]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/QPYTHIA/pythia-6.4.14.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
adding common functionality for the magnetic field to the component interface
[u/mrichter/AliRoot.git] / PYTHIA6 / QPYTHIA / pythia-6.4.14.f
CommitLineData
b527e4b2 1C*********************************************************************
2C*********************************************************************
3C* **
4C* November 2007 **
5C* **
6C* The Lund Monte Carlo **
7C* **
8C* PYTHIA version 6.4 **
9C* **
10C* Torbjorn Sjostrand **
11C* CERN/PH, CH-1211 Geneva, Switzerland **
12C* phone +41 - 22 - 767 82 27 **
13C* and **
14C* Department of Theoretical Physics **
15C* Lund University **
16C* Solvegatan 14A, S-223 62 Lund, Sweden **
17C* E-mail torbjorn@thep.lu.se **
18C* **
19C* SUSY and Technicolor parts by **
20C* Stephen Mrenna **
21C* Computing Division **
22C* Generators and Detector Simulation Group **
23C* Fermi National Accelerator Laboratory **
24C* MS 234, Batavia, IL 60510, USA **
25C* phone + 1 - 630 - 840 - 2556 **
26C* E-mail mrenna@fnal.gov **
27C* **
28C* New multiple interactions and more SUSY parts by **
29C* Peter Skands **
30C* Theoretical Physics Department **
31C* Fermi National Accelerator Laboratory **
32C* MS 106, Batavia, IL 60510, USA **
33C* and **
34C* CERN/PH, CH-1211 Geneva, Switzerland **
35C* phone +41 - 22 - 767 24 59 **
36C* E-mail skands@fnal.gov **
37C* **
38C* Several parts are written by Hans-Uno Bengtsson **
39C* PYSHOW is written together with Mats Bengtsson **
40C* PYMAEL is written by Emanuel Norrbin **
41C* advanced popcorn baryon production written by Patrik Eden **
42C* code for virtual photons mainly written by Christer Friberg **
43C* code for low-mass strings mainly written by Emanuel Norrbin **
44C* Bose-Einstein code mainly written by Leif Lonnblad **
45C* CTEQ parton distributions are by the CTEQ collaboration **
46C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
47C* SaS photon parton distributions together with Gerhard Schuler **
48C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
49C* MSSM Higgs mass calculation code by M. Carena, **
50C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
51C* PYGAUS adapted from CERN library (K.S. Kolbig) **
52C* NRQCD/colour octet production of onium by S. Wolf **
53C* **
54C* The latest program version and documentation is found on WWW **
55C* http://www.thep.lu.se/~torbjorn/Pythia.html **
56C* **
57C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2007 **
58C* **
59C*********************************************************************
60C*********************************************************************
61C *
62C List of subprograms in order of appearance, with main purpose *
63C (S = subroutine, F = function, B = block data) *
64C *
65C B PYDATA to contain all default values *
66C S PYCKBD to check that BLOCK DATA has been correctly loaded *
67C S PYTEST to test the proper functioning of the package *
68C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
69C *
70C S PYINIT to administer the initialization procedure *
71C S PYEVNT to administer the generation of an event *
72C S PYEVNW ditto, for new multiple interactions scenario *
73C S PYSTAT to print cross-section and other information *
74C S PYUPEV to administer the generation of an LHA hard process *
75C S PYUPIN to provide initialization needed for LHA input *
76C S PYLHEF to produce a Les Houches Event File from run *
77C S PYINRE to initialize treatment of resonances *
78C S PYINBM to read in beam, target and frame choices *
79C S PYINKI to initialize kinematics of incoming particles *
80C S PYINPR to set up the selection of included processes *
81C S PYXTOT to give total, elastic and diffractive cross-sect. *
82C S PYMAXI to find differential cross-section maxima *
83C S PYPILE to select multiplicity of pileup events *
84C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
85C S PYGAGA to handle lepton -> lepton + gamma branchings *
86C S PYRAND to select subprocess and kinematics for event *
87C S PYSCAT to set up kinematics and colour flow of event *
88C S PYEVOL handler for pT-ordered ISR and multiple interactions *
89C S PYSSPA to simulate initial state spacelike showers *
90C S PYPTIS to do pT-ordered initial state spacelike showers *
91C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
92C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
93C S PYPTMI to do pT-ordered multiple interactions *
94C F PYFCMP to give companion quark x*f distribution *
95C F PYPCMP to calculate momentum integral for companion quarks *
96C S PYUPRE to rearranges contents of the HEPEUP commonblock *
97C S PYADSH to administrate sequential final-state showers *
98C S PYVETO to allow the generation of an event to be aborted *
99C S PYRESD to perform resonance decays *
100C S PYMULT to generate multiple interactions - old scheme *
101C S PYREMN to add on target remnants - old scheme *
102C S PYMIGN to generate multiple interactions - new scheme *
103C S PYMIHK to connect colours in mult. int. - new scheme *
104C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
105C S PYMIHG to collapse two pairs of LHA1 colour tags. *
106C S PYMIRM to add on target remnants in mult. int.- new scheme *
107C S PYFSCR to perform final state colour reconnections - -"- *
108C S PYDIFF to set up kinematics for diffractive events *
109C S PYDISG to set up kinematics, remnant and showers for DIS *
110C S PYDOCU to compute cross-sections and handle documentation *
111C S PYFRAM to perform boosts between different frames *
112C S PYWIDT to calculate full and partial widths of resonances *
113C S PYOFSH to calculate partial width into off-shell channels *
114C S PYRECO to handle colour reconnection in W+W- events *
115C S PYKLIM to calculate borders of allowed kinematical region *
116C S PYKMAP to construct value of kinematical variable *
117C S PYSIGH to calculate differential cross-sections *
118C S PYSGQC auxiliary to PYSIGH for QCD processes *
119C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
120C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
121C S PYSGHG auxiliary to PYSIGH for Higgs processes *
122C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
123C S PYSGTC auxiliary to PYSIGH for technicolor processes *
124C S PYSGEX auxiliary to PYSIGH for various exotic processes *
125C S PYPDFU to evaluate parton distributions *
126C S PYPDFL to evaluate parton distributions at low x and Q^2 *
127C S PYPDEL to evaluate electron parton distributions *
128C S PYPDGA to evaluate photon parton distributions (generic) *
129C S PYGGAM to evaluate photon parton distributions (SaS sets) *
130C S PYGVMD to evaluate VMD part of photon parton distributions *
131C S PYGANO to evaluate anomalous part of photon PDFs *
132C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
133C S PYGDIR to evaluate direct contribution to photon PDFs *
134C S PYPDPI to evaluate pion parton distributions *
135C S PYPDPR to evaluate proton parton distributions *
136C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
137C S PYGRVL to evaluate the GRV 94L proton parton distributions *
138C S PYGRVM to evaluate the GRV 94M proton parton distributions *
139C S PYGRVD to evaluate the GRV 94D proton parton distributions *
140C F PYGRVV auxiliary to the PYGRV* routines *
141C F PYGRVW auxiliary to the PYGRV* routines *
142C F PYGRVS auxiliary to the PYGRV* routines *
143C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
144C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
145C S PYPDPO to evaluate old proton parton distributions *
146C F PYHFTH to evaluate threshold factor for heavy flavour *
147C S PYSPLI to find flavours left in hadron when one removed *
148C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
149C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
150C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
151C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
152C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
153C S PYSTBH to evaluate matrix element for t + b + H processes *
154C S PYTBHB auxiliary to PYSTBH *
155C S PYTBHG auxiliary to PYSTBH *
156C S PYTBHQ auxiliary to PYSTBH *
157C F PYTBHS auxiliary to PYSTBH *
158C *
159C S PYMSIN to initialize the supersymmetry simulation *
160C S PYSLHA to interface to SUSY spectrum and decay calculators *
161C S PYAPPS to determine MSSM parameters from SUGRA input *
162C S PYSUGI to determine MSSM parameters using ISASUSY *
163C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
164C F PYRNMQ to determine running squark masses *
165C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
166C S PYINOM to calculate neutralino/chargino mass eigenstates *
167C F PYRNM3 to determine running M3, gluino mass *
168C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
169C S PYHGGM to determine Higgs mass spectrum *
170C S PYSUBH to determine Higgs masses in the MSSM *
171C S PYPOLE to determine Higgs masses in the MSSM *
172C S PYRGHM auxiliary to PYPOLE *
173C S PYGFXX auxiliary to PYRGHM *
174C F PYFINT auxiliary to PYPOLE *
175C F PYFISB auxiliary to PYFINT *
176C S PYSFDC to calculate sfermion decay partial widths *
177C S PYGLUI to calculate gluino decay partial widths *
178C S PYTBBN to calculate 3-body decay of gluino to neutralino *
179C S PYTBBC to calculate 3-body decay of gluino to chargino *
180C S PYNJDC to calculate neutralino decay partial widths *
181C S PYCJDC to calculate chargino decay partial widths *
182C F PYXXZ6 auxiliary for ino 3-body decays *
183C F PYXXGA auxiliary for ino -> ino + gamma decay *
184C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
185C F PYX2XH auxiliary for ino -> ino + Higgs decay *
186C S PYHEXT to calculate non-SM Higgs decay partial widths *
187C F PYH2XX auxiliary for H -> ino + ino decay *
188C F PYGAUS to perform Gaussian integration *
189C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
190C F PYSIMP to perform Simpson integration *
191C F PYLAMF to evaluate the lambda kinematics function *
192C S PYTBDY to perform 3-body decay of gauginos *
193C S PYTECM to calculate techni_rho/omega masses *
194C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
195C S PYCMQR auxiliary to PYEICG *
196C S PYCMQ2 auxiliary to PYEICG *
197C S PYCDIV auxiliary to PYCMQR *
198C S PYCSRT auxiliary to PYCMQR *
199C S PYTHAG auxiliary to PYCMQR *
200C S PYCBAL auxiliary to PYEICG *
201C S PYCBA2 auxiliary to PYEICG *
202C S PYCRTH auxiliary to PYEICG *
203C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
204C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
205C S PYWIDX to calculate decay widths from within PYWIDT *
206C S PYRVSF to calculate R-violating sfermion decay widths *
207C S PYRVNE to calculate R-violating neutralino decay widths *
208C S PYRVCH to calculate R-violating chargino decay widths *
209C S PYRVGL to calculate R-violating gluino decay widths *
210C F PYRVSB auxiliary to PYRVSF *
211C S PYRVGW to calculate R-Violating 3-body widths *
212C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
213C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
214C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
215C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
216C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
217C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
218C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
219C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
220C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
221C *
222C S PY1ENT to fill one entry (= parton or particle) *
223C S PY2ENT to fill two entries *
224C S PY3ENT to fill three entries *
225C S PY4ENT to fill four entries *
226C S PY2FRM to interface to generic two-fermion generator *
227C S PY4FRM to interface to generic four-fermion generator *
228C S PY6FRM to interface to generic six-fermion generator *
229C S PY4JET to generate a shower from a given 4-parton config *
230C S PY4JTW to evaluate the weight od a shower history for above *
231C S PY4JTS to set up the parton configuration for above *
232C S PYJOIN to connect entries with colour flow information *
233C S PYGIVE to fill (or query) commonblock variables *
234C S PYONOF to allow easy control of particle decay modes *
235C S PYTUNE to select a predefined 'tune' for min-bias and UE *
236C S PYEXEC to administrate fragmentation and decay chain *
237C S PYPREP to rearrange showered partons along strings *
238C S PYSTRF to do string fragmentation of jet system *
239C S PYJURF to find boost to string junction rest frame *
240C S PYINDF to do independent fragmentation of one or many jets *
241C S PYDECY to do the decay of a particle *
242C S PYDCYK to select parton and hadron flavours in decays *
243C S PYKFDI to select parton and hadron flavours in fragm *
244C S PYNMES to select number of popcorn mesons *
245C S PYKFIN to calculate falvour prod. ratios from input params. *
246C S PYPTDI to select transverse momenta in fragm *
247C S PYZDIS to select longitudinal scaling variable in fragm *
248C S PYSHOW to do m-ordered timelike parton shower evolution *
249C S PYPTFS to do pT-ordered timelike parton shower evolution *
250C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
251C S PYBOEI to include Bose-Einstein effects (crudely) *
252C S PYBESQ auxiliary to PYBOEI *
253C F PYMASS to give the mass of a particle or parton *
254C F PYMRUN to give the running MSbar mass of a quark *
255C S PYNAME to give the name of a particle or parton *
256C F PYCHGE to give three times the electric charge *
257C F PYCOMP to compress standard KF flavour code to internal KC *
258C S PYERRM to write error messages and abort faulty run *
259C F PYALEM to give the alpha_electromagnetic value *
260C F PYALPS to give the alpha_strong value *
261C F PYANGL to give the angle from known x and y components *
262C F PYR to provide a random number generator *
263C S PYRGET to save the state of the random number generator *
264C S PYRSET to set the state of the random number generator *
265C S PYROBO to rotate and/or boost an event *
266C S PYEDIT to remove unwanted entries from record *
267C S PYLIST to list event record or particle data *
268C S PYLOGO to write a logo *
269C S PYUPDA to update particle data *
270C F PYK to provide integer-valued event information *
271C F PYP to provide real-valued event information *
272C S PYSPHE to perform sphericity analysis *
273C S PYTHRU to perform thrust analysis *
274C S PYCLUS to perform three-dimensional cluster analysis *
275C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
276C S PYJMAS to give high and low jet mass of event *
277C S PYFOWO to give Fox-Wolfram moments *
278C S PYTABU to analyze events, with tabular output *
279C *
280C S PYEEVT to administrate the generation of an e+e- event *
281C S PYXTEE to give the total cross-section at given CM energy *
282C S PYRADK to generate initial state photon radiation *
283C S PYXKFL to select flavour of primary qqbar pair *
284C S PYXJET to select (matrix element) jet multiplicity *
285C S PYX3JT to select kinematics of three-jet event *
286C S PYX4JT to select kinematics of four-jet event *
287C S PYXDIF to select angular orientation of event *
288C S PYONIA to perform generation of onium decay to gluons *
289C *
290C S PYBOOK to book a histogram *
291C S PYFILL to fill an entry in a histogram *
292C S PYFACT to multiply histogram contents by a factor *
293C S PYOPER to perform operations between histograms *
294C S PYHIST to print and reset all histograms *
295C S PYPLOT to print a single histogram *
296C S PYNULL to reset contents of a single histogram *
297C S PYDUMP to dump histogram contents onto a file *
298C *
299C S PYSTOP routine to handle Fortran STOP condition *
300C *
301C S PYKCUT dummy routine for user kinematical cuts *
302C S PYEVWT dummy routine for weighting events *
303C S UPINIT dummy routine to initialize user processes *
304C S UPEVNT dummy routine to generate a user process event *
305C S UPVETO dummy routine to abort event at parton level *
306C S PDFSET dummy routine to be removed when using PDFLIB *
307C S STRUCTM dummy routine to be removed when using PDFLIB *
308C S STRUCTP dummy routine to be removed when using PDFLIB *
309C S SUGRA dummy routine to be removed when linking with ISAJET *
310C F VISAJE dummy functn. to be removed when linking with ISAJET *
311C S SSMSSM dummy routine to be removed when linking with ISAJET *
312C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
313C S FHSETPARA dummy routine -"- FEYNHIGGS *
314C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
315C S PYTAUD dummy routine for interface to tau decay libraries *
316C S PYTIME dummy routine for giving date and time *
317C *
318C*********************************************************************
319
320C...PYDATA
321C...Default values for switches and parameters,
322C...and particle, decay and process data.
323
324 BLOCK DATA PYDATA
325
326C...Double precision and integer declarations.
327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
328 IMPLICIT INTEGER(I-N)
329 INTEGER PYK,PYCHGE,PYCOMP
330C...Commonblocks.
331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
333 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
334 COMMON/PYDAT4/CHAF(500,2)
335 CHARACTER CHAF*16
336 COMMON/PYDATR/MRPY(6),RRPY(100)
337 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
338 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
339 COMMON/PYINT1/MINT(400),VINT(400)
340 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
341 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
342 COMMON/PYINT4/MWID(500),WIDS(500,5)
343 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
344 COMMON/PYINT6/PROC(0:500)
345 CHARACTER PROC*28
346 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
347 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
348 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
349 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
350 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
351 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
352 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
353 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
354 & AU(3,3),AD(3,3),AE(3,3)
355 COMMON/PYLH3C/CPRO(2),CVER(2)
356 CHARACTER CPRO*12,CVER*12
357 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
358 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
359 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,
360 &/PYBINS/,/PYLH3P/,/PYLH3C/
361
362C...PYDAT1, containing status codes and most parameters.
363 DATA MSTU/
364 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
365 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
366 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
367 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
368 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
369 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
370 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
371 7 30*0,
372 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
374 & 80*0/
375 DATA (PARU(I),I=1,100)/
376 & 3.141592653589793D0, 6.283185307179586D0,
377 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
378 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
379 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
380 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
381 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
382 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
383 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
384 6 40*0D0/
385 DATA (PARU(I),I=101,200)/
386 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
387 & 0D0, 0D0, 0D0, 0D0, 0D0,
388 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
389 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
390 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
391 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
392 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
393 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
394 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
395 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
396 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
397 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
398 DATA MSTJ/
399 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
400 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
401 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
402 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
403 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
404 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
405 6 40*0,
406 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
407 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
408 2 80*0/
409 DATA PARJ/
410 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
411 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
412 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
413 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
414 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
415 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
416 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
417 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
418 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
419 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
420 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
421 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
422 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
423 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
424 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
425 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
426 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
427 4 10*0D0,
428 5 10*0D0,
429 6 10*0D0,
430 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
431 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
432 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
433 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
434 9 5*0D0/
435
436C...PYDAT2, with particle data and flavour treatment parameters.
437 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
438 &-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,
439 &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,
440 &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,
441 &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,
442 &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,
443 &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,
444 &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,
445 &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,
446 &7*0,3,131*0/
447 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
448 &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,
449 &-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,
450 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,133*0/
451 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
452 &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,
453 &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,
454 &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,7*0,1,131*0/
455 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
456 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
457 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
458 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
459 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
460 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
461 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
462 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
463 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
464 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
465 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
466 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
467 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
468 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
469 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
470 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
471 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
472 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
473 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
474 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
475 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
476 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
477 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
478 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
479 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
480 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
481 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
482 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
483 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
484 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
485 &3000115,3000215,131*0/
486 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
487 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
488 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
489 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
490 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
491 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
492 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
493 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
494 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
495 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
496 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
497 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
498 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
499 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
500 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
501 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
502 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
503 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
504 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
505 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
506 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
507 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
508 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
509 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
510 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
511 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
512 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
513 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
514 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
515 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
516 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
517 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
518 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
519 &3*9.5D0,2*250D0,131*0D0/
520 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
521 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
522 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
523 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
524 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
525 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
526 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
527 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
528 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
529 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
530 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
531 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
532 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
533 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
534 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
535 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
536 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
537 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
538 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
539 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
540 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
541 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
542 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
543 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
544 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
545 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
546 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
547 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
548 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
549 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
550 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
551 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
552 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
553 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
554 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
555 &8.80013D0,13*0D0,2.54987D0,2.84456D0,131*0D0/
556 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
557 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
558 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
559 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
560 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
561 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
562 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
563 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
564
565 DATA PARF/
566 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
567 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
568 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
569 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
570 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
571 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
572 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
573 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
574 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
575 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
576 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
577 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
578 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
579 3 60*0D0,
580 4 0.2D0, 0.5D0, 8*0D0,
581 5 1800*0D0/
582 DATA ((VCKM(I,J),J=1,4),I=1,4)/
583 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
584 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
585 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
586 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
587
588C...PYDAT3, with particle decay parameters and data.
589 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
590 &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,
591 &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,
592 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1,131*0/
593 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
594 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
595 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
596 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
597 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
598 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
599 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
600 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
601 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
602 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
603 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
604 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
605 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
606 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
607 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
608 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
609 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
610 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
611 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
612 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
613 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
614 &4214,4215,4216,4296,4322,131*0/
615 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
616 &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,
617 &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,
618 &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,
619 &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,
620 &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,
621 &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,
622 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
623 &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
624 &3*22,15,12,2*7,7*0,6*1,26,30,131*0/
625 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
626 &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,
627 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
628 &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
629 &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
630 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
631 &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
632 &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
633 &5*-1,3*1,-1,3649*0/
634 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
635 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
636 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
637 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
638 &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,
639 &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,
640 &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,
641 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
642 &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,
643 &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,
644 &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,
645 &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,
646 &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,
647 &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
648 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
649 &16*32,3653*0/
650 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
651 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
652 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
653 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
654 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
655 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
656 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
657 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
658 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
659 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
660 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
661 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
662 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
663 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
664 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
665 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
666 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
667 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
668 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
669 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
670 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
671 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
672 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
673 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
674 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
675 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
676 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
677 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
678 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
679 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
680 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
681 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
682 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
683 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
684 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
685 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
686 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
687 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
688 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
689 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
690 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
691 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
692 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
693 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
694 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
695 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
696 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
697 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
698 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
699 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
700 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
701 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
702 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
703 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
704 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
705 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
706 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
707 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
708 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
709 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
710 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
711 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
712 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
713 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
714 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
715 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
716 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
717 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
718 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
719 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
720 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
721 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
722 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
723 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
724 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
725 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
726 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
727 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
728 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
729 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
730 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
731 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
732 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
733 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
734 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
735 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
736 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
737 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
738 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
739 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
740 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
741 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
742 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
743 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
744 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
745 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
746 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
747 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
748 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
749 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
750 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
751 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
752 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
753 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
754 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
755 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
756 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
757 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
758 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
759 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
760 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
761 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
762 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
763 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
764 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
765 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
766 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
767 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
768 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
769 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
770 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
771 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
772 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
773 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
774 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
775 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
776 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
777 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
778 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
779 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
780 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
781 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
782 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
783 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
784 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
785 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
786 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
787 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
788 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
789 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
790 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
791 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
792 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
793 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
794 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
795 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
796 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
797 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
798 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
799 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
800 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
801 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
802 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
803 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
804 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
805 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
806 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
807 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
808 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
809 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
810 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
811 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
812 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
813 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
814 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
815 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
816 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
817 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
818 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
819 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
820 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
821 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
822 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
823 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
824 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
825 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
826 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
827 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
828 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
829 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
830 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
831 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
832 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
833 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
834 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
835 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
836 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
837 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
838 &2*0.011947D0,0.011946D0,0D0,3649*0D0/
839 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
840 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
841 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
842 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
843 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
844 &-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,
845 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
846 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
847 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
848 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
849 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
850 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
851 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
852 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
853 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
854 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
855 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
856 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
857 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
858 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
859 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
860 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
861 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
862 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
863 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
864 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
865 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
866 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
867 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
868 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
869 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
870 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
871 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
872 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
873 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
874 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
875 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
876 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
877 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
878 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
879 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
880 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
881 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
882 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
883 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
884 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
885 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
886 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
887 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
888 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
889 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
890 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
891 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
892 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
893 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
894 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
895 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
896 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
897 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
898 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
899 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
900 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
901 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
902 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
903 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
904 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
905 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
906 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
907 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
908 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
909 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
910 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
911 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
912 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
913 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
914 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
915 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
916 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
917 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
918 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
919 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
920 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
921 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
922 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
923 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
924 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
925 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
926 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
927 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
928 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
929 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
930 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
931 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
932 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
933 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
934 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
935 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
936 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
937 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
938 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
939 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
940 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
941 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
942 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
943 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
944 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
945 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
946 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
947 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
948 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
949 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
950 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
951 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
952 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
953 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
954 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
955 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
956 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
957 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
958 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
959 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
960 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
961 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
962 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
963 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
964 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
965 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
966 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
967 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
968 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
969 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
970 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
971 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
972 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
973 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
974 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
975 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
976 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
977 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
978 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
979 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
980 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
981 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
982 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
983 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
984 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
985 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
986 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
987 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
988 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
989 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
990 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
991 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
992 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
993 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
994 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
995 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
996 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
997 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
998 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
999 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1000 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1001 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1002 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1003 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1004 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1005 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1006 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1007 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1008 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1009 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1010 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1011 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1012 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1013 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1014 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1015 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1016 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1017 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1018 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1019 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1020 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1021 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1022 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1023 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1024 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1025 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1026 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1027 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1028 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1029 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1030 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1031 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1032 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1033 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1034 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1035 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1036 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1037 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1038 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1039 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1040 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1041 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1042 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1043 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1044 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1045 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1046 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1047 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1048 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1049 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1050 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1051 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1052 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1053 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1054 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1055 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1056 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1057 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1058 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1059 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1060 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1061 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1062 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1063 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1064 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1065 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1066 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1067 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1068 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1069 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1070 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1071 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1072 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1073 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1074 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1075 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1076 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1077 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1078 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1079 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1080 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1081 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1082 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1083 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1084 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1085 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1086 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1087 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1088 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1089 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1090 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1091 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1092 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1093 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1094 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1095 &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,
1096 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1097 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1098 &21,22,23,24,9*11,9*-11,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/
1099 DATA (KFDP(I,1),I=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,
1100 &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1101 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1102 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1103 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1104 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1105 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1106 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1107 &-11,-13,-15,-17,3649*0/
1108 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,
1109 &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,
1110 &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,
1111 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1112 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1113 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1114 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1115 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1116 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1117 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1118 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1119 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1120 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1121 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1122 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1123 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1124 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1125 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1126 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1127 &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/
1128 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1129 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1130 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1131 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1132 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1133 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1134 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1135 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1136 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1137 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1138 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1139 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1140 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1141 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1142 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1143 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1144 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1145 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1146 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1147 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1148 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1149 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1150 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1151 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1152 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1153 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1154 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1155 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1156 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1157 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1158 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1159 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1160 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1161 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1162 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1163 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1164 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1165 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1166 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1167 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1168 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1169 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1170 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1171 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1172 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1173 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1174 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1175 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1176 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1177 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1178 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1179 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1180 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1181 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1182 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1183 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1184 &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,
1185 &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,
1186 &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,
1187 &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/
1188 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1189 &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,
1190 &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,
1191 &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,
1192 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1193 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1194 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1195 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1196 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1197 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1198 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1199 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1200 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1201 &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,
1202 &-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,
1203 &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,
1204 &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,
1205 &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,
1206 &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,
1207 &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/
1208 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1209 &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,
1210 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1211 &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,
1212 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1213 &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,
1214 &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,
1215 &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,
1216 &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,
1217 &-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,
1218 &-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,
1219 &-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,
1220 &-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,
1221 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1222 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1223 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1224 &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,
1225 &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,
1226 &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,
1227 &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/
1228 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1229 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1230 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1231 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1232 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1233 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1234 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1235 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1236 &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,
1237 &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,
1238 &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,
1239 &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,
1240 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1241 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1242 &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,
1243 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1244 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1245 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1246 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1247 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1248 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1249 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1250 &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,
1251 &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,
1252 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1253 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1254 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1255 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1256 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1257 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1258 &-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,
1259 &-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,
1260 &-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,
1261 &-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,
1262 &-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,
1263 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1264 &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,
1265 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1266 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1267 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1268 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1269 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1270 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1271 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1272 &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,
1273 &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,
1274 &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,
1275 &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,
1276 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1277 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1278 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1279 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1280 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1281 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1282 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1283 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1284 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1285 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1286 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1287 &-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/
1288 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1289 &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,
1290 &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,
1291 &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,
1292 &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,
1293 &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,
1294 &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,
1295 &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,
1296 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1297 &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,
1298 &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,
1299 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1300 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1301 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1302 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1303 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1304 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1305 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1306 &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,
1307 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1308 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1309 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1310 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1311 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1312 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1313 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1314 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1315 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1316 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1317 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1318 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1319 &3649*0/
1320 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1321 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1322 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1323 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1324 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1325 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1326 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1327 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1328 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1329 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1330 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1331 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1332 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1333 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1334 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1335 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1336 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1337 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1338 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1339 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1340 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1341 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1342 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1343 &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,
1344 &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,
1345 &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,
1346 &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,
1347 &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,
1348 &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,
1349 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1350 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1351 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1352 &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,
1353 &-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,
1354 &-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,
1355 &-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,
1356 &-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,
1357 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1358 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1359 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1360 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1361 &-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,
1362 &-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,
1363 &-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,
1364 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1365 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1366 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1367 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1368 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1369 &-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,
1370 &-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,
1371 &-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,
1372 &-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,
1373 &-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,
1374 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1375 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1376 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1377 &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,
1378 &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,
1379 &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/
1380 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1381 &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,
1382 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1383 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1384 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1385 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1386 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1387 &-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,
1388 &-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,
1389 &-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,
1390 &-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,
1391 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1392 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1393 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1394 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1395 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1396 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1397 &-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,
1398 &-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,
1399 &-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/
1400 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1401 &-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,
1402 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1403 &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,
1404 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1405 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1406 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1407 &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,
1408 &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,
1409 &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,
1410 &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,
1411 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
1412 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1413 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1414 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1415 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1416 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1417 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1418 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1419 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1420 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1421 &-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,
1422 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1423 &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,
1424 &162*81,31*0,-211,111,6516*0/
1425 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1426 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1427 &3*111,-211,111,7193*0/
1428
1429C...PYDAT4, with particle names (character strings).
1430 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1431 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1432 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1433 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1434 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1435 &'junction',' ','system','cluster','string','indep.','CMshower',
1436 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1437 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1438 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1439 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1440 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1441 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1442 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1443 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1444 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1445 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1446 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1447 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1448 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1449 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1450 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1451 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1452 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1453 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1454 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1455 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1456 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1457 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1458 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1459 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1460 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1461 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1462 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1463 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1464 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1465 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1466 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1467 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1468 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1469 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1470 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1471 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1472 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1473 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1474 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1475 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1476 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',131*' '/
1477 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1478 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1479 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1480 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1481 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1482 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1483 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1484 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1485 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1486 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1487 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1488 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1489 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1490 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1491 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1492 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1493 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1494 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1495 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1496 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1497 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1498 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1499 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1500 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1501 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1502 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1503 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1504 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1505 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1506 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1507 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1508 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1509 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1510 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1511 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1512 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1513 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1514 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1515 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1516 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1517 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1518 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1519 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1520 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1521 &131*' '/
1522
1523C...PYDATR, with initial values for the random number generator.
1524 DATA MRPY/19780503,0,0,97,33,0/
1525
1526C...Default values for allowed processes and kinematics constraints.
1527 DATA MSEL/1/
1528 DATA MSUB/500*0/
1529 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1530 &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,
1531 &6*1,4*0,4*1,16*0/
1532 DATA CKIN/
1533 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1534 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1535 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1536 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1537 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1538 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1539 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1540 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1541 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1542 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1543 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1544 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1545 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1546 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1547 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1548 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1549 8 120*0D0/
1550
1551C...Default values for main switches and parameters. Reset information.
1552 DATA (MSTP(I),I=1,100)/
1553 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1554 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1555 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1556 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1557 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1558 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1559 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1560 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1561 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1562 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1563 DATA (MSTP(I),I=101,200)/
1564 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1565 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1566 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1567 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1568 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1569 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1570 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1571 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1572 8 6, 414, 2007, 11, 19, 0, 0, 0, 0, 0,
1573 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1574 DATA (PARP(I),I=1,100)/
1575 & 0.25D0, 10D0, 8*0D0,
1576 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1577 2 10*0D0,
1578 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1579 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1580 5 10*0D0,
1581 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1582 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1583 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1584 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
1585 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1586 DATA (PARP(I),I=101,200)/
1587 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1588 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1589 2 1.0D0, 0.4D0, 8*0D0,
1590 3 0.01D0, 9*0D0,
1591 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1592 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1593 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1594 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1595 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1596 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1597 8 0.3D0, 0.64D0,
1598 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1599 DATA MSTI/200*0/
1600 DATA PARI/200*0D0/
1601 DATA MINT/400*0/
1602 DATA VINT/400*0D0/
1603
1604C...Constants for the generation of the various processes.
1605 DATA (ISET(I),I=1,100)/
1606 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1607 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1608 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1609 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1610 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1611 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1612 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1613 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1614 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1615 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1616 DATA (ISET(I),I=101,200)/
1617 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1618 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1619 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1620 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1621 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1622 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1623 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1624 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1625 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1626 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1627 DATA (ISET(I),I=201,300)/
1628 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1629 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1630 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1631 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1632 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1633 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1634 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1635 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1636 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1637 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1638 DATA (ISET(I),I=301,500)/
1639 & 2, 39*-2,
1640 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1641 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1642 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1643 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1644 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1645 9 1, 1, 2, 2, 2, 5*-2,
1646 & 5, 5, 18*-2,
1647 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1648 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1649 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1650 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1651 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1652 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1653 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1654 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1655 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1656 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1657 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1658 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1659 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1660 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1661 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1662 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1663 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1664 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1665 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1666 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1667 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1668 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1669 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1670 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1671 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1672 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1673 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1674 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1675 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1676 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1677 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1678 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1679 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1680 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1681 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1682 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1683 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1684 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1685 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1686 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1687 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1688 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1689 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1690 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1691 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1692 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1693 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1694 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1695 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1696 & 1000011, 1000011, 2000011, 2000011, 1000011,
1697 & 2000011, 1000013, 1000013, 2000013, 2000013,
1698 & 1000013, 2000013, 1000015, 1000015, 2000015,
1699 & 2000015, 1000015, 2000015, 1000011, 1000012,
1700 1 1000015, 1000016, 2000015, 1000016, 1000012,
1701 1 1000012, 1000016, 1000016, 0, 0,
1702 1 1000022, 1000022, 1000023, 1000023, 1000025,
1703 1 1000025, 1000035, 1000035, 1000022, 1000023,
1704 2 1000022, 1000025, 1000022, 1000035, 1000023,
1705 2 1000025, 1000023, 1000035, 1000025, 1000035,
1706 2 1000024, 1000024, 1000037, 1000037, 1000024,
1707 2 1000037, 1000022, 1000024, 1000023, 1000024,
1708 3 1000025, 1000024, 1000035, 1000024, 1000022,
1709 3 1000037, 1000023, 1000037, 1000025, 1000037,
1710 3 1000035, 1000037, 1000021, 1000022, 1000021,
1711 3 1000023, 1000021, 1000025, 1000021, 1000035/
1712 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1713 4 1000021, 1000024, 1000021, 1000037, 1000021,
1714 4 1000021, 1000021, 1000021, 0, 0,
1715 4 1000002, 1000022, 2000002, 1000022, 1000002,
1716 4 1000023, 2000002, 1000023, 1000002, 1000025,
1717 5 2000002, 1000025, 1000002, 1000035, 2000002,
1718 5 1000035, 1000001, 1000024, 2000005, 1000024,
1719 5 1000001, 1000037, 2000005, 1000037, 1000002,
1720 5 1000021, 2000002, 1000021, 0, 0,
1721 6 1000006, 1000006, 2000006, 2000006, 1000006,
1722 6 2000006, 1000006, 1000006, 2000006, 2000006,
1723 6 0, 0, 0, 0, 0,
1724 6 0, 0, 0, 0, 0,
1725 7 1000002, 1000002, 2000002, 2000002, 1000002,
1726 7 2000002, 1000002, 1000002, 2000002, 2000002,
1727 7 1000002, 2000002, 1000002, 1000002, 2000002,
1728 7 2000002, 1000002, 1000002, 2000002, 2000002/
1729 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1730 8 1000005, 1000002, 2000005, 2000002, 1000005,
1731 8 2000002, 1000005, 1000002, 2000005, 2000002,
1732 8 1000005, 2000002, 1000005, 1000005, 2000005,
1733 8 2000005, 1000005, 1000005, 2000005, 2000005,
1734 9 1000005, 1000005, 2000005, 2000005, 1000005,
1735 9 2000005, 1000005, 1000021, 2000005, 1000021,
1736 9 1000005, 2000005, 37, 25, 37,
1737 9 35, 36, 25, 36, 35,
1738 & 37, 37, 78*0,
1739 4 9900041, 0, 9900042, 0, 9900041,
1740 4 11, 9900042, 11, 9900041, 13,
1741 4 9900042, 13, 9900041, 15, 9900042,
1742 4 15, 9900041, 9900041, 9900042, 9900042/
1743 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1744 5 9900041, 0, 9900042, 0, 9900023,
1745 5 0, 9900024, 0, 0, 0,
1746 5 0, 0, 0, 0, 0,
1747 5 0, 0, 0, 0, 0,
1748 6 24, 24, 24, 3000211, 3000211,
1749 6 3000211, 22, 3000111, 22, 3000221,
1750 6 23, 3000111, 23, 3000221, 24,
1751 6 3000211, 0, 0, 24, 23,
1752 7 24, 3000111, 3000211, 23, 3000211,
1753 7 3000111, 22, 3000211, 23, 3000211,
1754 7 24, 3000111, 24, 3000221, 22,
1755 7 24, 22, 23, 23, 23,
1756 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1757 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1758 9 5000039, 0, 5000039, 0, 21,
1759 9 5000039, 0, 5000039, 21, 5000039,
1760 9 10*0/
1761 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1762 & 37, 6, 37, 6, 36*0,
1763 2 443, 21, 9900443, 21, 9900441,
1764 2 21, 9910441, 21, 0, 9900443,
1765 2 0, 9900441, 0, 9910441, 21,
1766 2 9900443, 21, 9900441, 21, 9910441,
1767 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1768 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1769 6 553, 21, 9900553, 21, 9900551,
1770 6 21, 9910551, 21, 0, 9900553,
1771 6 0, 9900551, 0, 9910551, 21,
1772 6 9900553, 21, 9900551, 21, 9910551,
1773 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1774 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1775 DATA COEF/10000*0D0/
1776 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1777 &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,
1778 &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,
1779 &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,
1780 &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,
1781 &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,
1782 &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,
1783 &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,
1784 &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,
1785 &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,
1786 &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/
1787
1788C...Treatment of resonances.
1789 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1790 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,131*0/
1791
1792C...Character constants: name of processes.
1793 DATA PROC(0)/ 'All included subprocesses '/
1794 DATA (PROC(I),I=1,20)/
1795 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1796 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1797 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1798 &' ', 'W+ + W- -> h0 ',
1799 &' ', 'f + f'' -> f + f'' (QFD) ',
1800 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1801 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1802 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1803 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1804 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1805 DATA (PROC(I),I=21,40)/
1806 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1807 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1808 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1809 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1810 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1811 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1812 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1813 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1814 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1815 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1816 DATA (PROC(I),I=41,60)/
1817 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1818 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1819 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1820 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1821 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1822 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1823 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1824 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1825 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1826 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1827 DATA (PROC(I),I=61,80)/
1828 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1829 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1830 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1831 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1832 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1833 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1834 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1835 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1836 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1837 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1838 DATA (PROC(I),I=81,100)/
1839 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1840 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1841 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1842 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1843 8'g + g -> chi_2c + g ', ' ',
1844 9'Elastic scattering ', 'Single diffractive (XB) ',
1845 9'Single diffractive (AX) ', 'Double diffractive ',
1846 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1847 9' ', ' ',
1848 9'q + gamma* -> q ', ' '/
1849 DATA (PROC(I),I=101,120)/
1850 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1851 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1852 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1853 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1854 &' ', 'f + fbar -> gamma + h0 ',
1855 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1856 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1857 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1858 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1859 1' ', ' '/
1860 DATA (PROC(I),I=121,140)/
1861 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1862 2'f + f'' -> f + f'' + h0 ',
1863 2'f + f'' -> f" + f"'' + h0 ',
1864 2' ', ' ',
1865 2' ', ' ',
1866 2' ', ' ',
1867 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1868 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1869 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1870 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1871 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1872 DATA (PROC(I),I=141,160)/
1873 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1874 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1875 4'q + l -> LQ ', 'e + gamma -> e* ',
1876 4'd + g -> d* ', 'u + g -> u* ',
1877 4'g + g -> eta_tc ', ' ',
1878 5'f + fbar -> H0 ', 'g + g -> H0 ',
1879 5'gamma + gamma -> H0 ', ' ',
1880 5' ', 'f + fbar -> A0 ',
1881 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1882 5' ', ' '/
1883 DATA (PROC(I),I=161,180)/
1884 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1885 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1886 6'f + fbar -> f'' + fbar'' (g/Z)',
1887 6'f +fbar'' -> f" + fbar"'' (W) ',
1888 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1889 6'q + qbar -> e + e* ', ' ',
1890 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1891 7'f + f'' -> f + f'' + H0 ',
1892 7'f + f'' -> f" + f"'' + H0 ',
1893 7' ', 'f + fbar -> Z0 + A0 ',
1894 7'f + fbar'' -> W+/- + A0 ',
1895 7'f + f'' -> f + f'' + A0 ',
1896 7'f + f'' -> f" + f"'' + A0 ',
1897 7' '/
1898 DATA (PROC(I),I=181,200)/
1899 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1900 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1901 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1902 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1903 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1904 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1905 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1906 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1907 9' ', ' ',
1908 9' ', ' '/
1909 DATA (PROC(I),I=201,220)/
1910 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1911 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1912 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1913 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1914 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1915 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1916 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1917 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1918 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1919 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1920 DATA (PROC(I),I=221,240)/
1921 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1922 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1923 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1924 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1925 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1926 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1927 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1928 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1929 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1930 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1931 DATA (PROC(I),I=241,260)/
1932 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1933 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1934 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1935 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1936 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1937 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1938 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1939 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1940 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1941 5'qj + g -> ~qj_R + ~g ', ' '/
1942 DATA (PROC(I),I=261,300)/
1943 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1944 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1945 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1946 6' ', ' ',
1947 6' ', ' ',
1948 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1949 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1950 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1951 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1952 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1953 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1954 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1955 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1956 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1957 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1958 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1959 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1960 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1961 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1962 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1963 DATA (PROC(I),I=301,340)/
1964 &'f + fbar -> H+ + H- ', 39*' '/
1965 DATA (PROC(I),I=341,380)/
1966 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1967 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1968 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1969 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1970 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1971 5'f + f -> f'' + f'' + H_L++/-- ',
1972 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1973 5'f + fbar'' -> W_R+/- ',5*' ',
1974 6' ', 'f + fbar -> W_L+ W_L- ',
1975 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1976 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1977 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1978 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1979 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1980 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1981 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1982 7'f + fbar'' -> W+/- pi_T0 ',
1983 7'f + fbar'' -> W+/- pi_T0'' ',
1984 7'f + fbar'' -> gamma W+/- (ETC)','f + fbar -> gamma Z0 (ETC)',
1985 7'f + fbar -> Z0 Z0 (ETC)'/
1986 DATA (PROC(I),I=381,420)/
1987 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1988 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1989 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1990 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1991 8' ', ' ',
1992 9'f + fbar -> G* ', 'g + g -> G* ',
1993 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1994 9'g + g -> g + G* ', ' ',
1995 9 4*' ',
1996 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
1997 & 18*' '/
1998 DATA (PROC(I),I=421,460)/
1999 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2000 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2001 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2002 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2003 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2004 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2005 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2006 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2007 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2008 3'q + q~ -> g + cc~[3P2(1)] ',
2009 3 21 *' '/
2010 DATA (PROC(I),I=461,500)/
2011 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2012 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2013 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2014 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2015 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2016 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2017 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2018 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2019 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2020 7'q + q~ -> g + bb~[3P2(1)] ',
2021 7 21 *' '/
2022
2023C...Cross sections and slope offsets.
2024 DATA SIGT/294*0D0/
2025
2026C...Supersymmetry switches and parameters.
2027 DATA IMSS/0,
2028 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2029 1 89*0/
2030 DATA RMSS/0D0,
2031 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2032 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2033 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2034 3 10*0D0,
2035 4 0D0,1D0,8*0D0,
2036 5 49*0D0/
2037C...Initial values for R-violating SUSY couplings.
2038C...Should not be changed here. See PYMSIN.
2039 DATA RVLAM/27*0D0/
2040 DATA RVLAMP/27*0D0/
2041 DATA RVLAMB/27*0D0/
2042
2043C...Technicolor switches and parameters
2044 DATA ITCM/0,
2045 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2046 1 89*0/
2047 DATA RTCM/0D0,
2048 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2049 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2050 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2051 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2052 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2053 4 200D0, 48*0D0/
2054
2055C...Data for histogramming routines.
2056 DATA IHIST/1000,20000,55,1/
2057 DATA INDX/1000*0/
2058
2059C...Data for SUSY Les Houches Accord.
2060 DATA CPRO/'PYTHIA ','PYTHIA '/
2061 DATA CVER/'6.4 ','6.4 '/
2062 DATA MODSEL/200*0/
2063 DATA PARMIN/100*0D0/
2064 DATA RMSOFT/101*0D0/
2065 DATA AU/9*0D0/
2066 DATA AD/9*0D0/
2067 DATA AE/9*0D0/
2068
2069 END
2070
2071C*********************************************************************
2072
2073C...PYCKBD
2074C...Check that BLOCK DATA PYDATA has been loaded.
2075C...Should not be required, except that some compilers/linkers
2076C...are pretty buggy in this respect.
2077
2078 SUBROUTINE PYCKBD
2079
2080C...Double precision and integer declarations.
2081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2082 IMPLICIT INTEGER(I-N)
2083 INTEGER PYK,PYCHGE,PYCOMP
2084C...Commonblocks.
2085 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2088 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2089 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2090 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2091 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2092
2093C...Check a few variables to see they have been sensibly initialized.
2094 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2095 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2096 &MSTP(1).GT.5) THEN
2097C...If not, abort the run right away.
2098 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2099 WRITE(*,*) 'The program execution is stopped now!'
2100 CALL PYSTOP(8)
2101 ENDIF
2102
2103 RETURN
2104 END
2105
2106C*********************************************************************
2107
2108C...PYTEST
2109C...A simple program (disguised as subroutine) to run at installation
2110C...as a check that the program works as intended.
2111
2112 SUBROUTINE PYTEST(MTEST)
2113
2114C...Double precision and integer declarations.
2115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2116 IMPLICIT INTEGER(I-N)
2117 INTEGER PYK,PYCHGE,PYCOMP
2118C...Commonblocks.
2119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2121 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2122 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2123 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2125 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2126C...Local arrays.
2127 DIMENSION PSUM(5),PINI(6),PFIN(6)
2128
2129C...Save defaults for values that are changed.
2130 MSTJ1=MSTJ(1)
2131 MSTJ3=MSTJ(3)
2132 MSTJ11=MSTJ(11)
2133 MSTJ42=MSTJ(42)
2134 MSTJ43=MSTJ(43)
2135 MSTJ44=MSTJ(44)
2136 PARJ17=PARJ(17)
2137 PARJ22=PARJ(22)
2138 PARJ43=PARJ(43)
2139 PARJ54=PARJ(54)
2140 MST101=MSTJ(101)
2141 MST104=MSTJ(104)
2142 MST105=MSTJ(105)
2143 MST107=MSTJ(107)
2144 MST116=MSTJ(116)
2145
2146C...First part: loop over simple events to be generated.
2147 IF(MTEST.GE.1) CALL PYTABU(20)
2148 NERR=0
2149 DO 180 IEV=1,500
2150
2151C...Reset parameter values. Switch on some nonstandard features.
2152 MSTJ(1)=1
2153 MSTJ(3)=0
2154 MSTJ(11)=1
2155 MSTJ(42)=2
2156 MSTJ(43)=4
2157 MSTJ(44)=2
2158 PARJ(17)=0.1D0
2159 PARJ(22)=1.5D0
2160 PARJ(43)=1D0
2161 PARJ(54)=-0.05D0
2162 MSTJ(101)=5
2163 MSTJ(104)=5
2164 MSTJ(105)=0
2165 MSTJ(107)=1
2166 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2167
2168C...Ten events each for some single jets configurations.
2169 IF(IEV.LE.50) THEN
2170 ITY=(IEV+9)/10
2171 MSTJ(3)=-1
2172 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2173 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2174 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2175 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2176 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2177 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2178
2179C...Ten events each for some simple jet systems; string fragmentation.
2180 ELSEIF(IEV.LE.130) THEN
2181 ITY=(IEV-41)/10
2182 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2183 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2184 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2185 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2186 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2187 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2188 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2189 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2190 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2191
2192C...Seventy events with independent fragmentation and momentum cons.
2193 ELSEIF(IEV.LE.200) THEN
2194 ITY=1+(IEV-131)/16
2195 MSTJ(2)=1+MOD(IEV-131,4)
2196 MSTJ(3)=1+MOD((IEV-131)/4,4)
2197 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2198 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2199 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2200 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2201 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2202 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2203
2204C...A hundred events with random jets (check invariant mass).
2205 ELSEIF(IEV.LE.300) THEN
2206 100 DO 110 J=1,5
2207 PSUM(J)=0D0
2208 110 CONTINUE
2209 NJET=2D0+6D0*PYR(0)
2210 DO 130 I=1,NJET
2211 KFL=21
2212 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2213 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2214 EJET=5D0+20D0*PYR(0)
2215 THETA=ACOS(2D0*PYR(0)-1D0)
2216 PHI=6.2832D0*PYR(0)
2217 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2218 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2219 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2220 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2221 DO 120 J=1,4
2222 PSUM(J)=PSUM(J)+P(I,J)
2223 120 CONTINUE
2224 130 CONTINUE
2225 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2226 & (PSUM(5)+PARJ(32))**2) GOTO 100
2227
2228C...Fifty e+e- continuum events with matrix elements.
2229 ELSEIF(IEV.LE.350) THEN
2230 MSTJ(101)=2
2231 CALL PYEEVT(0,40D0)
2232
2233C...Fifty e+e- continuum event with varying shower options.
2234 ELSEIF(IEV.LE.400) THEN
2235 MSTJ(42)=1+MOD(IEV,2)
2236 MSTJ(43)=1+MOD(IEV/2,4)
2237 MSTJ(44)=MOD(IEV/8,3)
2238 CALL PYEEVT(0,90D0)
2239
2240C...Fifty e+e- continuum events with coherent shower.
2241 ELSEIF(IEV.LE.450) THEN
2242 CALL PYEEVT(0,500D0)
2243
2244C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2245 ELSE
2246 CALL PYONIA(5,9.46D0)
2247 ENDIF
2248
2249C...Generate event. Find total momentum, energy and charge.
2250 DO 140 J=1,4
2251 PINI(J)=PYP(0,J)
2252 140 CONTINUE
2253 PINI(6)=PYP(0,6)
2254 CALL PYEXEC
2255 DO 150 J=1,4
2256 PFIN(J)=PYP(0,J)
2257 150 CONTINUE
2258 PFIN(6)=PYP(0,6)
2259
2260C...Check conservation of energy, momentum and charge;
2261C...usually exact, but only approximate for single jets.
2262 MERR=0
2263 IF(IEV.LE.50) THEN
2264 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2265 & MERR=MERR+1
2266 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2267 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2268 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2269 ELSE
2270 DO 160 J=1,4
2271 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2272 160 CONTINUE
2273 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2274 ENDIF
2275 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2276 & (PFIN(J),J=1,4),PFIN(6)
2277
2278C...Check that all KF codes are known ones, and that partons/particles
2279C...satisfy energy-momentum-mass relation. Store particle statistics.
2280 DO 170 I=1,N
2281 IF(K(I,1).GT.20) GOTO 170
2282 IF(PYCOMP(K(I,2)).EQ.0) THEN
2283 WRITE(MSTU(11),5100) I
2284 MERR=MERR+1
2285 ENDIF
2286 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2287 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2288 & THEN
2289 WRITE(MSTU(11),5200) I
2290 MERR=MERR+1
2291 ENDIF
2292 170 CONTINUE
2293 IF(MTEST.GE.1) CALL PYTABU(21)
2294
2295C...List all erroneous events and some normal ones.
2296 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2297 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2298 CALL PYLIST(2)
2299 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2300 CALL PYLIST(1)
2301 ENDIF
2302
2303C...Stop execution if too many errors.
2304 IF(MERR.NE.0) NERR=NERR+1
2305 IF(NERR.GE.10) THEN
2306 WRITE(MSTU(11),6300)
2307 CALL PYLIST(1)
2308 CALL PYSTOP(9)
2309 ENDIF
2310 180 CONTINUE
2311
2312C...Summarize result of run.
2313 IF(MTEST.GE.1) CALL PYTABU(22)
2314
2315C...Reset commonblock variables changed during run.
2316 MSTJ(1)=MSTJ1
2317 MSTJ(3)=MSTJ3
2318 MSTJ(11)=MSTJ11
2319 MSTJ(42)=MSTJ42
2320 MSTJ(43)=MSTJ43
2321 MSTJ(44)=MSTJ44
2322 PARJ(17)=PARJ17
2323 PARJ(22)=PARJ22
2324 PARJ(43)=PARJ43
2325 PARJ(54)=PARJ54
2326 MSTJ(101)=MST101
2327 MSTJ(104)=MST104
2328 MSTJ(105)=MST105
2329 MSTJ(107)=MST107
2330 MSTJ(116)=MST116
2331
2332C...Second part: complete events of various kinds.
2333C...Common initial values. Loop over initiating conditions.
2334 MSTP(122)=MAX(0,MIN(2,MTEST))
2335 MDCY(PYCOMP(111),1)=0
2336 DO 230 IPROC=1,8
2337
2338C...Reset process type, kinematics cuts, and the flags used.
2339 MSEL=0
2340 DO 190 ISUB=1,500
2341 MSUB(ISUB)=0
2342 190 CONTINUE
2343 CKIN(1)=2D0
2344 CKIN(3)=0D0
2345 MSTP(2)=1
2346 MSTP(11)=0
2347 MSTP(33)=0
2348 MSTP(81)=1
2349 MSTP(82)=1
2350 MSTP(111)=1
2351 MSTP(131)=0
2352 MSTP(133)=0
2353 PARP(131)=0.01D0
2354
2355C...Prompt photon production at fixed target.
2356 IF(IPROC.EQ.1) THEN
2357 PZSUM=300D0
2358 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2359 PQSUM=2D0
2360 MSEL=10
2361 CKIN(3)=5D0
2362 CALL PYINIT('FIXT','pi+','p',PZSUM)
2363
2364C...QCD processes at ISR energies.
2365 ELSEIF(IPROC.EQ.2) THEN
2366 PESUM=63D0
2367 PZSUM=0D0
2368 PQSUM=2D0
2369 MSEL=1
2370 CKIN(3)=5D0
2371 CALL PYINIT('CMS','p','p',PESUM)
2372
2373C...W production + multiple interactions at CERN Collider.
2374 ELSEIF(IPROC.EQ.3) THEN
2375 PESUM=630D0
2376 PZSUM=0D0
2377 PQSUM=0D0
2378 MSEL=12
2379 CKIN(1)=20D0
2380 MSTP(82)=4
2381 MSTP(2)=2
2382 MSTP(33)=3
2383 CALL PYINIT('CMS','p','pbar',PESUM)
2384
2385C...W/Z gauge boson pairs + pileup events at the Tevatron.
2386 ELSEIF(IPROC.EQ.4) THEN
2387 PESUM=1800D0
2388 PZSUM=0D0
2389 PQSUM=0D0
2390 MSUB(22)=1
2391 MSUB(23)=1
2392 MSUB(25)=1
2393 CKIN(1)=200D0
2394 MSTP(111)=0
2395 MSTP(131)=1
2396 MSTP(133)=2
2397 PARP(131)=0.04D0
2398 CALL PYINIT('CMS','p','pbar',PESUM)
2399
2400C...Higgs production at LHC.
2401 ELSEIF(IPROC.EQ.5) THEN
2402 PESUM=15400D0
2403 PZSUM=0D0
2404 PQSUM=2D0
2405 MSUB(3)=1
2406 MSUB(102)=1
2407 MSUB(123)=1
2408 MSUB(124)=1
2409 PMAS(25,1)=300D0
2410 CKIN(1)=200D0
2411 MSTP(81)=0
2412 MSTP(111)=0
2413 CALL PYINIT('CMS','p','p',PESUM)
2414
2415C...Z' production at SSC.
2416 ELSEIF(IPROC.EQ.6) THEN
2417 PESUM=40000D0
2418 PZSUM=0D0
2419 PQSUM=2D0
2420 MSEL=21
2421 PMAS(32,1)=600D0
2422 CKIN(1)=400D0
2423 MSTP(81)=0
2424 MSTP(111)=0
2425 CALL PYINIT('CMS','p','p',PESUM)
2426
2427C...W pair production at 1 TeV e+e- collider.
2428 ELSEIF(IPROC.EQ.7) THEN
2429 PESUM=1000D0
2430 PZSUM=0D0
2431 PQSUM=0D0
2432 MSUB(25)=1
2433 MSUB(69)=1
2434 MSTP(11)=1
2435 CALL PYINIT('CMS','e+','e-',PESUM)
2436
2437C...Deep inelastic scattering at a LEP+LHC ep collider.
2438 ELSEIF(IPROC.EQ.8) THEN
2439 P(1,1)=0D0
2440 P(1,2)=0D0
2441 P(1,3)=8000D0
2442 P(2,1)=0D0
2443 P(2,2)=0D0
2444 P(2,3)=-80D0
2445 PESUM=8080D0
2446 PZSUM=7920D0
2447 PQSUM=0D0
2448 MSUB(10)=1
2449 CKIN(3)=50D0
2450 MSTP(111)=0
2451 CALL PYINIT('3MOM','p','e-',PESUM)
2452 ENDIF
2453
2454C...Generate 20 events of each required type.
2455 DO 220 IEV=1,20
2456 CALL PYEVNT
2457 PESUMM=PESUM
2458 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2459
2460C...Check conservation of energy/momentum/flavour.
2461 PINI(1)=0D0
2462 PINI(2)=0D0
2463 PINI(3)=PZSUM
2464 PINI(4)=PESUMM
2465 PINI(6)=PQSUM
2466 DO 200 J=1,4
2467 PFIN(J)=PYP(0,J)
2468 200 CONTINUE
2469 PFIN(6)=PYP(0,6)
2470 MERR=0
2471 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2472 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2473 DEVQ=ABS(PFIN(6)-PINI(6))
2474 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2475 & DEVQ.GT.0.1D0) MERR=1
2476 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2477 & (PFIN(J),J=1,4),PFIN(6)
2478
2479C...Check that all KF codes are known ones, and that partons/particles
2480C...satisfy energy-momentum-mass relation.
2481 DO 210 I=1,N
2482 IF(K(I,1).GT.20) GOTO 210
2483 IF(PYCOMP(K(I,2)).EQ.0) THEN
2484 WRITE(MSTU(11),5100) I
2485 MERR=MERR+1
2486 ENDIF
2487 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2488 & SIGN(1D0,P(I,5))
2489 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2490 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2491 WRITE(MSTU(11),5200) I
2492 MERR=MERR+1
2493 ENDIF
2494 210 CONTINUE
2495
2496C...Listing of erroneous events, and first event of each type.
2497 IF(MERR.GE.1) NERR=NERR+1
2498 IF(NERR.GE.10) THEN
2499 WRITE(MSTU(11),6300)
2500 CALL PYLIST(1)
2501 CALL PYSTOP(9)
2502 ENDIF
2503 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2504 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2505 CALL PYLIST(1)
2506 ENDIF
2507 220 CONTINUE
2508
2509C...List statistics for each process type.
2510 IF(MTEST.GE.1) CALL PYSTAT(1)
2511 230 CONTINUE
2512
2513C...Summarize result of run.
2514 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2515 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2516
2517C...Format statements for output.
2518 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2519 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2520 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2521 &4(1X,F12.5),1X,F8.2)
2522 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2523 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2524 &'kinematics')
2525 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2526 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2527 6400 FORMAT(5X,'Faulty event follows:')
2528 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2529 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2530 &5X,'This should not have happened!')
2531
2532 RETURN
2533 END
2534
2535C*********************************************************************
2536
2537C...PYHEPC
2538C...Converts PYTHIA event record contents to or from
2539C...the standard event record commonblock.
2540
2541 SUBROUTINE PYHEPC(MCONV)
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/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2551 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2552C...HEPEVT commonblock.
2553 PARAMETER (NMXHEP=4000)
2554 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2555 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2556 DOUBLE PRECISION PHEP,VHEP
2557 SAVE /HEPEVT/
2558
2559C...Store HEPEVT commonblock size (for interfacing issues).
2560 MSTU(8)=NMXHEP
2561
2562C...Conversion from PYTHIA to standard, the easy part.
2563 IF(MCONV.EQ.1) THEN
2564 NEVHEP=0
2565 IF(N.GT.NMXHEP) CALL PYERRM(8,
2566 & '(PYHEPC:) no more space in /HEPEVT/')
2567 NHEP=MIN(N,NMXHEP)
2568 DO 150 I=1,NHEP
2569 ISTHEP(I)=0
2570 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2571 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2572 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2573 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2574 IDHEP(I)=K(I,2)
2575 JMOHEP(1,I)=K(I,3)
2576 JMOHEP(2,I)=0
2577 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2578 JDAHEP(1,I)=K(I,4)
2579 JDAHEP(2,I)=K(I,5)
2580 ELSE
2581 JDAHEP(1,I)=0
2582 JDAHEP(2,I)=0
2583 ENDIF
2584 DO 100 J=1,5
2585 PHEP(J,I)=P(I,J)
2586 100 CONTINUE
2587 DO 110 J=1,4
2588 VHEP(J,I)=V(I,J)
2589 110 CONTINUE
2590
2591C...Check if new event (from pileup).
2592 IF(I.EQ.1) THEN
2593 INEW=1
2594 ELSE
2595 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2596 ENDIF
2597
2598C...Fill in missing mother information.
2599 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2600 IMO1=I-2
2601 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2602 & THEN
2603 IMO1=IMO1-1
2604 GOTO 120
2605 ENDIF
2606 JMOHEP(1,I)=IMO1
2607 JMOHEP(2,I)=IMO1+1
2608 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2609 I1=K(I,3)-1
2610 130 I1=I1+1
2611 IF(I1.GE.I) CALL PYERRM(8,
2612 & '(PYHEPC:) translation of inconsistent event history')
2613 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2614 KC=PYCOMP(K(I1,2))
2615 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2616 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2617 JMOHEP(2,I)=I1
2618 ELSEIF(K(I,2).EQ.94) THEN
2619 NJET=2
2620 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2621 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2622 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2623 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2624 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2625 ENDIF
2626
2627C...Fill in missing daughter information.
2628 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2629 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2630 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2631 JDAHEP(1,I2)=I
2632 140 CONTINUE
2633 ENDIF
2634 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2635 I1=JMOHEP(1,I)
2636 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2637 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2638 IF(JDAHEP(1,I1).EQ.0) THEN
2639 JDAHEP(1,I1)=I
2640 ELSE
2641 JDAHEP(2,I1)=I
2642 ENDIF
2643 150 CONTINUE
2644 DO 160 I=1,NHEP
2645 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2646 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2647 160 CONTINUE
2648
2649C...Conversion from standard to PYTHIA, the easy part.
2650 ELSE
2651 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2652 & '(PYHEPC:) no more space in /PYJETS/')
2653 N=MIN(NHEP,MSTU(4))
2654 NKQ=0
2655 KQSUM=0
2656 DO 190 I=1,N
2657 K(I,1)=0
2658 IF(ISTHEP(I).EQ.1) K(I,1)=1
2659 IF(ISTHEP(I).EQ.2) K(I,1)=11
2660 IF(ISTHEP(I).EQ.3) K(I,1)=21
2661 K(I,2)=IDHEP(I)
2662 K(I,3)=JMOHEP(1,I)
2663 K(I,4)=JDAHEP(1,I)
2664 K(I,5)=JDAHEP(2,I)
2665 DO 170 J=1,5
2666 P(I,J)=PHEP(J,I)
2667 170 CONTINUE
2668 DO 180 J=1,4
2669 V(I,J)=VHEP(J,I)
2670 180 CONTINUE
2671 V(I,5)=0D0
2672 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2673 I1=JDAHEP(1,I)
2674 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2675 & PHEP(5,I)/PHEP(4,I)
2676 ENDIF
2677
2678C...Fill in missing information on colour connection in jet systems.
2679 IF(ISTHEP(I).EQ.1) THEN
2680 KC=PYCOMP(K(I,2))
2681 KQ=0
2682 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2683 IF(KQ.NE.0) NKQ=NKQ+1
2684 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2685 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2686 K(I,1)=2
2687 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2688 IF(K(I+1,2).EQ.21) K(I,1)=2
2689 ENDIF
2690 ENDIF
2691 190 CONTINUE
2692 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2693 & '(PYHEPC:) input parton configuration not colour singlet')
2694 ENDIF
2695
2696 END
2697
2698C*********************************************************************
2699
2700C...PYINIT
2701C...Initializes the generation procedure; finds maxima of the
2702C...differential cross-sections to be used for weighting.
2703
2704 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2705
2706C...Double precision and integer declarations.
2707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2708 IMPLICIT INTEGER(I-N)
2709 INTEGER PYK,PYCHGE,PYCOMP
2710C...Commonblocks.
2711 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2712 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2713 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2714 COMMON/PYDAT4/CHAF(500,2)
2715 CHARACTER CHAF*16
2716 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2717 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2718 COMMON/PYINT1/MINT(400),VINT(400)
2719 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2720 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2721 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2722 &/PYINT1/,/PYINT2/,/PYINT5/
2723C...Local arrays and character variables.
2724 DIMENSION ALAMIN(20),NFIN(20)
2725 CHARACTER*(*) FRAME,BEAM,TARGET
2726 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2727
2728C...Interface to PDFLIB.
2729 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2730 COMMON/LW50512/QCDL4,QCDL5
2731 SAVE /W50511/
2732 SAVE /LW50512/
2733 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2734 CHARACTER*20 PARM(20)
2735 DATA VALUE/20*0D0/,PARM/20*' '/
2736
2737C...Data:Lambda and n_f values for parton distributions..
2738 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2739 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2740 &NFIN/20*4/
2741 DATA CHLH/'lepton','hadron'/
2742
2743C...Check that BLOCK DATA PYDATA has been loaded.
2744 CALL PYCKBD
2745
2746C...Reset MINT and VINT arrays. Write headers.
2747 MSTI(53)=0
2748 DO 100 J=1,400
2749 MINT(J)=0
2750 VINT(J)=0D0
2751 100 CONTINUE
2752 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2753 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2754
2755C...Reset error counters.
2756 MSTU(23)=0
2757 MSTU(27)=0
2758 MSTU(30)=0
2759
2760C...Reset processes that should not be on.
2761 MSUB(96)=0
2762 MSUB(97)=0
2763
2764C...Select global FSR/ISR/UE parameter set = 'tune'
2765C...See routine PYTUNE for details
2766 IF (MSTP(5).NE.0) THEN
2767 MSTP5=MSTP(5)
2768 CALL PYTUNE(MSTP5)
2769 ENDIF
2770
2771C...Call user process initialization routine.
2772 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2773 MSEL=0
2774 CALL UPINIT
2775 MSEL=0
2776 ENDIF
2777
2778C...Maximum 4 generations; set maximum number of allowed flavours.
2779 MSTP(1)=MIN(4,MSTP(1))
2780 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2781 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2782
2783C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2784 DO 120 I=-20,20
2785 VINT(180+I)=0D0
2786 IA=IABS(I)
2787 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2788 DO 110 J=1,MSTP(1)
2789 IB=2*J-1+MOD(IA,2)
2790 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2791 IPM=(5-ISIGN(1,I))/2
2792 IDC=J+MDCY(IA,2)+2
2793 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2794 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2795 110 CONTINUE
2796 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2797 VINT(180+I)=1D0
2798 ENDIF
2799 120 CONTINUE
2800
2801C...Initialize parton distributions: PDFLIB.
2802 IF(MSTP(52).EQ.2) THEN
2803 PARM(1)='NPTYPE'
2804 VALUE(1)=1
2805 PARM(2)='NGROUP'
2806 VALUE(2)=MSTP(51)/1000
2807 PARM(3)='NSET'
2808 VALUE(3)=MOD(MSTP(51),1000)
2809 PARM(4)='TMAS'
2810 VALUE(4)=PMAS(6,1)
2811 CALL PDFSET_ALICE(PARM,VALUE)
2812 MINT(93)=1000000+MSTP(51)
2813 ENDIF
2814
2815C...Choose Lambda value to use in alpha-strong.
2816 MSTU(111)=MSTP(2)
2817 IF(MSTP(3).GE.2) THEN
2818 ALAM=0.2D0
2819 NF=4
2820 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2821 ALAM=ALAMIN(MSTP(51))
2822 NF=NFIN(MSTP(51))
2823 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2824 ALAM=QCDL5
2825 NF=5
2826 ELSEIF(MSTP(52).EQ.2) THEN
2827 ALAM=QCDL4
2828 NF=4
2829 ENDIF
2830 PARP(1)=ALAM
2831 PARP(61)=ALAM
2832 PARP(72)=ALAM
2833 PARU(112)=ALAM
2834 MSTU(112)=NF
2835 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2836 ENDIF
2837
2838C...Initialize the SUSY generation: couplings, masses,
2839C...decay modes, branching ratios, and so on.
2840 CALL PYMSIN
2841C...Initialize widths and partial widths for resonances.
2842 CALL PYINRE
2843C...Set Z0 mass and width for e+e- routines.
2844 PARJ(123)=PMAS(23,1)
2845 PARJ(124)=PMAS(23,2)
2846
2847C...Identify beam and target particles and frame of process.
2848 CHFRAM=FRAME//' '
2849 CHBEAM=BEAM//' '
2850 CHTARG=TARGET//' '
2851 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2852 IF(MINT(65).EQ.1) GOTO 170
2853
2854C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2855C...For e-gamma allow 2 alternatives.
2856 MINT(121)=1
2857 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2858 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2859 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2860 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2861 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2862 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2863 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2864 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2865 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2866 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2867 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2868 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2869 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2870 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2871 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2872 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2873 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2874 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2875 ENDIF
2876 MINT(123)=MSTP(14)
2877 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2878 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2879 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2880 IF(MSTP(14).EQ.11) MINT(123)=0
2881 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2882 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2883 IF(MSTP(14).EQ.15) MINT(123)=2
2884 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2885 IF(MSTP(14).EQ.19) MINT(123)=3
2886 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2887 IF(MSTP(14).EQ.21) MINT(123)=0
2888 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2889 IF(MSTP(14).EQ.24) MINT(123)=1
2890 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2891 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2892 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2893 ENDIF
2894
2895C...Set up kinematics of process.
2896 CALL PYINKI(0)
2897
2898C...Set up kinematics for photons inside leptons.
2899 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2900
2901C...Precalculate flavour selection weights.
2902 CALL PYKFIN
2903
2904C...Loop over gamma-p or gamma-gamma alternatives.
2905 CKIN3=CKIN(3)
2906 MSAV48=0
2907 DO 160 IGA=1,MINT(121)
2908 CKIN(3)=CKIN3
2909 MINT(122)=IGA
2910
2911C...Select partonic subprocesses to be included in the simulation.
2912 CALL PYINPR
2913 MINT(101)=1
2914 MINT(102)=1
2915 MINT(103)=MINT(11)
2916 MINT(104)=MINT(12)
2917
2918C...Count number of subprocesses on.
2919 MINT(48)=0
2920 DO 130 ISUB=1,500
2921 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2922 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2923 MSUB(ISUB)=0
2924 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2925 & MSUB(ISUB).EQ.1) THEN
2926 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2927 CALL PYSTOP(1)
2928 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2929 WRITE(MSTU(11),5300) ISUB
2930 CALL PYSTOP(1)
2931 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2932 WRITE(MSTU(11),5400) ISUB
2933 CALL PYSTOP(1)
2934 ELSEIF(MSUB(ISUB).EQ.1) THEN
2935 MINT(48)=MINT(48)+1
2936 ENDIF
2937 130 CONTINUE
2938
2939C...Stop or raise warning flag if no subprocesses on.
2940 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2941 IF(MSTP(127).NE.1) THEN
2942 WRITE(MSTU(11),5500)
2943 CALL PYSTOP(1)
2944 ELSE
2945 WRITE(MSTU(11),5700)
2946 MSTI(53)=1
2947 ENDIF
2948 ENDIF
2949 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2950 MSAV48=MSAV48+MINT(48)
2951
2952C...Reset variables for cross-section calculation.
2953 DO 150 I=0,500
2954 DO 140 J=1,3
2955 NGEN(I,J)=0
2956 XSEC(I,J)=0D0
2957 140 CONTINUE
2958 150 CONTINUE
2959
2960C...Find parametrized total cross-sections.
2961 CALL PYXTOT
2962 VINT(318)=VINT(317)
2963
2964C...Maxima of differential cross-sections.
2965 IF(MSTP(121).LE.1) CALL PYMAXI
2966
2967C...Initialize possibility of pileup events.
2968 IF(MINT(121).GT.1) MSTP(131)=0
2969 IF(MSTP(131).NE.0) CALL PYPILE(1)
2970
2971C...Initialize multiple interactions with variable impact parameter.
2972 IF(MINT(50).EQ.1) THEN
2973 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2974 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
2975 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
2976 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
2977 MINT(35)=1
2978 CALL PYMULT(1)
2979 MINT(35)=3
2980 CALL PYMIGN(1)
2981 ENDIF
2982 ENDIF
2983
2984C...Save results for gamma-p and gamma-gamma alternatives.
2985 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2986 160 CONTINUE
2987
2988C...Initialization finished.
2989 IF(MSAV48.EQ.0) THEN
2990 IF(MSTP(127).NE.1) THEN
2991 WRITE(MSTU(11),5500)
2992 CALL PYSTOP(1)
2993 ELSE
2994 WRITE(MSTU(11),5700)
2995 MSTI(53)=1
2996 ENDIF
2997 ENDIF
2998 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2999
3000C...Formats for initialization information.
3001 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3002 &'routines',1X,17('*'))
3003 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3004 &'-',A6,' interactions.'/1X,'Execution stopped!')
3005 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3006 &1X,'Execution stopped!')
3007 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3008 &1X,'Execution stopped!')
3009 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3010 &1X,'Execution stopped.')
3011 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3012 &22('*'))
3013 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3014 &1X,'Execution will stop if you try to generate events.')
3015
3016 RETURN
3017 END
3018
3019C*********************************************************************
3020
3021C...PYEVNT
3022C...Administers the generation of a high-pT event via calls to
3023C...a number of subroutines.
3024
3025 SUBROUTINE PYEVNT
3026
3027C...Double precision and integer declarations.
3028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3029 IMPLICIT INTEGER(I-N)
3030 INTEGER PYK,PYCHGE,PYCOMP
3031C...Commonblocks.
3032 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3033 COMMON/PYCTAG/NCT,MCT(4000,2)
3034 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3035 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3036 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3037 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3038 COMMON/PYINT1/MINT(400),VINT(400)
3039 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3040 COMMON/PYINT4/MWID(500),WIDS(500,5)
3041 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3042 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3043 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3044C...Local array.
3045 DIMENSION VTX(4)
3046
3047C...Optionally let PYEVNW do the whole job.
3048 IF(MSTP(81).GE.20) THEN
3049 CALL PYEVNW
3050 RETURN
3051 ENDIF
3052
3053C...Stop if no subprocesses on.
3054 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3055 WRITE(MSTU(11),5100)
3056 CALL PYSTOP(1)
3057 ENDIF
3058
3059C...Initial values for some counters.
3060 MSTU(1)=0
3061 MSTU(2)=0
3062 N=0
3063 MINT(5)=MINT(5)+1
3064 MINT(7)=0
3065 MINT(8)=0
3066 MINT(30)=0
3067 MINT(83)=0
3068 MINT(84)=MSTP(126)
3069 MSTU(24)=0
3070 MSTU70=0
3071 MSTJ14=MSTJ(14)
3072C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3073 NCT=0
3074 MINT(33)=0
3075
3076C...Let called routines know call is from PYEVNT (not PYEVNW).
3077 MINT(35)=1
3078 IF (MSTP(81).GE.10) MINT(35)=2
3079
3080C...If variable energies: redo incoming kinematics and cross-section.
3081 MSTI(61)=0
3082 IF(MSTP(171).EQ.1) THEN
3083 CALL PYINKI(1)
3084 IF(MSTI(61).EQ.1) THEN
3085 MINT(5)=MINT(5)-1
3086 RETURN
3087 ENDIF
3088 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3089 CALL PYXTOT
3090 ENDIF
3091
3092C...Loop over number of pileup events; check space left.
3093 IF(MSTP(131).LE.0) THEN
3094 NPILE=1
3095 ELSE
3096 CALL PYPILE(2)
3097 NPILE=MINT(81)
3098 ENDIF
3099 DO 270 IPILE=1,NPILE
3100 IF(MINT(84)+100.GE.MSTU(4)) THEN
3101 CALL PYERRM(11,
3102 & '(PYEVNT:) no more space in PYJETS for pileup events')
3103 IF(MSTU(21).GE.1) GOTO 280
3104 ENDIF
3105 MINT(82)=IPILE
3106
3107C...Generate variables of hard scattering.
3108 MINT(51)=0
3109 MSTI(52)=0
3110 100 CONTINUE
3111 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3112 MINT(31)=0
3113 MINT(39)=0
3114 MINT(51)=0
3115 MINT(57)=0
3116 CALL PYRAND
3117 IF(MSTI(61).EQ.1) THEN
3118 MINT(5)=MINT(5)-1
3119 RETURN
3120 ENDIF
3121 IF(MINT(51).EQ.2) RETURN
3122 ISUB=MINT(1)
3123 IF(MSTP(111).EQ.-1) GOTO 260
3124
3125C...Loopback point if PYPREP fails, especially for junction topologies.
3126 NPREP=0
3127 MNT31S=MINT(31)
3128 110 NPREP=NPREP+1
3129 MINT(31)=MNT31S
3130
3131 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3132C...Hard scattering (including low-pT):
3133C...reconstruct kinematics and colour flow of hard scattering.
3134 MINT31=MINT(31)
3135 120 MINT(31)=MINT31
3136 MINT(51)=0
3137 CALL PYSCAT
3138 IF(MINT(51).EQ.1) GOTO 100
3139 IPU1=MINT(84)+1
3140 IPU2=MINT(84)+2
3141 IF(ISUB.EQ.95) GOTO 140
3142
3143C...Reset statistics on activity in event.
3144 DO 130 J=351,359
3145 MINT(J)=0
3146 VINT(J)=0D0
3147 130 CONTINUE
3148
3149C...Showering of initial state partons (optional).
3150 NFIN=N
3151 ALAMSV=PARJ(81)
3152 PARJ(81)=PARP(72)
3153 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3154 & CALL PYSSPA(IPU1,IPU2)
3155 PARJ(81)=ALAMSV
3156 IF(MINT(51).EQ.1) GOTO 100
3157
3158C...Showering of final state partons (optional).
3159 ALAMSV=PARJ(81)
3160 PARJ(81)=PARP(72)
3161 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3162 & THEN
3163 IPU3=MINT(84)+3
3164 IPU4=MINT(84)+4
3165 IF(ISET(ISUB).EQ.5) IPU4=-3
3166 QMAX=VINT(55)
3167 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3168 if(parj(200).eq.1.) then
3169 CALL PYSHOWQ(IPU3,IPU4,QMAX)
3170
3171 else
3172 CALL PYSHOW(IPU3,IPU4,QMAX)
3173 endif
3174 ELSEIF(ISET(ISUB).EQ.11) THEN
3175 CALL PYADSH(NFIN)
3176 ENDIF
3177 PARJ(81)=ALAMSV
3178
3179C...Allow possibility for user to abort event generation.
3180 IVETO=0
3181 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3182 IF(IVETO.EQ.1) GOTO 100
3183
3184C...Decay of final state resonances.
3185 MINT(32)=0
3186 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3187 IF(MINT(51).EQ.1) GOTO 100
3188 MINT(52)=N
3189
3190
3191C...Multiple interactions - PYTHIA 6.3 intermediate style.
3192 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3193 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3194 CALL PYMIGN(6)
3195 IF(MINT(51).EQ.1) GOTO 100
3196 MINT(53)=N
3197
3198C...Beam remnant flavour and colour assignments - new scheme.
3199 CALL PYMIHK
3200 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3201 & GOTO 120
3202 IF(MINT(51).EQ.1) GOTO 100
3203
3204C...Primordial kT and beam remnant momentum sharing - new scheme.
3205 CALL PYMIRM
3206 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3207 & GOTO 120
3208 IF(MINT(51).EQ.1) GOTO 100
3209 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3210
3211C...Multiple interactions - PYTHIA 6.2 style.
3212 ELSEIF(MINT(111).NE.12) THEN
3213 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3214 CALL PYMULT(6)
3215 MINT(53)=N
3216 ENDIF
3217
3218C...Hadron remnants and primordial kT.
3219 CALL PYREMN(IPU1,IPU2)
3220 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3221 & 110
3222 IF(MINT(51).EQ.1) GOTO 100
3223 ENDIF
3224
3225 ELSEIF(ISUB.NE.99) THEN
3226C...Diffractive and elastic scattering.
3227 CALL PYDIFF
3228
3229 ELSE
3230C...DIS scattering (photon flux external).
3231 CALL PYDISG
3232 IF(MINT(51).EQ.1) GOTO 100
3233 ENDIF
3234
3235C...Check that no odd resonance left undecayed.
3236 MINT(54)=N
3237 IF(MSTP(111).GE.1) THEN
3238 NFIX=N
3239 DO 150 I=MINT(84)+1,NFIX
3240 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3241 & K(I,2).NE.22) THEN
3242 KCA=PYCOMP(K(I,2))
3243 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3244 CALL PYRESD(I)
3245 IF(MINT(51).EQ.1) GOTO 100
3246 ENDIF
3247 ENDIF
3248 150 CONTINUE
3249 ENDIF
3250
3251C...Boost hadronic subsystem to overall rest frame.
3252C..(Only relevant when photon inside lepton beam.)
3253 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3254
3255C...Recalculate energies from momenta and masses (if desired).
3256 IF(MSTP(113).GE.1) THEN
3257 DO 160 I=MINT(83)+1,N
3258 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3259 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3260 160 CONTINUE
3261 NRECAL=N
3262 ENDIF
3263
3264C...Colour reconnection before string formation
3265 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3266
3267C...Rearrange partons along strings, check invariant mass cuts.
3268 MSTU(28)=0
3269 IF(MSTP(111).LE.0) MSTJ(14)=-1
3270 CALL PYPREP(MINT(84)+1)
3271 MSTJ(14)=MSTJ14
3272 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3273 MSTU(24)=0
3274 GOTO 100
3275 ENDIF
3276 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3277 IF (MINT(51).EQ.1) GOTO 100
3278 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3279 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3280 DO 190 I=MINT(84)+1,N
3281 IF(K(I,2).EQ.94) THEN
3282 DO 180 I1=I+1,MIN(N,I+10)
3283 IF(K(I1,3).EQ.I) THEN
3284 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3285 IF(K(I1,3).EQ.0) THEN
3286 DO 170 II=MINT(84)+1,I-1
3287 IF(K(II,2).EQ.K(I1,2)) THEN
3288 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3289 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3290 ENDIF
3291 170 CONTINUE
3292 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3293 ENDIF
3294 ENDIF
3295 180 CONTINUE
3296 ENDIF
3297 190 CONTINUE
3298 CALL PYEDIT(12)
3299 CALL PYEDIT(14)
3300 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3301 IF(MSTP(125).EQ.0) MINT(4)=0
3302 DO 210 I=MINT(83)+1,N
3303 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3304 DO 200 I1=I+1,N
3305 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3306 IF(K(I1,3).EQ.I) K(I,5)=I1
3307 200 CONTINUE
3308 ENDIF
3309 210 CONTINUE
3310 ENDIF
3311
3312C...Introduce separators between sections in PYLIST event listing.
3313 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3314 MSTU70=1
3315 MSTU(71)=N
3316 ELSEIF(IPILE.EQ.1) THEN
3317 MSTU70=3
3318 MSTU(71)=2
3319 MSTU(72)=MINT(4)
3320 MSTU(73)=N
3321 ENDIF
3322
3323C...Go back to lab frame (needed for vertices, also in fragmentation).
3324 CALL PYFRAM(1)
3325
3326C...Set nonvanishing production vertex (optional).
3327 IF(MSTP(151).EQ.1) THEN
3328 DO 220 J=1,4
3329 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3330 & SIN(PARU(2)*PYR(0))
3331 220 CONTINUE
3332 DO 240 I=MINT(83)+1,N
3333 DO 230 J=1,4
3334 V(I,J)=V(I,J)+VTX(J)
3335 230 CONTINUE
3336 240 CONTINUE
3337 ENDIF
3338
3339C...Perform hadronization (if desired).
3340 IF(MSTP(111).GE.1) THEN
3341 CALL PYEXEC
3342 IF(MSTU(24).NE.0) GOTO 100
3343 ENDIF
3344 IF(MSTP(113).GE.1) THEN
3345 DO 250 I=NRECAL,N
3346 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3347 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3348 250 CONTINUE
3349 ENDIF
3350 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3351
3352C...Store event information and calculate Monte Carlo estimates of
3353C...subprocess cross-sections.
3354 260 IF(IPILE.EQ.1) CALL PYDOCU
3355
3356C...Set counters for current pileup event and loop to next one.
3357 MSTI(41)=IPILE
3358 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3359 IF(MSTU70.LT.10) THEN
3360 MSTU70=MSTU70+1
3361 MSTU(70+MSTU70)=N
3362 ENDIF
3363 MINT(83)=N
3364 MINT(84)=N+MSTP(126)
3365 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3366 270 CONTINUE
3367
3368C...Generic information on pileup events. Reconstruct missing history.
3369 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3370 PARI(91)=VINT(132)
3371 PARI(92)=VINT(133)
3372 PARI(93)=VINT(134)
3373 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3374 ENDIF
3375 CALL PYEDIT(16)
3376
3377C...Transform to the desired coordinate frame.
3378 280 CALL PYFRAM(MSTP(124))
3379 MSTU(70)=MSTU70
3380 PARU(21)=VINT(1)
3381
3382C...Error messages
3383 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3384 &1X,'Execution stopped.')
3385
3386 RETURN
3387 END
3388
3389C*********************************************************************
3390
3391C...PYEVNW
3392C...Administers the generation of a high-pT event via calls to
3393C...a number of subroutines for the new multiple interactions and
3394C...showering framework.
3395
3396 SUBROUTINE PYEVNW
3397
3398C...Double precision and integer declarations.
3399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3400 IMPLICIT INTEGER(I-N)
3401 INTEGER PYK,PYCHGE,PYCOMP
3402C...Commonblocks.
3403 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3404 COMMON/PYCTAG/NCT,MCT(4000,2)
3405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3406 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3407 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3408 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3409 COMMON/PYINT1/MINT(400),VINT(400)
3410 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3411 COMMON/PYINT4/MWID(500),WIDS(500,5)
3412 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3413 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3414 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3415 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3416 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3417 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3418C...Local arrays.
3419 DIMENSION VTX(4)
3420
3421C...Stop if no subprocesses on.
3422 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3423 WRITE(MSTU(11),5100)
3424 CALL PYSTOP(1)
3425 ENDIF
3426
3427C...Initial values for some counters.
3428 MSTU(1)=0
3429 MSTU(2)=0
3430 N=0
3431 MINT(5)=MINT(5)+1
3432 MINT(7)=0
3433 MINT(8)=0
3434 MINT(30)=0
3435 MINT(83)=0
3436 MINT(84)=MSTP(126)
3437 MSTU(24)=0
3438 MSTU70=0
3439 MSTJ14=MSTJ(14)
3440C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3441 NCT=0
3442 MINT(33)=0
3443
3444C...Let called routines know call is from PYEVNW (not PYEVNT).
3445 MINT(35)=3
3446
3447C...If variable energies: redo incoming kinematics and cross-section.
3448 MSTI(61)=0
3449 IF(MSTP(171).EQ.1) THEN
3450 CALL PYINKI(1)
3451 IF(MSTI(61).EQ.1) THEN
3452 MINT(5)=MINT(5)-1
3453 RETURN
3454 ENDIF
3455 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3456 CALL PYXTOT
3457 ENDIF
3458
3459C...Loop over number of pileup events; check space left.
3460 IF(MSTP(131).LE.0) THEN
3461 NPILE=1
3462 ELSE
3463 CALL PYPILE(2)
3464 NPILE=MINT(81)
3465 ENDIF
3466 DO 300 IPILE=1,NPILE
3467 IF(MINT(84)+100.GE.MSTU(4)) THEN
3468 CALL PYERRM(11,
3469 & '(PYEVNW:) no more space in PYJETS for pileup events')
3470 IF(MSTU(21).GE.1) GOTO 310
3471 ENDIF
3472 MINT(82)=IPILE
3473
3474C...Generate variables of hard scattering.
3475 MINT(51)=0
3476 MSTI(52)=0
3477 100 CONTINUE
3478 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3479 MINT(31)=0
3480 MINT(39)=0
3481 MINT(36)=0
3482 MINT(51)=0
3483 MINT(57)=0
3484 CALL PYRAND
3485 IF(MSTI(61).EQ.1) THEN
3486 MINT(5)=MINT(5)-1
3487 RETURN
3488 ENDIF
3489 IF(MINT(51).EQ.2) RETURN
3490 ISUB=MINT(1)
3491 IF(MSTP(111).EQ.-1) GOTO 290
3492
3493C...Loopback point if PYPREP fails, especially for junction topologies.
3494 NPREP=0
3495 MNT31S=MINT(31)
3496 110 NPREP=NPREP+1
3497 MINT(31)=MNT31S
3498
3499 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3500C...Hard scattering (including low-pT):
3501C...reconstruct kinematics and colour flow of hard scattering.
3502 MINT31=MINT(31)
3503 120 MINT(31)=MINT31
3504 MINT(51)=0
3505 CALL PYSCAT
3506 IF(MINT(51).EQ.1) GOTO 100
3507 NPARTD=N
3508 NFIN=N
3509
3510C...Intertwined initial state showers and multiple interactions.
3511C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3512C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3513 MSTP61=MSTP(61)
3514 IF (MINT(47).LT.2) MSTP(61)=0
3515 MSTP81=MSTP(81)
3516 IF (MINT(50).EQ.0) MSTP(81)=0
3517 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3518 & MINT(111).NE.12) THEN
3519C...Absolute max pT2 scale for evolution: phase space limit.
3520 PT2MXS=0.25D0*VINT(2)
3521C...Check if more constrained by ISR and MI max scales:
3522 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3523C...Loopback point in case of failure in evolution.
3524 LOOP=0
3525 130 LOOP=LOOP+1
3526 MINT(51)=0
3527 IF(LOOP.GT.100) THEN
3528 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3529 & //'multiple interactions.')
3530 MINT(51)=1
3531 RETURN
3532 ENDIF
3533
3534C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3535C...once per event. (E.g. compute constants and save variables to be
3536C...restored later in case of failure.)
3537 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3538
3539C...Initialize interleaved MI/ISR/JI evolution.
3540C...PT2MAX: absolute upper limit for evolution - Initialization may
3541C... return a PT2MAX which is lower than this.
3542C...PT2MIN: absolute lower limit for evolution - Initialization may
3543C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3544 PT2MAX=PT2MXS
3545 PT2MIN=0D0
3546 CALL PYEVOL(0,PT2MAX,PT2MIN)
3547 IF (MINT(51).EQ.1) GOTO 130
3548
3549C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3550C...In principle factorized, so can be stopped and restarted.
3551C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3552C PT2MED=MAX(10D0**2,PT2MIN)
3553C CALL PYEVOL(1,PT2MAX,PT2MED)
3554C IF (MINT(51).EQ.1) GOTO 160
3555C PT2MAX=PT2MED
3556 CALL PYEVOL(1,PT2MAX,PT2MIN)
3557 IF (MINT(51).EQ.1) GOTO 130
3558
3559C...Finalize interleaved MI/ISR/JI evolution.
3560 CALL PYEVOL(2,PT2MAX,PT2MIN)
3561 IF (MINT(51).EQ.1) GOTO 130
3562
3563 ENDIF
3564 MSTP(61)=MSTP61
3565 MSTP(81)=MSTP81
3566 IF(MINT(51).EQ.1) GOTO 100
3567C...(MINT(52) is actually obsolete in this routine. Set anyway
3568C...to ensure PYDOCU stable.)
3569 MINT(52)=N
3570 MINT(53)=N
3571
3572C...Beam remnants - new scheme.
3573 140 IF(MINT(50).EQ.1) THEN
3574 IF (ISUB.EQ.95) MINT(31)=1
3575
3576C...Beam remnant flavour and colour assignments - new scheme.
3577 CALL PYMIHK
3578 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3579 & GOTO 120
3580 IF(MINT(51).EQ.1) GOTO 100
3581
3582C...Primordial kT and beam remnant momentum sharing - new scheme.
3583 CALL PYMIRM
3584 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3585 & GOTO 120
3586 IF(MINT(51).EQ.1) GOTO 100
3587 IF (ISUB.EQ.95) MINT(31)=0
3588 ELSEIF(MINT(111).NE.12) THEN
3589C...Hadron remnants and primordial kT - old model.
3590C...Happens e.g. for direct photon on one side.
3591 IPU1=IMI(1,1,1)
3592 IPU2=IMI(2,1,1)
3593 CALL PYREMN(IPU1,IPU2)
3594 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3595 & 110
3596 IF(MINT(51).EQ.1) GOTO 100
3597C...PYREMN does not set colour tags for BRs, so needs to be done now.
3598 DO 160 I=MINT(53)+1,N
3599 DO 150 KCS=4,5
3600 IDA=MOD(K(I,KCS),MSTU(5))
3601 IF (IDA.NE.0) THEN
3602 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3603 ELSE
3604 MCT(I,KCS-3)=0
3605 ENDIF
3606 150 CONTINUE
3607 160 CONTINUE
3608C...Instruct PYPREP to use colour tags
3609 MINT(33)=1
3610
3611 DO 360 MQGST=1,2
3612 DO 350 I=MINT(84)+1,N
3613
3614C...Look for coloured string endpoint, or (later) leftover gluon.
3615 IF (K(I,1).NE.3) GOTO 350
3616 KC=PYCOMP(K(I,2))
3617 IF(KC.EQ.0) GOTO 350
3618 KQ=KCHG(KC,2)
3619 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3620
3621C... Pick up loose string end with no previous tag.
3622 KCS=4
3623 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3624 IF(MCT(I,KCS-3).NE.0) GOTO 350
3625
3626 CALL PYCTTR(I,KCS,I)
3627 IF(MINT(51).NE.0) RETURN
3628
3629 350 CONTINUE
3630 360 CONTINUE
3631C...Now delete any colour processing information if set (since partons
3632C...otherwise not FS showered!)
3633 DO 170 I=MINT(84)+1,N
3634 IF (I.LE.N) THEN
3635 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3636 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3637 ENDIF
3638 170 CONTINUE
3639 ENDIF
3640
3641C...Showering of final state partons (optional).
3642 ALAMSV=PARJ(81)
3643 PARJ(81)=PARP(72)
3644 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3645 & THEN
3646 QMAX=VINT(55)
3647 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3648 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3649C...External processes: handle successive showers.
3650 ELSEIF(ISET(ISUB).EQ.11) THEN
3651 CALL PYADSH(NFIN)
3652 ENDIF
3653 PARJ(81)=ALAMSV
3654
3655C...Allow possibility for user to abort event generation.
3656 IVETO=0
3657 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3658 IF(IVETO.EQ.1) GOTO 100
3659
3660
3661C...Decay of final state resonances.
3662 MINT(32)=0
3663 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3664 CALL PYRESD(0)
3665 IF(MINT(51).NE.0) GOTO 100
3666 ENDIF
3667
3668 IF(MINT(51).EQ.1) GOTO 100
3669
3670 ELSEIF(ISUB.NE.99) THEN
3671C...Diffractive and elastic scattering.
3672 CALL PYDIFF
3673
3674 ELSE
3675C...DIS scattering (photon flux external).
3676 CALL PYDISG
3677 IF(MINT(51).EQ.1) GOTO 100
3678 ENDIF
3679
3680C...Check that no odd resonance left undecayed.
3681 MINT(54)=N
3682 IF(MSTP(111).GE.1) THEN
3683 NFIX=N
3684 DO 180 I=MINT(84)+1,NFIX
3685 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3686 & K(I,2).NE.22) THEN
3687 KCA=PYCOMP(K(I,2))
3688 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3689 CALL PYRESD(I)
3690 IF(MINT(51).EQ.1) GOTO 100
3691 ENDIF
3692 ENDIF
3693 180 CONTINUE
3694 ENDIF
3695
3696C...Boost hadronic subsystem to overall rest frame.
3697C..(Only relevant when photon inside lepton beam.)
3698 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3699
3700C...Recalculate energies from momenta and masses (if desired).
3701 IF(MSTP(113).GE.1) THEN
3702 DO 190 I=MINT(83)+1,N
3703 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3704 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3705 190 CONTINUE
3706 NRECAL=N
3707 ENDIF
3708
3709C...Colour reconnection before string formation
3710 CALL PYFSCR(MINT(84)+1)
3711
3712C...Rearrange partons along strings, check invariant mass cuts.
3713 MSTU(28)=0
3714 IF(MSTP(111).LE.0) MSTJ(14)=-1
3715 CALL PYPREP(MINT(84)+1)
3716 MSTJ(14)=MSTJ14
3717 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3718 MSTU(24)=0
3719 GOTO 100
3720 ENDIF
3721 IF(MINT(51).EQ.1) GOTO 110
3722 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3723 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3724 DO 220 I=MINT(84)+1,N
3725 IF(K(I,2).EQ.94) THEN
3726 DO 210 I1=I+1,MIN(N,I+10)
3727 IF(K(I1,3).EQ.I) THEN
3728 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3729 IF(K(I1,3).EQ.0) THEN
3730 DO 200 II=MINT(84)+1,I-1
3731 IF(K(II,2).EQ.K(I1,2)) THEN
3732 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3733 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3734 ENDIF
3735 200 CONTINUE
3736 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3737 ENDIF
3738 ENDIF
3739 210 CONTINUE
3740 ENDIF
3741 220 CONTINUE
3742 CALL PYEDIT(12)
3743 CALL PYEDIT(14)
3744 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3745 IF(MSTP(125).EQ.0) MINT(4)=0
3746 DO 240 I=MINT(83)+1,N
3747 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3748 DO 230 I1=I+1,N
3749 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3750 IF(K(I1,3).EQ.I) K(I,5)=I1
3751 230 CONTINUE
3752 ENDIF
3753 240 CONTINUE
3754 ENDIF
3755
3756C...Introduce separators between sections in PYLIST event listing.
3757 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3758 MSTU70=1
3759 MSTU(71)=N
3760 ELSEIF(IPILE.EQ.1) THEN
3761 MSTU70=3
3762 MSTU(71)=2
3763 MSTU(72)=MINT(4)
3764 MSTU(73)=N
3765 ENDIF
3766
3767C...Go back to lab frame (needed for vertices, also in fragmentation).
3768 CALL PYFRAM(1)
3769
3770C...Set nonvanishing production vertex (optional).
3771 IF(MSTP(151).EQ.1) THEN
3772 DO 250 J=1,4
3773 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3774 & SIN(PARU(2)*PYR(0))
3775 250 CONTINUE
3776 DO 270 I=MINT(83)+1,N
3777 DO 260 J=1,4
3778 V(I,J)=V(I,J)+VTX(J)
3779 260 CONTINUE
3780 270 CONTINUE
3781 ENDIF
3782
3783C...Perform hadronization (if desired).
3784 IF(MSTP(111).GE.1) THEN
3785 CALL PYEXEC
3786 IF(MSTU(24).NE.0) GOTO 100
3787 ENDIF
3788 IF(MSTP(113).GE.1) THEN
3789 DO 280 I=NRECAL,N
3790 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3791 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3792 280 CONTINUE
3793 ENDIF
3794 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3795
3796C...Store event information and calculate Monte Carlo estimates of
3797C...subprocess cross-sections.
3798 290 IF(IPILE.EQ.1) CALL PYDOCU
3799
3800C...Set counters for current pileup event and loop to next one.
3801 MSTI(41)=IPILE
3802 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3803 IF(MSTU70.LT.10) THEN
3804 MSTU70=MSTU70+1
3805 MSTU(70+MSTU70)=N
3806 ENDIF
3807 MINT(83)=N
3808 MINT(84)=N+MSTP(126)
3809 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3810 300 CONTINUE
3811
3812C...Generic information on pileup events. Reconstruct missing history.
3813 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3814 PARI(91)=VINT(132)
3815 PARI(92)=VINT(133)
3816 PARI(93)=VINT(134)
3817 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3818 ENDIF
3819 CALL PYEDIT(16)
3820
3821C...Transform to the desired coordinate frame.
3822 310 CALL PYFRAM(MSTP(124))
3823 MSTU(70)=MSTU70
3824 PARU(21)=VINT(1)
3825
3826C...Error messages
3827 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3828 &1X,'Execution stopped.')
3829
3830 RETURN
3831 END
3832
3833
3834C***********************************************************************
3835
3836C...PYSTAT
3837C...Prints out information about cross-sections, decay widths, branching
3838C...ratios, kinematical limits, status codes and parameter values.
3839
3840 SUBROUTINE PYSTAT(MSTAT)
3841
3842C...Double precision and integer declarations.
3843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3844 IMPLICIT INTEGER(I-N)
3845 INTEGER PYK,PYCHGE,PYCOMP
3846C...Parameter statement to help give large particle numbers.
3847 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3848 &KEXCIT=4000000,KDIMEN=5000000)
3849 PARAMETER (EPS=1D-3)
3850C...Commonblocks.
3851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3853 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3854 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3855 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3856 COMMON/PYINT1/MINT(400),VINT(400)
3857 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3858 COMMON/PYINT4/MWID(500),WIDS(500,5)
3859 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3860 COMMON/PYINT6/PROC(0:500)
3861 CHARACTER PROC*28, CHTMP*16
3862 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3863 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3864 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3865 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3866C...Local arrays, character variables and data.
3867 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3868 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3869 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3870 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3871 CHARACTER*24 CHD0, CHDC(10)
3872 CHARACTER*6 DNAME(3)
3873 DATA PROGA/
3874 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3875 &'VMD/hadron * anomalous ','direct * direct ',
3876 &'direct * anomalous ','anomalous * anomalous '/
3877 DATA DISGA/'e * VMD','e * anomalous'/
3878 DATA PROGG9/
3879 &'direct * direct ','direct * VMD ',
3880 &'direct * anomalous ','VMD * direct ',
3881 &'VMD * VMD ','VMD * anomalous ',
3882 &'anomalous * direct ','anomalous * VMD ',
3883 &'anomalous * anomalous ','DIS * VMD ',
3884 &'DIS * anomalous ','VMD * DIS ',
3885 &'anomalous * DIS '/
3886 DATA PROGG4/
3887 &'direct * direct ','direct * resolved ',
3888 &'resolved * direct ','resolved * resolved '/
3889 DATA PROGG2/
3890 &'direct * hadron ','resolved * hadron '/
3891 DATA PROGP4/
3892 &'VMD * hadron ','direct * hadron ',
3893 &'anomalous * hadron ','DIS * hadron '/
3894 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3895 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3896 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3897 &' y*_small ',' eta*_large ',' eta*_small ',
3898 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3899 &' x_2 ',' x_F ',' cos(theta_hard) ',
3900 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3901 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3902 &' tau'' '/
3903 DATA DNAME /'q ','lepton','nu '/
3904
3905C...Cross-sections.
3906 IF(MSTAT.LE.1) THEN
3907 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3908 WRITE(MSTU(11),5000)
3909 WRITE(MSTU(11),5100)
3910 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3911 DO 100 I=1,500
3912 IF(MSUB(I).NE.1) GOTO 100
3913 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3914 100 CONTINUE
3915 IF(MINT(121).GT.1) THEN
3916 WRITE(MSTU(11),5300)
3917 DO 110 IGA=1,MINT(121)
3918 CALL PYSAVE(3,IGA)
3919 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3920 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3921 & XSEC(0,3)
3922 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3923 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3924 & XSEC(0,3)
3925 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3926 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3927 & XSEC(0,3)
3928 ELSEIF(MINT(121).EQ.4) THEN
3929 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3930 & XSEC(0,3)
3931 ELSEIF(MINT(121).EQ.2) THEN
3932 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3933 & XSEC(0,3)
3934 ELSE
3935 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3936 & XSEC(0,3)
3937 ENDIF
3938 110 CONTINUE
3939 CALL PYSAVE(5,0)
3940 ENDIF
3941 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3942 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3943
3944C...Decay widths and branching ratios.
3945 ELSEIF(MSTAT.EQ.2) THEN
3946 WRITE(MSTU(11),5500)
3947 WRITE(MSTU(11),5600)
3948 DO 140 KC=1,500
3949 KF=KCHG(KC,4)
3950 CALL PYNAME(KF,CHKF)
3951 IOFF=0
3952 IF(KC.LE.22) THEN
3953 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3954 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3955 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3956 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3957 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3958 ELSE
3959 IF(MWID(KC).LE.0) GOTO 140
3960 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3961 & KF/KSUSY1.EQ.2)) GOTO 140
3962 ENDIF
3963C...Off-shell branchings.
3964 IF(IOFF.EQ.1) THEN
3965 NGP=0
3966 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3967 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3968 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3969 DO 120 J=1,MDCY(KC,3)
3970 IDC=J+MDCY(KC,2)-1
3971 NGP1=0
3972 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3973 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3974 NGP2=0
3975 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3976 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3977 CALL PYNAME(KFDP(IDC,1),CHD1)
3978 CALL PYNAME(KFDP(IDC,2),CHD2)
3979 IF(KFDP(IDC,3).EQ.0) THEN
3980 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3981 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3982 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3983 ELSE
3984 CALL PYNAME(KFDP(IDC,3),CHD3)
3985 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3986 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3987 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3988 ENDIF
3989 120 CONTINUE
3990C...On-shell decays.
3991 ELSE
3992 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3993 BRFIN=1D0
3994 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3995 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3996 & STATE(MDCY(KC,1)),BRFIN
3997 DO 130 J=1,MDCY(KC,3)
3998 IDC=J+MDCY(KC,2)-1
3999 NGP1=0
4000 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4001 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4002 NGP2=0
4003 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4004 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4005 BRPRI=0D0
4006 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4007 BRFIN=0D0
4008 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4009 CALL PYNAME(KFDP(IDC,1),CHD1)
4010 CALL PYNAME(KFDP(IDC,2),CHD2)
4011 IF(KFDP(IDC,3).EQ.0) THEN
4012 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4013 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4014 & CHD2(1:10),WDTP(J),BRPRI,
4015 & STATE(MDME(IDC,1)),BRFIN
4016 ELSE
4017 CALL PYNAME(KFDP(IDC,3),CHD3)
4018 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4019 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4020 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4021 & STATE(MDME(IDC,1)),BRFIN
4022 ENDIF
4023 130 CONTINUE
4024 ENDIF
4025 140 CONTINUE
4026 WRITE(MSTU(11),6000)
4027
4028C...Allowed incoming partons/particles at hard interaction.
4029 ELSEIF(MSTAT.EQ.3) THEN
4030 WRITE(MSTU(11),6100)
4031 CALL PYNAME(MINT(11),CHAU)
4032 CHIN(1)=CHAU(1:12)
4033 CALL PYNAME(MINT(12),CHAU)
4034 CHIN(2)=CHAU(1:12)
4035 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4036 DO 150 I=-20,22
4037 IF(I.EQ.0) GOTO 150
4038 IA=IABS(I)
4039 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4040 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4041 CALL PYNAME(I,CHAU)
4042 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4043 & STATE(KFIN(2,I))
4044 150 CONTINUE
4045 WRITE(MSTU(11),6400)
4046
4047C...User-defined limits on kinematical variables.
4048 ELSEIF(MSTAT.EQ.4) THEN
4049 WRITE(MSTU(11),6500)
4050 WRITE(MSTU(11),6600)
4051 SHRMAX=CKIN(2)
4052 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4053 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4054 PTHMIN=MAX(CKIN(3),CKIN(5))
4055 PTHMAX=CKIN(4)
4056 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4057 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4058 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4059 DO 160 I=4,14
4060 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4061 160 CONTINUE
4062 SPRMAX=CKIN(32)
4063 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4064 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4065 WRITE(MSTU(11),7000)
4066
4067C...Status codes and parameter values.
4068 ELSEIF(MSTAT.EQ.5) THEN
4069 WRITE(MSTU(11),7100)
4070 WRITE(MSTU(11),7200)
4071 DO 170 I=1,100
4072 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4073 & PARP(100+I)
4074 170 CONTINUE
4075
4076C...List of all processes implemented in the program.
4077 ELSEIF(MSTAT.EQ.6) THEN
4078 WRITE(MSTU(11),7400)
4079 WRITE(MSTU(11),7500)
4080 DO 180 I=1,500
4081 IF(ISET(I).LT.0) GOTO 180
4082 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4083 180 CONTINUE
4084 WRITE(MSTU(11),7700)
4085
4086 ELSEIF(MSTAT.EQ.7) THEN
4087 WRITE (MSTU(11),8000)
4088 NMODES(0)=0
4089 NMODES(10)=0
4090 NMODES(9)=0
4091 DO 290 ILR=1,2
4092 DO 280 KFSM=1,16
4093 KFSUSY=ILR*KSUSY1+KFSM
4094 NRVDC=0
4095C...SDOWN DECAYS
4096 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4097 NRVDC=3
4098 DO 190 I=1,NRVDC
4099 PBRAT(I)=0D0
4100 NMODES(I)=0
4101 190 CONTINUE
4102 CALL PYNAME(KFSUSY,CHTMP)
4103 CHD0=CHTMP//' '
4104 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4105 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4106 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4107 KC=PYCOMP(KFSUSY)
4108 DO 200 J=1,MDCY(KC,3)
4109 IDC=J+MDCY(KC,2)-1
4110 ID1=IABS(KFDP(IDC,1))
4111 ID2=IABS(KFDP(IDC,2))
4112 IF (KFDP(IDC,3).EQ.0) THEN
4113 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4114 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4115 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4116 NMODES(1)=NMODES(1)+1
4117 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4118 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4119 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4120 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4121 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4122 NMODES(2)=NMODES(2)+1
4123 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4124 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4125 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4126 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4127 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4128 NMODES(3)=NMODES(3)+1
4129 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4130 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4131 ENDIF
4132 ENDIF
4133 200 CONTINUE
4134 ENDIF
4135C...SUP DECAYS
4136 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4137 NRVDC=2
4138 DO 210 I=1,NRVDC
4139 NMODES(I)=0
4140 PBRAT(I)=0D0
4141 210 CONTINUE
4142 CALL PYNAME(KFSUSY,CHTMP)
4143 CHD0=CHTMP//' '
4144 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4145 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4146 KC=PYCOMP(KFSUSY)
4147 DO 220 J=1,MDCY(KC,3)
4148 IDC=J+MDCY(KC,2)-1
4149 ID1=IABS(KFDP(IDC,1))
4150 ID2=IABS(KFDP(IDC,2))
4151 IF (KFDP(IDC,3).EQ.0) THEN
4152 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4153 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4154 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4155 NMODES(1)=NMODES(1)+1
4156 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4157 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4158 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4159 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4160 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4161 NMODES(2)=NMODES(2)+1
4162 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4163 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4164 ENDIF
4165 ENDIF
4166 220 CONTINUE
4167 ENDIF
4168C...SLEPTON DECAYS
4169 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4170 NRVDC=2
4171 DO 230 I=1,NRVDC
4172 PBRAT(I)=0D0
4173 NMODES(I)=0
4174 230 CONTINUE
4175 CALL PYNAME(KFSUSY,CHTMP)
4176 CHD0=CHTMP//' '
4177 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4178 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4179 KC=PYCOMP(KFSUSY)
4180 DO 240 J=1,MDCY(KC,3)
4181 IDC=J+MDCY(KC,2)-1
4182 ID1=IABS(KFDP(IDC,1))
4183 ID2=IABS(KFDP(IDC,2))
4184 IF (KFDP(IDC,3).EQ.0) THEN
4185 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4186 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4187 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4188 NMODES(1)=NMODES(1)+1
4189 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4190 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4191 ENDIF
4192 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4193 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4194 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4195 NMODES(2)=NMODES(2)+1
4196 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4197 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4198 ENDIF
4199 ENDIF
4200 240 CONTINUE
4201 ENDIF
4202C...SNEUTRINO DECAYS
4203 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4204 & THEN
4205 NRVDC=2
4206 DO 250 I=1,NRVDC
4207 PBRAT(I)=0D0
4208 NMODES(I)=0
4209 250 CONTINUE
4210 CALL PYNAME(KFSUSY,CHTMP)
4211 CHD0=CHTMP//' '
4212 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4213 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4214 KC=PYCOMP(KFSUSY)
4215 DO 260 J=1,MDCY(KC,3)
4216 IDC=J+MDCY(KC,2)-1
4217 ID1=IABS(KFDP(IDC,1))
4218 ID2=IABS(KFDP(IDC,2))
4219 IF (KFDP(IDC,3).EQ.0) THEN
4220 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4221 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4222 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4223 NMODES(1)=NMODES(1)+1
4224 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4225 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4226 ENDIF
4227 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4228 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4229 NMODES(2)=NMODES(2)+1
4230 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4231 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4232 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4233 ENDIF
4234 ENDIF
4235 260 CONTINUE
4236 ENDIF
4237 IF (NRVDC.NE.0) THEN
4238 DO 270 I=1,NRVDC
4239 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4240 NMODES(0)=NMODES(0)+NMODES(I)
4241 270 CONTINUE
4242 ENDIF
4243 280 CONTINUE
4244 290 CONTINUE
4245 DO 370 KFSM=21,37
4246 KFSUSY=KSUSY1+KFSM
4247 NRVDC=0
4248C...NEUTRALINO DECAYS
4249 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4250 NRVDC=4
4251 DO 300 I=1,NRVDC
4252 PBRAT(I)=0D0
4253 NMODES(I)=0
4254 300 CONTINUE
4255 CALL PYNAME(KFSUSY,CHTMP)
4256 CHD0=CHTMP//' '
4257 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4258 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4259 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4260 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4261 KC=PYCOMP(KFSUSY)
4262 DO 310 J=1,MDCY(KC,3)
4263 IDC=J+MDCY(KC,2)-1
4264 ID1=IABS(KFDP(IDC,1))
4265 ID2=IABS(KFDP(IDC,2))
4266 ID3=IABS(KFDP(IDC,3))
4267 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4268 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4269 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4270 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4271 NMODES(1)=NMODES(1)+1
4272 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4273 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4274 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4275 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4276 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4277 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4278 NMODES(2)=NMODES(2)+1
4279 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4280 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4281 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4282 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4283 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4284 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4285 NMODES(3)=NMODES(3)+1
4286 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4287 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4288 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4289 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4290 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4291 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4292 NMODES(4)=NMODES(4)+1
4293 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4294 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4295 ENDIF
4296 310 CONTINUE
4297 ENDIF
4298C...CHARGINO DECAYS
4299 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4300 NRVDC=5
4301 DO 320 I=1,NRVDC
4302 PBRAT(I)=0D0
4303 NMODES(I)=0
4304 320 CONTINUE
4305 CALL PYNAME(KFSUSY,CHTMP)
4306 CHD0=CHTMP//' '
4307 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4308 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4309 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4310 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4311 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4312 KC=PYCOMP(KFSUSY)
4313 DO 330 J=1,MDCY(KC,3)
4314 IDC=J+MDCY(KC,2)-1
4315 ID1=IABS(KFDP(IDC,1))
4316 ID2=IABS(KFDP(IDC,2))
4317 ID3=IABS(KFDP(IDC,3))
4318 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4319 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4320 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4321 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4322 NMODES(1)=NMODES(1)+1
4323 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4324 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4325 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4326 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4327 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4328 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4329 NMODES(1)=NMODES(1)+1
4330 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4331 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4332 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4333 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4334 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4335 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4336 NMODES(2)=NMODES(2)+1
4337 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4338 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4339 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4340 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4341 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4342 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4343 NMODES(3)=NMODES(3)+1
4344 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4345 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4346 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4347 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4348 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4349 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4350 NMODES(3)=NMODES(3)+1
4351 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4352 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4353 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4354 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4355 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4356 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4357 NMODES(4)=NMODES(4)+1
4358 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4359 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4360 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4361 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4362 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4363 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4364 NMODES(4)=NMODES(4)+1
4365 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4366 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4367 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4368 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4369 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4370 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4371 NMODES(5)=NMODES(5)+1
4372 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4373 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4374 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4375 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4376 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4377 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4378 NMODES(5)=NMODES(5)+1
4379 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4380 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4381 ENDIF
4382 330 CONTINUE
4383 ENDIF
4384C...GLUINO DECAYS
4385 IF (KFSM.EQ.21) THEN
4386 NRVDC=3
4387 DO 340 I=1,NRVDC
4388 PBRAT(I)=0D0
4389 NMODES(I)=0
4390 340 CONTINUE
4391 CALL PYNAME(KFSUSY,CHTMP)
4392 CHD0=CHTMP//' '
4393 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4394 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4395 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4396 KC=PYCOMP(KFSUSY)
4397 DO 350 J=1,MDCY(KC,3)
4398 IDC=J+MDCY(KC,2)-1
4399 ID1=IABS(KFDP(IDC,1))
4400 ID2=IABS(KFDP(IDC,2))
4401 ID3=IABS(KFDP(IDC,3))
4402 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4403 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4404 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4405 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4406 NMODES(1)=NMODES(1)+1
4407 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4408 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4409 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4410 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4411 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4412 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4413 NMODES(2)=NMODES(2)+1
4414 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4415 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4416 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4417 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4418 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4419 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4420 NMODES(3)=NMODES(3)+1
4421 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4422 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4423 ENDIF
4424 350 CONTINUE
4425 ENDIF
4426
4427 IF (NRVDC.NE.0) THEN
4428 DO 360 I=1,NRVDC
4429 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4430 NMODES(0)=NMODES(0)+NMODES(I)
4431 360 CONTINUE
4432 ENDIF
4433 370 CONTINUE
4434 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4435
4436 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4437 WRITE (MSTU(11),8500)
4438 DO 400 IRV=1,3
4439 DO 390 JRV=1,3
4440 DO 380 KRV=1,3
4441 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4442 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4443 380 CONTINUE
4444 390 CONTINUE
4445 400 CONTINUE
4446 WRITE (MSTU(11),8600)
4447 ENDIF
4448 ENDIF
4449
4450C...Formats for printouts.
4451 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4452 &'Events and Cross-sections',1X,9('*'))
4453 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4454 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4455 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4456 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4457 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4458 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4459 &'I',12X,'I')
4460 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4461 &D10.3,1X,'I')
4462 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4463 &1X,'I',34X,'I',28X,'I',12X,'I')
4464 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4465 &1X,'********* Total number of errors, excluding junctions =',
4466 &1X,I8,' *************'/
4467 &1X,'********* Total number of errors, including junctions =',
4468 &1X,I8,' *************'/
4469 &1X,'********* Total number of warnings = ',
4470 &1X,I8,' *************'/
4471 &1X,'********* Fraction of events that fail fragmentation ',
4472 &'cuts =',1X,F8.5,' *********'/)
4473 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4474 &'Ratios',1X,27('*'))
4475 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4476 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4477 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4478 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4479 &1X,98('='))
4480 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4481 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4482 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4483 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4484 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4485 &1P,D10.3,0P,1X,'I')
4486 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4487 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4488 &1P,D10.3,0P,1X,'I')
4489 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4490 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4491 &'Particles at Hard Interaction',1X,7('*'))
4492 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4493 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4494 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4495 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4496 &78('=')/1X,'I',38X,'I',37X,'I')
4497 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4498 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4499 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4500 &'Kinematical Variables',1X,12('*'))
4501 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4502 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4503 &16X,'I')
4504 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4505 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4506 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4507 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4508 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4509 &'Parameter Values',1X,12('*'))
4510 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4511 &'PARP(I)'/)
4512 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4513 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4514 &1X,13('*'))
4515 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4516 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4517 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4518 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4519 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4520 8000 FORMAT(1X/ 1X/
4521 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4522 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4523 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4524 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4525 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4526 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4527 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4528 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4529 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4530 & /1X,70('='))
4531 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4532 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4533 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4534 8500 FORMAT(1X/ 1X/
4535 & 1X,'R-Violating couplings',1X/ 1X /
4536 & 1X,55('=')/
4537 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4538 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4539 & ,'I',15X,'I',15X,'I',15X,'I')
4540 8600 FORMAT(1X,55('='))
4541 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4542 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4543
4544 RETURN
4545 END
4546
4547C*********************************************************************
4548
4549C...PYUPEV
4550C...Administers the hard-process generation required for output to the
4551C...Les Houches event record.
4552
4553 SUBROUTINE PYUPEV
4554
4555C...Double precision and integer declarations.
4556 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4557 IMPLICIT INTEGER(I-N)
4558 INTEGER PYK,PYCHGE,PYCOMP
4559
4560C...Commonblocks.
4561 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4562 COMMON/PYCTAG/NCT,MCT(4000,2)
4563 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4564 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4565 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4566 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4567 COMMON/PYINT1/MINT(400),VINT(400)
4568 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4569 COMMON/PYINT4/MWID(500),WIDS(500,5)
4570 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4571 &/PYINT1/,/PYINT2/,/PYINT4/
4572
4573C...HEPEUP for output.
4574 INTEGER MAXNUP
4575 PARAMETER (MAXNUP=500)
4576 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4577 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4578 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4579 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4580 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4581 SAVE /HEPEUP/
4582
4583C...Stop if no subprocesses on.
4584 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4585 WRITE(MSTU(11),5100)
4586 STOP
4587 ENDIF
4588
4589C...Special flags for hard-process generation only.
4590 MSTP71=MSTP(71)
4591 MSTP(71)=0
4592 MST128=MSTP(128)
4593 MSTP(128)=1
4594
4595C...Initial values for some counters.
4596 N=0
4597 MINT(5)=MINT(5)+1
4598 MINT(7)=0
4599 MINT(8)=0
4600 MINT(30)=0
4601 MINT(83)=0
4602 MINT(84)=MSTP(126)
4603 MSTU(24)=0
4604 MSTU70=0
4605 MSTJ14=MSTJ(14)
4606C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4607 MINT(33)=0
4608
4609C...If variable energies: redo incoming kinematics and cross-section.
4610 MSTI(61)=0
4611 IF(MSTP(171).EQ.1) THEN
4612 CALL PYINKI(1)
4613 IF(MSTI(61).EQ.1) THEN
4614 MINT(5)=MINT(5)-1
4615 RETURN
4616 ENDIF
4617 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4618 CALL PYXTOT
4619 ENDIF
4620
4621C...Do not allow pileup events.
4622 MINT(82)=1
4623
4624C...Generate variables of hard scattering.
4625 MINT(51)=0
4626 MSTI(52)=0
4627 100 CONTINUE
4628 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4629 MINT(31)=0
4630 MINT(51)=0
4631 MINT(57)=0
4632 CALL PYRAND
4633 IF(MSTI(61).EQ.1) THEN
4634 MINT(5)=MINT(5)-1
4635 RETURN
4636 ENDIF
4637 IF(MINT(51).EQ.2) RETURN
4638 ISUB=MINT(1)
4639
4640 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4641C...Hard scattering (including low-pT):
4642C...reconstruct kinematics and colour flow of hard scattering.
4643 MINT31=MINT(31)
4644 110 MINT(31)=MINT31
4645 MINT(51)=0
4646 CALL PYSCAT
4647 IF(MINT(51).EQ.1) GOTO 100
4648 IPU1=MINT(84)+1
4649 IPU2=MINT(84)+2
4650
4651C...Decay of final state resonances.
4652 MINT(32)=0
4653 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4654 & CALL PYRESD(0)
4655 IF(MINT(51).EQ.1) GOTO 100
4656 MINT(52)=N
4657
4658C...Longitudinal boost of hard scattering.
4659 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4660 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4661
4662 ELSEIF(ISUB.NE.99) THEN
4663C...Diffractive and elastic scattering.
4664 CALL PYDIFF
4665
4666 ELSE
4667C...DIS scattering (photon flux external).
4668 CALL PYDISG
4669 IF(MINT(51).EQ.1) GOTO 100
4670 ENDIF
4671
4672C...Check that no odd resonance left undecayed.
4673 MINT(54)=N
4674 NFIX=N
4675 DO 120 I=MINT(84)+1,NFIX
4676 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4677 & K(I,2).NE.22) THEN
4678 KCA=PYCOMP(K(I,2))
4679 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4680 CALL PYRESD(I)
4681 IF(MINT(51).EQ.1) GOTO 100
4682 ENDIF
4683 ENDIF
4684 120 CONTINUE
4685
4686C...Boost hadronic subsystem to overall rest frame.
4687C..(Only relevant when photon inside lepton beam.)
4688 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4689
4690C...Store event information and calculate Monte Carlo estimates of
4691C...subprocess cross-sections.
4692 130 CALL PYDOCU
4693
4694C...Transform to the desired coordinate frame.
4695 140 CALL PYFRAM(MSTP(124))
4696 MSTU(70)=MSTU70
4697 PARU(21)=VINT(1)
4698
4699C...Restore special flags for hard-process generation only.
4700 MSTP(71)=MSTP71
4701 MSTP(128)=MST128
4702
4703C...Trace colour tags; convert to LHA style labels.
4704 NCT=100
4705 DO 150 I=MINT(84)+1,N
4706 MCT(I,1)=0
4707 MCT(I,2)=0
4708 150 CONTINUE
4709 DO 160 I=MINT(84)+1,N
4710 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4711 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4712 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4713 & THEN
4714 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4715 IDA=MOD(K(I,4),MSTU(5))
4716 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4717 & MCT(IMO,2).NE.0) THEN
4718 MCT(I,1)=MCT(IMO,2)
4719 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4720 & MCT(IMO,1).NE.0) THEN
4721 MCT(I,1)=MCT(IMO,1)
4722 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4723 & MCT(IDA,2).NE.0) THEN
4724 MCT(I,1)=MCT(IDA,2)
4725 ELSE
4726 NCT=NCT+1
4727 MCT(I,1)=NCT
4728 ENDIF
4729 ENDIF
4730 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4731 & THEN
4732 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4733 IDA=MOD(K(I,5),MSTU(5))
4734 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4735 & MCT(IMO,1).NE.0) THEN
4736 MCT(I,2)=MCT(IMO,1)
4737 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4738 & MCT(IMO,2).NE.0) THEN
4739 MCT(I,2)=MCT(IMO,2)
4740 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4741 & MCT(IDA,1).NE.0) THEN
4742 MCT(I,2)=MCT(IDA,1)
4743 ELSE
4744 NCT=NCT+1
4745 MCT(I,2)=NCT
4746 ENDIF
4747 ENDIF
4748 ENDIF
4749 160 CONTINUE
4750
4751C...Put event in HEPEUP commonblock.
4752 NUP=N-MINT(84)
4753 IDPRUP=MINT(1)
4754 XWGTUP=1D0
4755 SCALUP=VINT(53)
4756 AQEDUP=VINT(57)
4757 AQCDUP=VINT(58)
4758 DO 180 I=1,NUP
4759 IDUP(I)=K(I+MINT(84),2)
4760 IF(I.LE.2) THEN
4761 ISTUP(I)=-1
4762 MOTHUP(1,I)=0
4763 MOTHUP(2,I)=0
4764 ELSEIF(K(I+4,3).EQ.0) THEN
4765 ISTUP(I)=1
4766 MOTHUP(1,I)=1
4767 MOTHUP(2,I)=2
4768 ELSE
4769 ISTUP(I)=1
4770 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4771 MOTHUP(2,I)=0
4772 ENDIF
4773 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4774 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4775 ICOLUP(1,I)=MCT(I+MINT(84),1)
4776 ICOLUP(2,I)=MCT(I+MINT(84),2)
4777 DO 170 J=1,5
4778 PUP(J,I)=P(I+MINT(84),J)
4779 170 CONTINUE
4780 VTIMUP(I)=V(I,5)
4781 SPINUP(I)=9D0
4782 180 CONTINUE
4783
4784C...Optionally write out event to disk. Minimal size for time/spin fields.
4785 IF(MSTP(162).GT.0) THEN
4786 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4787 DO 190 I=1,NUP
4788 IF(VTIMUP(I).EQ.0D0) THEN
4789 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4790 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4791 & ' 0. 9.'
4792 ELSE
4793 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4794 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4795 & VTIMUP(I),' 9.'
4796 ENDIF
4797 190 CONTINUE
4798
4799C...Optional extra line with parton-density information.
4800 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4801 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4802 ENDIF
4803
4804C...Error messages and other print formats.
4805 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4806 &1X,'Execution stopped.')
4807 5200 FORMAT(1P,2I6,4E14.6)
4808 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4809 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4810 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4811
4812 RETURN
4813 END
4814
4815C*********************************************************************
4816
4817C...PYUPIN
4818C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4819C...processes, and optionally stores that information on file.
4820
4821 SUBROUTINE PYUPIN
4822
4823C...Double precision and integer declarations.
4824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4825 IMPLICIT INTEGER(I-N)
4826
4827C...Commonblocks.
4828 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4829 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4830 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4831 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4832 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4833
4834C...User process initialization commonblock.
4835 INTEGER MAXPUP
4836 PARAMETER (MAXPUP=100)
4837 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4838 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4839 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4840 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4841 &LPRUP(MAXPUP)
4842 SAVE /HEPRUP/
4843
4844C...Store info on incoming beams.
4845 IDBMUP(1)=K(1,2)
4846 IDBMUP(2)=K(2,2)
4847 EBMUP(1)=P(1,4)
4848 EBMUP(2)=P(2,4)
4849 PDFGUP(1)=0
4850 PDFGUP(2)=0
4851 PDFSUP(1)=MSTP(51)
4852 PDFSUP(2)=MSTP(51)
4853
4854C...Event weighting strategy.
4855 IDWTUP=3
4856
4857C...Info on individual processes.
4858 NPRUP=0
4859 DO 100 ISUB=1,500
4860 IF(MSUB(ISUB).EQ.1) THEN
4861 NPRUP=NPRUP+1
4862 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4863 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4864 XMAXUP(NPRUP)=1D0
4865 LPRUP(NPRUP)=ISUB
4866 ENDIF
4867 100 CONTINUE
4868
4869C...Write info to file.
4870 IF(MSTP(161).GT.0) THEN
4871 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4872 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4873 DO 110 IPR=1,NPRUP
4874 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4875 & LPRUP(IPR)
4876 110 CONTINUE
4877 ENDIF
4878
4879C...Formats for printout.
4880 5100 FORMAT(1P,2I8,2E14.6,6I6)
4881 5200 FORMAT(1P,3E14.6,I6)
4882
4883 RETURN
4884 END
4885
4886
4887C*********************************************************************
4888
4889C...Combine the two old-style Pythia initialization and event files
4890C...into a single Les Houches Event File.
4891
4892 SUBROUTINE PYLHEF
4893
4894C...Double precision and integer declarations.
4895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4896 IMPLICIT INTEGER(I-N)
4897
4898C...PYTHIA commonblock: only used to provide read/write units and version.
4899 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4900 SAVE /PYPARS/
4901
4902C...User process initialization commonblock.
4903 INTEGER MAXPUP
4904 PARAMETER (MAXPUP=100)
4905 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4906 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4907 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4908 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4909 &LPRUP(MAXPUP)
4910 SAVE /HEPRUP/
4911
4912C...User process event common block.
4913 INTEGER MAXNUP
4914 PARAMETER (MAXNUP=500)
4915 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4916 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4917 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4918 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4919 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4920 SAVE /HEPEUP/
4921
4922C...Lines to read in assumed never longer than 200 characters.
4923 PARAMETER (MAXLEN=200)
4924 CHARACTER*(MAXLEN) STRING
4925
4926C...Format for reading lines.
4927 CHARACTER*6 STRFMT
4928 STRFMT='(A000)'
4929 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4930
4931C...Rewind initialization and event files.
4932 REWIND MSTP(161)
4933 REWIND MSTP(162)
4934
4935C...Write header info.
4936 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4937 WRITE(MSTP(163),'(A)') '<!--'
4938 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4939 &MSTP(181),'.',MSTP(182)
4940 WRITE(MSTP(163),'(A)') '-->'
4941
4942C...Read first line of initialization info and get number of processes.
4943 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4944 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4945 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4946
4947C...Copy initialization lines, omitting trailing blanks.
4948C...Embed in <init> ... </init> block.
4949 WRITE(MSTP(163),'(A)') '<init>'
4950 DO 140 IPR=0,NPRUP
4951 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4952 LEN=MAXLEN+1
4953 120 LEN=LEN-1
4954 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4955 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4956 140 CONTINUE
4957 WRITE(MSTP(163),'(A)') '</init>'
4958
4959C...Begin event loop. Read first line of event info or already done.
4960 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4961 200 CONTINUE
4962
4963C...Look at first line to know number of particles in event.
4964 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4965
4966C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4967 WRITE(MSTP(163),'(A)') '<event>'
4968 DO 240 I=0,NUP
4969 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4970 LEN=MAXLEN+1
4971 220 LEN=LEN-1
4972 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4973 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4974 240 CONTINUE
4975
4976C...Copy trailing comment lines - with a # in the first column - as is.
4977 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4978 IF(STRING(1:1).EQ.'#') THEN
4979 LEN=MAXLEN+1
4980 280 LEN=LEN-1
4981 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4982 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4983 GOTO 260
4984 ENDIF
4985
4986C..End the <event> block. Loop back to look for next event.
4987 WRITE(MSTP(163),'(A)') '</event>'
4988 GOTO 200
4989
4990C...Successfully reached end of event loop: write closing tag
4991C...and remove temporary intermediate files (unless asked not to).
4992 300 WRITE(MSTP(163),'(A)') '</event>'
4993 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4994 IF(MSTP(164).EQ.1) RETURN
4995 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4996 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
4997 RETURN
4998
4999C...Error exit.
5000 400 WRITE(*,*) ' PYLHEF file joining failed!'
5001
5002 RETURN
5003 END
5004
5005C*********************************************************************
5006
5007C...PYINRE
5008C...Calculates full and effective widths of gauge bosons, stores
5009C...masses and widths, rescales coefficients to be used for
5010C...resonance production generation.
5011
5012 SUBROUTINE PYINRE
5013
5014C...Double precision and integer declarations.
5015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5016 IMPLICIT INTEGER(I-N)
5017 INTEGER PYK,PYCHGE,PYCOMP
5018C...Parameter statement to help give large particle numbers.
5019 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5020 &KEXCIT=4000000,KDIMEN=5000000)
5021C...Commonblocks.
5022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5024 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5025 COMMON/PYDAT4/CHAF(500,2)
5026 CHARACTER CHAF*16
5027 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5028 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5029 COMMON/PYINT1/MINT(400),VINT(400)
5030 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5031 COMMON/PYINT4/MWID(500),WIDS(500,5)
5032 COMMON/PYINT6/PROC(0:500)
5033 CHARACTER PROC*28
5034 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5035 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5036 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5037C...Local arrays and data.
5038 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5039 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5040
5041C...Born level couplings in MSSM Higgs doublet sector.
5042 XW=PARU(102)
5043 XWV=XW
5044 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5045 XW1=1D0-XW
5046 IF(MSTP(4).EQ.2) THEN
5047 TANBE=PARU(141)
5048 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5049 SQMZ=PMAS(23,1)**2
5050 SQMW=PMAS(24,1)**2
5051 SQMH=PMAS(25,1)**2
5052 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5053 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5054 SQMHC=SQMA+SQMW
5055 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5056 WRITE(MSTU(11),5000)
5057 CALL PYSTOP(101)
5058 ENDIF
5059 PMAS(35,1)=SQRT(SQMHP)
5060 PMAS(36,1)=SQRT(SQMA)
5061 PMAS(37,1)=SQRT(SQMHC)
5062 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5063 & (SQMA-SQMZ)))
5064 BESU=ATAN(TANBE)
5065 PARU(142)=1D0
5066 PARU(143)=1D0
5067 PARU(161)=-SIN(ALSU)/COS(BESU)
5068 PARU(162)=COS(ALSU)/SIN(BESU)
5069 PARU(163)=PARU(161)
5070 PARU(164)=SIN(BESU-ALSU)
5071 PARU(165)=PARU(164)
5072 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5073 PARU(171)=COS(ALSU)/COS(BESU)
5074 PARU(172)=SIN(ALSU)/SIN(BESU)
5075 PARU(173)=PARU(171)
5076 PARU(174)=COS(BESU-ALSU)
5077 PARU(175)=PARU(174)
5078 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5079 & SIN(BESU+ALSU)
5080 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5081 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5082 PARU(181)=TANBE
5083 PARU(182)=1D0/TANBE
5084 PARU(183)=PARU(181)
5085 PARU(184)=0D0
5086 PARU(185)=PARU(184)
5087 PARU(186)=COS(BESU-ALSU)
5088 PARU(187)=SIN(BESU-ALSU)
5089 PARU(188)=PARU(186)
5090 PARU(189)=PARU(187)
5091 PARU(190)=0D0
5092 PARU(195)=COS(BESU-ALSU)
5093 ENDIF
5094
5095C...Reset effective widths of gauge bosons.
5096 DO 110 I=1,500
5097 DO 100 J=1,5
5098 WIDS(I,J)=1D0
5099 100 CONTINUE
5100 110 CONTINUE
5101
5102C...Order resonances by increasing mass (except Z0 and W+/-).
5103 NRES=0
5104 DO 140 KC=1,500
5105 KF=KCHG(KC,4)
5106 IF(KF.EQ.0) GOTO 140
5107 IF(MWID(KC).EQ.0) GOTO 140
5108 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5109 IF(MSTP(1).LE.3) GOTO 140
5110 ENDIF
5111 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5112 IF(IMSS(1).LE.0) GOTO 140
5113 ENDIF
5114 NRES=NRES+1
5115 PMRES=PMAS(KC,1)
5116 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5117 DO 120 I1=NRES-1,1,-1
5118 IF(PMRES.GE.PMORD(I1)) GOTO 130
5119 KCORD(I1+1)=KCORD(I1)
5120 PMORD(I1+1)=PMORD(I1)
5121 120 CONTINUE
5122 130 KCORD(I1+1)=KC
5123 PMORD(I1+1)=PMRES
5124 140 CONTINUE
5125
5126C...Loop over possible resonances.
5127 DO 180 I=1,NRES
5128 KC=KCORD(I)
5129 KF=KCHG(KC,4)
5130
5131C...Check that no fourth generation channels on by mistake.
5132 IF(MSTP(1).LE.3) THEN
5133 DO 150 J=1,MDCY(KC,3)
5134 IDC=J+MDCY(KC,2)-1
5135 KFA1=IABS(KFDP(IDC,1))
5136 KFA2=IABS(KFDP(IDC,2))
5137 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5138 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5139 & MDME(IDC,1)=-1
5140 150 CONTINUE
5141 ENDIF
5142
5143C...Check that no supersymmetric channels on by mistake.
5144 IF(IMSS(1).LE.0) THEN
5145 DO 160 J=1,MDCY(KC,3)
5146 IDC=J+MDCY(KC,2)-1
5147 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5148 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5149 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5150 & MDME(IDC,1)=-1
5151 160 CONTINUE
5152 ENDIF
5153
5154C...Find mass and evaluate width.
5155 PMR=PMAS(KC,1)
5156 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5157 IF(MWID(KC).EQ.3) MINT(63)=1
5158 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5159 MINT(51)=0
5160
5161C...Evaluate suppression factors due to non-simulated channels.
5162 IF(KCHG(KC,3).EQ.0) THEN
5163 WDTP0I=0D0
5164 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5165 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5166 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5167 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5168 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5169 WIDS(KC,3)=0D0
5170 WIDS(KC,4)=0D0
5171 WIDS(KC,5)=0D0
5172 ELSE
5173 IF(MWID(KC).EQ.3) MINT(63)=1
5174 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5175 MINT(51)=0
5176 WDTP0I=0D0
5177 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5178 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5179 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5180 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5181 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5182 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5183 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5184 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5185 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5186 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5187 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5188 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5189 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5190 ENDIF
5191
5192C...Set resonance widths and branching ratios;
5193C...also on/off switch for decays.
5194 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5195 PMAS(KC,2)=WDTP(0)
5196 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5197 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5198 DO 170 J=1,MDCY(KC,3)
5199 IDC=J+MDCY(KC,2)-1
5200 BRAT(IDC)=0D0
5201 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5202 170 CONTINUE
5203 ENDIF
5204 180 CONTINUE
5205
5206C...Flavours of leptoquark: redefine charge and name.
5207 KFLQQ=KFDP(MDCY(42,2),1)
5208 KFLQL=KFDP(MDCY(42,2),2)
5209 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5210 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5211 LL=1
5212 IF(IABS(KFLQL).EQ.13) LL=2
5213 IF(IABS(KFLQL).EQ.15) LL=3
5214 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5215 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5216 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5217
5218C...Special cases in treatment of gamma*/Z0: redefine process name.
5219 IF(MSTP(43).EQ.1) THEN
5220 PROC(1)='f + fbar -> gamma*'
5221 PROC(15)='f + fbar -> g + gamma*'
5222 PROC(19)='f + fbar -> gamma + gamma*'
5223 PROC(30)='f + g -> f + gamma*'
5224 PROC(35)='f + gamma -> f + gamma*'
5225 ELSEIF(MSTP(43).EQ.2) THEN
5226 PROC(1)='f + fbar -> Z0'
5227 PROC(15)='f + fbar -> g + Z0'
5228 PROC(19)='f + fbar -> gamma + Z0'
5229 PROC(30)='f + g -> f + Z0'
5230 PROC(35)='f + gamma -> f + Z0'
5231 ELSEIF(MSTP(43).EQ.3) THEN
5232 PROC(1)='f + fbar -> gamma*/Z0'
5233 PROC(15)='f + fbar -> g + gamma*/Z0'
5234 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5235 PROC(30)='f + g -> f + gamma*/Z0'
5236 PROC(35)='f + gamma -> f + gamma*/Z0'
5237 ENDIF
5238
5239C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5240 IF(MSTP(44).EQ.1) THEN
5241 PROC(141)='f + fbar -> gamma*'
5242 ELSEIF(MSTP(44).EQ.2) THEN
5243 PROC(141)='f + fbar -> Z0'
5244 ELSEIF(MSTP(44).EQ.3) THEN
5245 PROC(141)='f + fbar -> Z''0'
5246 ELSEIF(MSTP(44).EQ.4) THEN
5247 PROC(141)='f + fbar -> gamma*/Z0'
5248 ELSEIF(MSTP(44).EQ.5) THEN
5249 PROC(141)='f + fbar -> gamma*/Z''0'
5250 ELSEIF(MSTP(44).EQ.6) THEN
5251 PROC(141)='f + fbar -> Z0/Z''0'
5252 ELSEIF(MSTP(44).EQ.7) THEN
5253 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5254 ENDIF
5255
5256C...Special cases in treatment of WW -> WW: redefine process name.
5257 IF(MSTP(45).EQ.1) THEN
5258 PROC(77)='W+ + W+ -> W+ + W+'
5259 ELSEIF(MSTP(45).EQ.2) THEN
5260 PROC(77)='W+ + W- -> W+ + W-'
5261 ELSEIF(MSTP(45).EQ.3) THEN
5262 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5263 ENDIF
5264
5265C...Format for error information.
5266 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5267 &'combination'/1X,'Execution stopped!')
5268
5269 RETURN
5270 END
5271
5272C*********************************************************************
5273
5274C...PYINBM
5275C...Identifies the two incoming particles and the choice of frame.
5276
5277 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5278
5279C...Double precision and integer declarations.
5280 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5281 IMPLICIT INTEGER(I-N)
5282 INTEGER PYK,PYCHGE,PYCOMP
5283
5284C...User process initialization commonblock.
5285 INTEGER MAXPUP
5286 PARAMETER (MAXPUP=100)
5287 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5288 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5289 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5290 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5291 &LPRUP(MAXPUP)
5292 SAVE /HEPRUP/
5293
5294C...Commonblocks.
5295 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5296 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5297 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5298 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5299 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5300 COMMON/PYINT1/MINT(400),VINT(400)
5301 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5302
5303C...Local arrays, character variables and data.
5304 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5305 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5306 DIMENSION LEN(3),KCDE(39),PM(2)
5307 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5308 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5309 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5310 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5311 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5312 &'nu_taubar ','pi+ ','pi- ','n0 ',
5313 &'nbar0 ','p+ ','pbar- ','gamma ',
5314 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5315 &'xi- ','xi0 ','omega- ','pi0 ',
5316 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5317 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5318 &'k+ ','k- ','ks0 ','kl0 '/
5319 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5320 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5321 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5322
5323C...Store initial energy. Default frame.
5324 VINT(290)=WIN
5325 MINT(111)=0
5326
5327C...Special user process initialization; convert to normal input.
5328 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5329 MINT(111)=11
5330 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5331 CALL PYNAME(IDBMUP(1),CHNAME)
5332 CHBEAM=CHNAME(1:12)
5333 CALL PYNAME(IDBMUP(2),CHNAME)
5334 CHTARG=CHNAME(1:12)
5335 ENDIF
5336
5337C...Convert character variables to lowercase and find their length.
5338 CHCOM(1)=CHFRAM
5339 CHCOM(2)=CHBEAM
5340 CHCOM(3)=CHTARG
5341 DO 130 I=1,3
5342 LEN(I)=12
5343 DO 110 LL=12,1,-1
5344 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5345 DO 100 LA=1,26
5346 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5347 & CHALP(1)(LA:LA)
5348 100 CONTINUE
5349 110 CONTINUE
5350 CHIDNT(I)=CHCOM(I)
5351
5352C...Fix up bar, underscore and charge in particle name (if needed).
5353 DO 120 LL=1,10
5354 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5355 CHTEMP=CHIDNT(I)
5356 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5357 ENDIF
5358 120 CONTINUE
5359 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5360 CHTEMP=CHIDNT(I)
5361 CHIDNT(I)='nu_'//CHTEMP(3:7)
5362 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5363 CHIDNT(I)(1:3)='n0 '
5364 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5365 CHIDNT(I)(1:5)='nbar0'
5366 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5367 CHIDNT(I)(1:3)='p+ '
5368 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5369 & CHIDNT(I)(1:2).EQ.'p-') THEN
5370 CHIDNT(I)(1:5)='pbar-'
5371 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5372 CHIDNT(I)(7:7)='0'
5373 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5374 CHIDNT(I)(1:7)='reggeon'
5375 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5376 CHIDNT(I)(1:7)='pomeron'
5377 ENDIF
5378 130 CONTINUE
5379
5380C...Identify free initialization.
5381 IF(CHCOM(1)(1:2).EQ.'no') THEN
5382 MINT(65)=1
5383 RETURN
5384 ENDIF
5385
5386C...Identify incoming beam and target particles.
5387 DO 160 I=1,2
5388 DO 140 J=1,39
5389 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5390 140 CONTINUE
5391 PM(I)=PYMASS(MINT(10+I))
5392 VINT(2+I)=PM(I)
5393 MINT(140+I)=0
5394 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5395 CHTEMP=CHIDNT(I+1)(7:12)//' '
5396 DO 150 J=1,12
5397 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5398 150 CONTINUE
5399 PM(I)=PYMASS(MINT(140+I))
5400 VINT(302+I)=PM(I)
5401 ENDIF
5402 160 CONTINUE
5403 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5404 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5405 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5406
5407C...Identify choice of frame and input energies.
5408 CHINIT=' '
5409
5410C...Events defined in the CM frame.
5411 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5412 MINT(111)=1
5413 S=WIN**2
5414 IF(MSTP(122).GE.1) THEN
5415 IF(CHCOM(2)(1:1).NE.'e') THEN
5416 LOFFS=(31-(LEN(2)+LEN(3)))/2
5417 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5418 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5419 & ' collider'//' '
5420 ELSE
5421 LOFFS=(30-(LEN(2)+LEN(3)))/2
5422 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5423 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5424 & ' collider'//' '
5425 ENDIF
5426 WRITE(MSTU(11),5200) CHINIT
5427 WRITE(MSTU(11),5300) WIN
5428 ENDIF
5429
5430C...Events defined in fixed target frame.
5431 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5432 MINT(111)=2
5433 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5434 IF(MSTP(122).GE.1) THEN
5435 LOFFS=(29-(LEN(2)+LEN(3)))/2
5436 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5437 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5438 & ' fixed target'//' '
5439 WRITE(MSTU(11),5200) CHINIT
5440 WRITE(MSTU(11),5400) WIN
5441 WRITE(MSTU(11),5500) SQRT(S)
5442 ENDIF
5443
5444C...Frame defined by user three-vectors.
5445 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5446 MINT(111)=3
5447 P(1,5)=PM(1)
5448 P(2,5)=PM(2)
5449 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5450 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5451 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5452 & (P(1,3)+P(2,3))**2
5453 IF(MSTP(122).GE.1) THEN
5454 LOFFS=(22-(LEN(2)+LEN(3)))/2
5455 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5456 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5457 & ' user configuration'//' '
5458 WRITE(MSTU(11),5200) CHINIT
5459 WRITE(MSTU(11),5600)
5460 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5461 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5462 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5463 ENDIF
5464
5465C...Frame defined by user four-vectors.
5466 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5467 MINT(111)=4
5468 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5469 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5470 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5471 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5472 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5473 & (P(1,3)+P(2,3))**2
5474 IF(MSTP(122).GE.1) THEN
5475 LOFFS=(22-(LEN(2)+LEN(3)))/2
5476 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5477 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5478 & ' user configuration'//' '
5479 WRITE(MSTU(11),5200) CHINIT
5480 WRITE(MSTU(11),5600)
5481 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5482 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5483 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5484 ENDIF
5485
5486C...Frame defined by user five-vectors.
5487 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5488 MINT(111)=5
5489 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5490 & (P(1,3)+P(2,3))**2
5491 IF(MSTP(122).GE.1) THEN
5492 LOFFS=(22-(LEN(2)+LEN(3)))/2
5493 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5494 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5495 & ' user configuration'//' '
5496 WRITE(MSTU(11),5200) CHINIT
5497 WRITE(MSTU(11),5600)
5498 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5499 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5500 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5501 ENDIF
5502
5503C...Frame defined by HEPRUP common block.
5504 ELSEIF(MINT(111).GE.11) THEN
5505 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5506 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5507 IF(MSTP(122).GE.1) THEN
5508 LOFFS=(22-(LEN(2)+LEN(3)))/2
5509 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5510 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5511 & ' user configuration'//' '
5512 WRITE(MSTU(11),5200) CHINIT
5513 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5514 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5515 ENDIF
5516
5517C...Unknown frame. Error for too low CM energy.
5518 ELSE
5519 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5520 CALL PYSTOP(7)
5521 ENDIF
5522 IF(S.LT.PARP(2)**2) THEN
5523 WRITE(MSTU(11),5900) SQRT(S)
5524 CALL PYSTOP(7)
5525 ENDIF
5526
5527C...Formats for initialization and error information.
5528 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5529 &1X,'Execution stopped!')
5530 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5531 &1X,'Execution stopped!')
5532 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5533 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5534 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5535 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5536 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5537 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5538 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5539 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5540 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5541 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5542 &1X,'Execution stopped!')
5543 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5544 &'generation.'/1X,'Execution stopped!')
5545 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5546 &'GeV beam energies',13X,'I')
5547
5548 RETURN
5549 END
5550
5551C*********************************************************************
5552
5553C...PYINKI
5554C...Sets up kinematics, including rotations and boosts to/from CM frame.
5555
5556 SUBROUTINE PYINKI(MODKI)
5557
5558C...Double precision and integer declarations.
5559 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5560 IMPLICIT INTEGER(I-N)
5561 INTEGER PYK,PYCHGE,PYCOMP
5562
5563C...User process initialization commonblock.
5564 INTEGER MAXPUP
5565 PARAMETER (MAXPUP=100)
5566 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5567 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5568 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5569 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5570 &LPRUP(MAXPUP)
5571 SAVE /HEPRUP/
5572
5573C...Commonblocks.
5574 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5576 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5577 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5578 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5579 COMMON/PYINT1/MINT(400),VINT(400)
5580 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5581
5582C...Set initial flavour state.
5583 N=2
5584 DO 100 I=1,2
5585 K(I,1)=1
5586 K(I,2)=MINT(10+I)
5587 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5588 100 CONTINUE
5589
5590C...Reset boost. Do kinematics for various cases.
5591 DO 110 J=6,10
5592 VINT(J)=0D0
5593 110 CONTINUE
5594
5595C...Set up kinematics for events defined in CM frame.
5596 IF(MINT(111).EQ.1) THEN
5597 WIN=VINT(290)
5598 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5599 S=WIN**2
5600 P(1,5)=VINT(3)
5601 P(2,5)=VINT(4)
5602 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5603 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5604 P(1,1)=0D0
5605 P(1,2)=0D0
5606 P(2,1)=0D0
5607 P(2,2)=0D0
5608 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5609 & (4D0*S))
5610 P(2,3)=-P(1,3)
5611 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5612 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5613
5614C...Set up kinematics for fixed target events.
5615 ELSEIF(MINT(111).EQ.2) THEN
5616 WIN=VINT(290)
5617 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5618 P(1,5)=VINT(3)
5619 P(2,5)=VINT(4)
5620 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5621 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5622 P(1,1)=0D0
5623 P(1,2)=0D0
5624 P(2,1)=0D0
5625 P(2,2)=0D0
5626 P(1,3)=WIN
5627 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5628 P(2,3)=0D0
5629 P(2,4)=P(2,5)
5630 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5631 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5632 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5633
5634C...Set up kinematics for events in user-defined frame.
5635 ELSEIF(MINT(111).EQ.3) THEN
5636 P(1,5)=VINT(3)
5637 P(2,5)=VINT(4)
5638 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5639 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5640 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5641 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5642 DO 120 J=1,3
5643 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5644 120 CONTINUE
5645 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5646 VINT(7)=PYANGL(P(1,1),P(1,2))
5647 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5648 VINT(6)=PYANGL(P(1,3),P(1,1))
5649 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5650 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5651
5652C...Set up kinematics for events with user-defined four-vectors.
5653 ELSEIF(MINT(111).EQ.4) THEN
5654 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5655 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5656 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5657 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5658 DO 130 J=1,3
5659 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5660 130 CONTINUE
5661 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5662 VINT(7)=PYANGL(P(1,1),P(1,2))
5663 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5664 VINT(6)=PYANGL(P(1,3),P(1,1))
5665 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5666 S=(P(1,4)+P(2,4))**2
5667
5668C...Set up kinematics for events with user-defined five-vectors.
5669 ELSEIF(MINT(111).EQ.5) THEN
5670 DO 140 J=1,3
5671 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5672 140 CONTINUE
5673 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5674 VINT(7)=PYANGL(P(1,1),P(1,2))
5675 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5676 VINT(6)=PYANGL(P(1,3),P(1,1))
5677 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5678 S=(P(1,4)+P(2,4))**2
5679
5680C...Set up kinematics for events with external user processes.
5681 ELSEIF(MINT(111).GE.11) THEN
5682 P(1,5)=VINT(3)
5683 P(2,5)=VINT(4)
5684 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5685 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5686 P(1,1)=0D0
5687 P(1,2)=0D0
5688 P(2,1)=0D0
5689 P(2,2)=0D0
5690 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5691 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5692 P(1,4)=EBMUP(1)
5693 P(2,4)=EBMUP(2)
5694 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5695 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5696 S=(P(1,4)+P(2,4))**2
5697 ENDIF
5698
5699C...Return or error for too low CM energy.
5700 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5701 IF(MSTP(172).LE.1) THEN
5702 CALL PYERRM(23,
5703 & '(PYINKI:) too low invariant mass in this event')
5704 ELSE
5705 MSTI(61)=1
5706 RETURN
5707 ENDIF
5708 ENDIF
5709
5710C...Save information on incoming particles.
5711 VINT(1)=SQRT(S)
5712 VINT(2)=S
5713 IF(MINT(111).GE.4) THEN
5714 IF(MINT(141).EQ.0) THEN
5715 VINT(3)=P(1,5)
5716 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5717 ELSE
5718 VINT(303)=P(1,5)
5719 ENDIF
5720 IF(MINT(142).EQ.0) THEN
5721 VINT(4)=P(2,5)
5722 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5723 ELSE
5724 VINT(304)=P(2,5)
5725 ENDIF
5726 ENDIF
5727 VINT(5)=P(1,3)
5728 IF(MODKI.EQ.0) VINT(289)=S
5729 DO 150 J=1,5
5730 V(1,J)=0D0
5731 V(2,J)=0D0
5732 VINT(290+J)=P(1,J)
5733 VINT(295+J)=P(2,J)
5734 150 CONTINUE
5735
5736C...Store pT cut-off and related constants to be used in generation.
5737 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5738 IF(MSTP(82).LE.1) THEN
5739 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5740 ELSE
5741 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5742 ENDIF
5743 VINT(149)=4D0*PTMN**2/S
5744 VINT(154)=PTMN
5745
5746 RETURN
5747 END
5748
5749C*********************************************************************
5750
5751C...PYINPR
5752C...Selects partonic subprocesses to be included in the simulation.
5753
5754 SUBROUTINE PYINPR
5755
5756C...Double precision and integer declarations.
5757 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5758 IMPLICIT INTEGER(I-N)
5759 INTEGER PYK,PYCHGE,PYCOMP
5760
5761C...User process initialization commonblock.
5762 INTEGER MAXPUP
5763 PARAMETER (MAXPUP=100)
5764 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5765 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5766 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5767 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5768 &LPRUP(MAXPUP)
5769 SAVE /HEPRUP/
5770
5771C...Commonblocks and character variables.
5772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5773 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5774 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5775 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5776 COMMON/PYINT1/MINT(400),VINT(400)
5777 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5778 COMMON/PYINT6/PROC(0:500)
5779 CHARACTER PROC*28
5780 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5781 &/PYINT6/
5782 CHARACTER CHIPR*10
5783
5784C...Reset processes to be included.
5785 IF(MSEL.NE.0) THEN
5786 DO 100 I=1,500
5787 MSUB(I)=0
5788 100 CONTINUE
5789 ENDIF
5790
5791C...Set running pTmin scale.
5792 IF(MSTP(82).LE.1) THEN
5793 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5794 ELSE
5795 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5796 ENDIF
5797
5798C...Begin by assuming incoming photon to enter subprocess.
5799 IF(MINT(11).EQ.22) MINT(15)=22
5800 IF(MINT(12).EQ.22) MINT(16)=22
5801
5802C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5803 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5804 MSUB(10)=1
5805 MINT(123)=MINT(122)+1
5806
5807C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5808C...allow mixture.
5809C...Here also set a few parameters otherwise normally not touched.
5810 ELSEIF(MINT(121).GT.1) THEN
5811
5812C...Parton distributions dampened at small Q2; go to low energies,
5813C...alpha_s <1; no minimum pT cut-off a priori.
5814 IF(MSTP(18).EQ.2) THEN
5815 MSTP(57)=3
5816 PARP(2)=2D0
5817 PARU(115)=1D0
5818 CKIN(5)=0.2D0
5819 CKIN(6)=0.2D0
5820 ENDIF
5821
5822C...Define pT cut-off parameters and whether run involves low-pT.
5823 PTMVMD=PTMRUN
5824 VINT(154)=PTMVMD
5825 PTMDIR=PTMVMD
5826 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5827 PTMANO=PTMVMD
5828 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5829 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5830 IPTL=1
5831 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5832 IF(MSEL.EQ.2) IPTL=1
5833
5834C...Set up for p/gamma * gamma; real or virtual photons.
5835 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5836 & MSTP(14).EQ.30)) THEN
5837
5838C...Set up for p/VMD * VMD.
5839 IF(MINT(122).EQ.1) THEN
5840 MINT(123)=2
5841 MSUB(11)=1
5842 MSUB(12)=1
5843 MSUB(13)=1
5844 MSUB(28)=1
5845 MSUB(53)=1
5846 MSUB(68)=1
5847 IF(IPTL.EQ.1) MSUB(95)=1
5848 IF(MSEL.EQ.2) THEN
5849 MSUB(91)=1
5850 MSUB(92)=1
5851 MSUB(93)=1
5852 MSUB(94)=1
5853 ENDIF
5854 IF(IPTL.EQ.1) CKIN(3)=0D0
5855
5856C...Set up for p/VMD * direct gamma.
5857 ELSEIF(MINT(122).EQ.2) THEN
5858 MINT(123)=0
5859 IF(MINT(121).EQ.6) MINT(123)=5
5860 MSUB(131)=1
5861 MSUB(132)=1
5862 MSUB(135)=1
5863 MSUB(136)=1
5864 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5865
5866C...Set up for p/VMD * anomalous gamma.
5867 ELSEIF(MINT(122).EQ.3) THEN
5868 MINT(123)=3
5869 IF(MINT(121).EQ.6) MINT(123)=7
5870 MSUB(11)=1
5871 MSUB(12)=1
5872 MSUB(13)=1
5873 MSUB(28)=1
5874 MSUB(53)=1
5875 MSUB(68)=1
5876 IF(IPTL.EQ.1) MSUB(95)=1
5877 IF(MSEL.EQ.2) THEN
5878 MSUB(91)=1
5879 MSUB(92)=1
5880 MSUB(93)=1
5881 MSUB(94)=1
5882 ENDIF
5883 IF(IPTL.EQ.1) CKIN(3)=0D0
5884
5885C...Set up for DIS * p.
5886 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5887 & IABS(MINT(12)).GT.100)) THEN
5888 MINT(123)=8
5889 IF(IPTL.EQ.1) MSUB(99)=1
5890
5891C...Set up for direct * direct gamma (switch off leptons).
5892 ELSEIF(MINT(122).EQ.4) THEN
5893 MINT(123)=0
5894 MSUB(137)=1
5895 MSUB(138)=1
5896 MSUB(139)=1
5897 MSUB(140)=1
5898 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5899 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5900 110 CONTINUE
5901 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5902
5903C...Set up for direct * anomalous gamma.
5904 ELSEIF(MINT(122).EQ.5) THEN
5905 MINT(123)=6
5906 MSUB(131)=1
5907 MSUB(132)=1
5908 MSUB(135)=1
5909 MSUB(136)=1
5910 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5911
5912C...Set up for anomalous * anomalous gamma.
5913 ELSEIF(MINT(122).EQ.6) THEN
5914 MINT(123)=3
5915 MSUB(11)=1
5916 MSUB(12)=1
5917 MSUB(13)=1
5918 MSUB(28)=1
5919 MSUB(53)=1
5920 MSUB(68)=1
5921 IF(IPTL.EQ.1) MSUB(95)=1
5922 IF(MSEL.EQ.2) THEN
5923 MSUB(91)=1
5924 MSUB(92)=1
5925 MSUB(93)=1
5926 MSUB(94)=1
5927 ENDIF
5928 IF(IPTL.EQ.1) CKIN(3)=0D0
5929 ENDIF
5930
5931C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5932 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5933
5934C...Set up for direct * direct gamma (switch off leptons).
5935 IF(MINT(122).EQ.1) THEN
5936 MINT(123)=0
5937 MSUB(137)=1
5938 MSUB(138)=1
5939 MSUB(139)=1
5940 MSUB(140)=1
5941 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5942 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5943 120 CONTINUE
5944 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5945
5946C...Set up for direct * VMD and VMD * direct gamma.
5947 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5948 MINT(123)=5
5949 MSUB(131)=1
5950 MSUB(132)=1
5951 MSUB(135)=1
5952 MSUB(136)=1
5953 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5954
5955C...Set up for direct * anomalous and anomalous * direct gamma.
5956 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5957 MINT(123)=6
5958 MSUB(131)=1
5959 MSUB(132)=1
5960 MSUB(135)=1
5961 MSUB(136)=1
5962 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5963
5964C...Set up for VMD*VMD.
5965 ELSEIF(MINT(122).EQ.5) THEN
5966 MINT(123)=2
5967 MSUB(11)=1
5968 MSUB(12)=1
5969 MSUB(13)=1
5970 MSUB(28)=1
5971 MSUB(53)=1
5972 MSUB(68)=1
5973 IF(IPTL.EQ.1) MSUB(95)=1
5974 IF(MSEL.EQ.2) THEN
5975 MSUB(91)=1
5976 MSUB(92)=1
5977 MSUB(93)=1
5978 MSUB(94)=1
5979 ENDIF
5980 IF(IPTL.EQ.1) CKIN(3)=0D0
5981
5982C...Set up for VMD * anomalous and anomalous * VMD gamma.
5983 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5984 MINT(123)=7
5985 MSUB(11)=1
5986 MSUB(12)=1
5987 MSUB(13)=1
5988 MSUB(28)=1
5989 MSUB(53)=1
5990 MSUB(68)=1
5991 IF(IPTL.EQ.1) MSUB(95)=1
5992 IF(MSEL.EQ.2) THEN
5993 MSUB(91)=1
5994 MSUB(92)=1
5995 MSUB(93)=1
5996 MSUB(94)=1
5997 ENDIF
5998 IF(IPTL.EQ.1) CKIN(3)=0D0
5999
6000C...Set up for anomalous * anomalous gamma.
6001 ELSEIF(MINT(122).EQ.9) THEN
6002 MINT(123)=3
6003 MSUB(11)=1
6004 MSUB(12)=1
6005 MSUB(13)=1
6006 MSUB(28)=1
6007 MSUB(53)=1
6008 MSUB(68)=1
6009 IF(IPTL.EQ.1) MSUB(95)=1
6010 IF(MSEL.EQ.2) THEN
6011 MSUB(91)=1
6012 MSUB(92)=1
6013 MSUB(93)=1
6014 MSUB(94)=1
6015 ENDIF
6016 IF(IPTL.EQ.1) CKIN(3)=0D0
6017
6018C...Set up for DIS * VMD and VMD * DIS gamma.
6019 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6020 MINT(123)=8
6021 IF(IPTL.EQ.1) MSUB(99)=1
6022
6023C...Set up for DIS * anomalous and anomalous * DIS gamma.
6024 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6025 MINT(123)=9
6026 IF(IPTL.EQ.1) MSUB(99)=1
6027 ENDIF
6028
6029C...Set up for gamma* * p; virtual photons = dir, res.
6030 ELSEIF(MINT(121).EQ.2) THEN
6031
6032C...Set up for direct * p.
6033 IF(MINT(122).EQ.1) THEN
6034 MINT(123)=0
6035 MSUB(131)=1
6036 MSUB(132)=1
6037 MSUB(135)=1
6038 MSUB(136)=1
6039 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6040
6041C...Set up for resolved * p.
6042 ELSEIF(MINT(122).EQ.2) THEN
6043 MINT(123)=1
6044 MSUB(11)=1
6045 MSUB(12)=1
6046 MSUB(13)=1
6047 MSUB(28)=1
6048 MSUB(53)=1
6049 MSUB(68)=1
6050 IF(IPTL.EQ.1) MSUB(95)=1
6051 IF(MSEL.EQ.2) THEN
6052 MSUB(91)=1
6053 MSUB(92)=1
6054 MSUB(93)=1
6055 MSUB(94)=1
6056 ENDIF
6057 IF(IPTL.EQ.1) CKIN(3)=0D0
6058 ENDIF
6059
6060C...Set up for gamma* * gamma*; virtual photons = dir, res.
6061 ELSEIF(MINT(121).EQ.4) THEN
6062
6063C...Set up for direct * direct gamma (switch off leptons).
6064 IF(MINT(122).EQ.1) THEN
6065 MINT(123)=0
6066 MSUB(137)=1
6067 MSUB(138)=1
6068 MSUB(139)=1
6069 MSUB(140)=1
6070 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6071 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6072 130 CONTINUE
6073 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6074
6075C...Set up for direct * resolved and resolved * direct gamma.
6076 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6077 MINT(123)=5
6078 MSUB(131)=1
6079 MSUB(132)=1
6080 MSUB(135)=1
6081 MSUB(136)=1
6082 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6083
6084C...Set up for resolved * resolved gamma.
6085 ELSEIF(MINT(122).EQ.4) THEN
6086 MINT(123)=2
6087 MSUB(11)=1
6088 MSUB(12)=1
6089 MSUB(13)=1
6090 MSUB(28)=1
6091 MSUB(53)=1
6092 MSUB(68)=1
6093 IF(IPTL.EQ.1) MSUB(95)=1
6094 IF(MSEL.EQ.2) THEN
6095 MSUB(91)=1
6096 MSUB(92)=1
6097 MSUB(93)=1
6098 MSUB(94)=1
6099 ENDIF
6100 IF(IPTL.EQ.1) CKIN(3)=0D0
6101 ENDIF
6102
6103C...End of special set up for gamma-p and gamma-gamma.
6104 ENDIF
6105 CKIN(1)=2D0*CKIN(3)
6106 ENDIF
6107
6108C...Flavour information for individual beams.
6109 DO 140 I=1,2
6110 MINT(40+I)=1
6111 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6112 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6113 MINT(44+I)=MINT(40+I)
6114 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6115 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6116 140 CONTINUE
6117
6118C...If two real gammas, whereof one direct, pick the first.
6119C...For two virtual photons, keep requested order.
6120 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6121 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6122 MINT(41)=1
6123 MINT(45)=1
6124 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6125 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6126 MINT(41)=1
6127 MINT(45)=1
6128 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6129 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6130 MINT(42)=1
6131 MINT(46)=1
6132 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6133 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6134 MINT(41)=1
6135 MINT(45)=1
6136 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6137 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6138 MINT(42)=1
6139 MINT(46)=1
6140 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6141 MINT(41)=1
6142 MINT(45)=1
6143 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6144 MINT(42)=1
6145 MINT(46)=1
6146 ENDIF
6147 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6148 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6149 IF(MINT(11).EQ.22) THEN
6150 MINT(41)=1
6151 MINT(45)=1
6152 ELSE
6153 MINT(42)=1
6154 MINT(46)=1
6155 ENDIF
6156 ENDIF
6157 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6158 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6159 ENDIF
6160
6161C...Flavour information on combination of incoming particles.
6162 MINT(43)=2*MINT(41)+MINT(42)-2
6163 MINT(44)=MINT(43)
6164 IF(MINT(123).LE.0) THEN
6165 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6166 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6167 ELSEIF(MINT(123).LE.3) THEN
6168 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6169 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6170 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6171 MINT(43)=4
6172 MINT(44)=1
6173 ENDIF
6174 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6175 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6176 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6177 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6178 MINT(50)=0
6179 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6180 MINT(107)=0
6181 MINT(108)=0
6182 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6183 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6184 & MINT(107)=2
6185 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6186 & MINT(107)=3
6187 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6188 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6189 & MINT(122).EQ.10) MINT(108)=2
6190 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6191 & MINT(122).EQ.11) MINT(108)=3
6192 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6193 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6194 IF(MINT(122).GE.3) MINT(107)=1
6195 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6196 ELSEIF(MINT(121).EQ.2) THEN
6197 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6198 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6199 ELSE
6200 IF(MINT(11).EQ.22) THEN
6201 MINT(107)=MINT(123)
6202 IF(MINT(123).GE.4) MINT(107)=0
6203 IF(MINT(123).EQ.7) MINT(107)=2
6204 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6205 IF(MSTP(14).EQ.28) MINT(107)=2
6206 IF(MSTP(14).EQ.29) MINT(107)=3
6207 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6208 & MINT(107)=4
6209 ENDIF
6210 IF(MINT(12).EQ.22) THEN
6211 MINT(108)=MINT(123)
6212 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6213 IF(MINT(123).EQ.7) MINT(108)=3
6214 IF(MSTP(14).EQ.26) MINT(108)=2
6215 IF(MSTP(14).EQ.27) MINT(108)=3
6216 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6217 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6218 & MINT(108)=4
6219 ENDIF
6220 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6221 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6222 MINTTP=MINT(107)
6223 MINT(107)=MINT(108)
6224 MINT(108)=MINTTP
6225 ENDIF
6226 ENDIF
6227 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6228 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6229
6230C...Select default processes according to incoming beams
6231C...(already done for gamma-p and gamma-gamma with
6232C...MSTP(14) = 10, 20, 25 or 30).
6233 IF(MINT(121).GT.1) THEN
6234 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6235
6236 IF(MINT(43).EQ.1) THEN
6237C...Lepton + lepton -> gamma/Z0 or W.
6238 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6239 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6240
6241 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6242 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6243C...Unresolved photon + lepton: Compton scattering.
6244 MSUB(133)=1
6245 MSUB(134)=1
6246
6247 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6248 & .OR.MINT(12).EQ.22)) THEN
6249C...DIS as pure gamma* + f -> f process.
6250 MSUB(99)=1
6251
6252 ELSEIF(MINT(43).LE.3) THEN
6253C...Lepton + hadron: deep inelastic scattering.
6254 MSUB(10)=1
6255
6256 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6257 & MINT(12).EQ.22) THEN
6258C...Two unresolved photons: fermion pair production,
6259C...exclude lepton pairs.
6260 DO 150 ISUB=137,140
6261 MSUB(ISUB)=1
6262 150 CONTINUE
6263 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6264 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6265 160 CONTINUE
6266 PTMDIR=PTMRUN
6267 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6268 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6269 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6270
6271 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6272 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6273 & MINT(12).EQ.22)) THEN
6274C...Unresolved photon + hadron: photon-parton scattering.
6275 DO 170 ISUB=131,136
6276 MSUB(ISUB)=1
6277 170 CONTINUE
6278
6279 ELSEIF(MSEL.EQ.1) THEN
6280C...High-pT QCD processes:
6281 MSUB(11)=1
6282 MSUB(12)=1
6283 MSUB(13)=1
6284 MSUB(28)=1
6285 MSUB(53)=1
6286 MSUB(68)=1
6287 PTMN=PTMRUN
6288 VINT(154)=PTMN
6289 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6290 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6291
6292 ELSE
6293C...All QCD processes:
6294 MSUB(11)=1
6295 MSUB(12)=1
6296 MSUB(13)=1
6297 MSUB(28)=1
6298 MSUB(53)=1
6299 MSUB(68)=1
6300 MSUB(91)=1
6301 MSUB(92)=1
6302 MSUB(93)=1
6303 MSUB(94)=1
6304 MSUB(95)=1
6305 ENDIF
6306
6307 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6308C...Heavy quark production.
6309 MSUB(81)=1
6310 MSUB(82)=1
6311 MSUB(84)=1
6312 DO 180 J=1,MIN(8,MDCY(21,3))
6313 MDME(MDCY(21,2)+J-1,1)=0
6314 180 CONTINUE
6315 MDME(MDCY(21,2)+MSEL-1,1)=1
6316 MSUB(85)=1
6317 DO 190 J=1,MIN(12,MDCY(22,3))
6318 MDME(MDCY(22,2)+J-1,1)=0
6319 190 CONTINUE
6320 MDME(MDCY(22,2)+MSEL-1,1)=1
6321
6322 ELSEIF(MSEL.EQ.10) THEN
6323C...Prompt photon production:
6324 MSUB(14)=1
6325 MSUB(18)=1
6326 MSUB(29)=1
6327
6328 ELSEIF(MSEL.EQ.11) THEN
6329C...Z0/gamma* production:
6330 MSUB(1)=1
6331
6332 ELSEIF(MSEL.EQ.12) THEN
6333C...W+/- production:
6334 MSUB(2)=1
6335
6336 ELSEIF(MSEL.EQ.13) THEN
6337C...Z0 + jet:
6338 MSUB(15)=1
6339 MSUB(30)=1
6340
6341 ELSEIF(MSEL.EQ.14) THEN
6342C...W+/- + jet:
6343 MSUB(16)=1
6344 MSUB(31)=1
6345
6346 ELSEIF(MSEL.EQ.15) THEN
6347C...Z0 & W+/- pair production:
6348 MSUB(19)=1
6349 MSUB(20)=1
6350 MSUB(22)=1
6351 MSUB(23)=1
6352 MSUB(25)=1
6353
6354 ELSEIF(MSEL.EQ.16) THEN
6355C...h0 production:
6356 MSUB(3)=1
6357 MSUB(102)=1
6358 MSUB(103)=1
6359 MSUB(123)=1
6360 MSUB(124)=1
6361
6362 ELSEIF(MSEL.EQ.17) THEN
6363C...h0 & Z0 or W+/- pair production:
6364 MSUB(24)=1
6365 MSUB(26)=1
6366
6367 ELSEIF(MSEL.EQ.18) THEN
6368C...h0 production; interesting processes in e+e-.
6369 MSUB(24)=1
6370 MSUB(103)=1
6371 MSUB(123)=1
6372 MSUB(124)=1
6373
6374 ELSEIF(MSEL.EQ.19) THEN
6375C...h0, H0 and A0 production; interesting processes in e+e-.
6376 MSUB(24)=1
6377 MSUB(103)=1
6378 MSUB(123)=1
6379 MSUB(124)=1
6380 MSUB(153)=1
6381 MSUB(171)=1
6382 MSUB(173)=1
6383 MSUB(174)=1
6384 MSUB(158)=1
6385 MSUB(176)=1
6386 MSUB(178)=1
6387 MSUB(179)=1
6388
6389 ELSEIF(MSEL.EQ.21) THEN
6390C...Z'0 production:
6391 MSUB(141)=1
6392
6393 ELSEIF(MSEL.EQ.22) THEN
6394C...W'+/- production:
6395 MSUB(142)=1
6396
6397 ELSEIF(MSEL.EQ.23) THEN
6398C...H+/- production:
6399 MSUB(143)=1
6400
6401 ELSEIF(MSEL.EQ.24) THEN
6402C...R production:
6403 MSUB(144)=1
6404
6405 ELSEIF(MSEL.EQ.25) THEN
6406C...LQ (leptoquark) production.
6407 MSUB(145)=1
6408 MSUB(162)=1
6409 MSUB(163)=1
6410 MSUB(164)=1
6411
6412 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6413C...Production of one heavy quark (W exchange):
6414 MSUB(83)=1
6415 DO 200 J=1,MIN(8,MDCY(21,3))
6416 MDME(MDCY(21,2)+J-1,1)=0
6417 200 CONTINUE
6418 MDME(MDCY(21,2)+MSEL-31,1)=1
6419
6420CMRENNA++Define SUSY alternatives.
6421 ELSEIF(MSEL.EQ.39) THEN
6422C...Turn on all SUSY processes.
6423 IF(MINT(43).EQ.4) THEN
6424C...Hadron-hadron processes.
6425 DO 210 I=201,301
6426 IF(ISET(I).GE.0) MSUB(I)=1
6427 210 CONTINUE
6428 ELSEIF(MINT(43).EQ.1) THEN
6429C...Lepton-lepton processes: QED production of squarks.
6430 DO 220 I=201,214
6431 MSUB(I)=1
6432 220 CONTINUE
6433 MSUB(210)=0
6434 MSUB(211)=0
6435 MSUB(212)=0
6436 DO 230 I=216,228
6437 MSUB(I)=1
6438 230 CONTINUE
6439 DO 240 I=261,263
6440 MSUB(I)=1
6441 240 CONTINUE
6442 MSUB(277)=1
6443 MSUB(278)=1
6444 ENDIF
6445
6446 ELSEIF(MSEL.EQ.40) THEN
6447C...Gluinos and squarks.
6448 IF(MINT(43).EQ.4) THEN
6449 MSUB(243)=1
6450 MSUB(244)=1
6451 MSUB(258)=1
6452 MSUB(259)=1
6453 MSUB(261)=1
6454 MSUB(262)=1
6455 MSUB(264)=1
6456 MSUB(265)=1
6457 DO 250 I=271,296
6458 MSUB(I)=1
6459 250 CONTINUE
6460 ELSEIF(MINT(43).EQ.1) THEN
6461 MSUB(277)=1
6462 MSUB(278)=1
6463 ENDIF
6464
6465 ELSEIF(MSEL.EQ.41) THEN
6466C...Stop production.
6467 MSUB(261)=1
6468 MSUB(262)=1
6469 MSUB(263)=1
6470 IF(MINT(43).EQ.4) THEN
6471 MSUB(264)=1
6472 MSUB(265)=1
6473 ENDIF
6474
6475 ELSEIF(MSEL.EQ.42) THEN
6476C...Slepton production.
6477 DO 260 I=201,214
6478 MSUB(I)=1
6479 260 CONTINUE
6480 IF(MINT(43).NE.4) THEN
6481 MSUB(210)=0
6482 MSUB(211)=0
6483 MSUB(212)=0
6484 ENDIF
6485
6486 ELSEIF(MSEL.EQ.43) THEN
6487C...Neutralino/Chargino + Gluino/Squark.
6488 IF(MINT(43).EQ.4) THEN
6489 DO 270 I=237,242
6490 MSUB(I)=1
6491 270 CONTINUE
6492 DO 280 I=246,254
6493 MSUB(I)=1
6494 280 CONTINUE
6495 MSUB(256)=1
6496 ENDIF
6497
6498 ELSEIF(MSEL.EQ.44) THEN
6499C...Neutralino/Chargino pair production.
6500 IF(MINT(43).EQ.4) THEN
6501 DO 290 I=216,236
6502 MSUB(I)=1
6503 290 CONTINUE
6504 ELSEIF(MINT(43).EQ.1) THEN
6505 DO 300 I=216,228
6506 MSUB(I)=1
6507 300 CONTINUE
6508 ENDIF
6509
6510 ELSEIF(MSEL.EQ.45) THEN
6511C...Sbottom production.
6512 MSUB(287)=1
6513 MSUB(288)=1
6514 IF(MINT(43).EQ.4) THEN
6515 DO 310 I=281,296
6516 MSUB(I)=1
6517 310 CONTINUE
6518 ENDIF
6519
6520 ELSEIF(MSEL.EQ.50) THEN
6521C...Pair production of technipions and gauge bosons.
6522 DO 320 I=361,368
6523 MSUB(I)=1
6524 320 CONTINUE
6525 IF(MINT(43).EQ.4) THEN
6526 DO 330 I=370,377
6527 MSUB(I)=1
6528 330 CONTINUE
6529 ENDIF
6530
6531 ELSEIF(MSEL.EQ.51) THEN
6532C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6533 DO 340 I=381,386
6534 MSUB(I)=1
6535 340 CONTINUE
6536
6537 ELSEIF(MSEL.EQ.61) THEN
6538C...Charmonium production in colour octet model, with recoiling parton.
6539 DO 342 I=421,439
6540 MSUB(I)=1
6541 342 CONTINUE
6542
6543 ELSEIF(MSEL.EQ.62) THEN
6544C...Bottomonium production in colour octet model, with recoiling parton.
6545 DO 344 I=461,479
6546 MSUB(I)=1
6547 344 CONTINUE
6548
6549 ELSEIF(MSEL.EQ.63) THEN
6550C...Charmonium and bottomonium production in colour octet model.
6551 DO 346 I=421,439
6552 MSUB(I)=1
6553 MSUB(I+40)=1
6554 346 CONTINUE
6555 ENDIF
6556
6557C...Find heaviest new quark flavour allowed in processes 81-84.
6558 KFLQM=1
6559 DO 350 I=1,MIN(8,MDCY(21,3))
6560 IDC=I+MDCY(21,2)-1
6561 IF(MDME(IDC,1).LE.0) GOTO 350
6562 KFLQM=I
6563 350 CONTINUE
6564 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6565 &KFLQM=MSTP(7)
6566 MINT(55)=KFLQM
6567 KFPR(81,1)=KFLQM
6568 KFPR(81,2)=KFLQM
6569 KFPR(82,1)=KFLQM
6570 KFPR(82,2)=KFLQM
6571 KFPR(83,1)=KFLQM
6572 KFPR(84,1)=KFLQM
6573 KFPR(84,2)=KFLQM
6574
6575C...Find heaviest new fermion flavour allowed in process 85.
6576 KFLFM=1
6577 DO 360 I=1,MIN(12,MDCY(22,3))
6578 IDC=I+MDCY(22,2)-1
6579 IF(MDME(IDC,1).LE.0) GOTO 360
6580 KFLFM=KFDP(IDC,1)
6581 360 CONTINUE
6582 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6583 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6584 MINT(56)=KFLFM
6585 KFPR(85,1)=KFLFM
6586 KFPR(85,2)=KFLFM
6587
6588C...Import relevant information on external user processes.
6589 IF(MINT(111).GE.11) THEN
6590 IPYPR=0
6591 DO 390 IUP=1,NPRUP
6592C...Find next empty PYTHIA process number slot and enable it.
6593 370 IPYPR=IPYPR+1
6594 IF(IPYPR.GT.500) CALL PYERRM(26,
6595 & '(PYINPR.) no more empty slots for user processes')
6596 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6597 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6598 ISET(IPYPR)=11
6599C...Overwrite KFPR with references back to process number and ID.
6600 KFPR(IPYPR,1)=IUP
6601 KFPR(IPYPR,2)=LPRUP(IUP)
6602C...Process title.
6603 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6604 ICHIN=1
6605 DO 380 ICH=1,9
6606 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6607 380 CONTINUE
6608 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6609C...Switch on process.
6610 MSUB(IPYPR)=1
6611 390 CONTINUE
6612 ENDIF
6613
6614 RETURN
6615 END
6616
6617C*********************************************************************
6618
6619C...PYXTOT
6620C...Parametrizes total, elastic and diffractive cross-sections
6621C...for different energies and beams. Donnachie-Landshoff for
6622C...total and Schuler-Sjostrand for elastic and diffractive.
6623C...Process code IPROC:
6624C...= 1 : p + p;
6625C...= 2 : pbar + p;
6626C...= 3 : pi+ + p;
6627C...= 4 : pi- + p;
6628C...= 5 : pi0 + p;
6629C...= 6 : phi + p;
6630C...= 7 : J/psi + p;
6631C...= 11 : rho + rho;
6632C...= 12 : rho + phi;
6633C...= 13 : rho + J/psi;
6634C...= 14 : phi + phi;
6635C...= 15 : phi + J/psi;
6636C...= 16 : J/psi + J/psi;
6637C...= 21 : gamma + p (DL);
6638C...= 22 : gamma + p (VDM).
6639C...= 23 : gamma + pi (DL);
6640C...= 24 : gamma + pi (VDM);
6641C...= 25 : gamma + gamma (DL);
6642C...= 26 : gamma + gamma (VDM).
6643
6644 SUBROUTINE PYXTOT
6645
6646C...Double precision and integer declarations.
6647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6648 IMPLICIT INTEGER(I-N)
6649 INTEGER PYK,PYCHGE,PYCOMP
6650C...Commonblocks.
6651 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6652 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6653 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6654 COMMON/PYINT1/MINT(400),VINT(400)
6655 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6656 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6657 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6658C...Local arrays.
6659 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6660 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6661 &CEFFD(10,9),SIGTMP(6,0:5)
6662
6663C...Common constants.
6664 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6665 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6666 &FACDD/0.0084D0/
6667
6668C...Number of multiple processes to be evaluated (= 0 : undefined).
6669 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6670C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6671 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6672 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6673 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6674 DATA YPAR/
6675 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6676 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6677 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6678
6679C...Beam and target hadron class:
6680C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6681 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6682 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6683C...Characteristic class masses, slope parameters, beta = sqrt(X).
6684 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6685 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6686 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6687
6688C...Fitting constants used in parametrizations of diffractive results.
6689 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6690 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6691 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6692 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6693 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6694 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6695 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6696 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6697 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6698 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6699 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6700 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6701 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6702 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6703 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6704 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6705 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6706 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6707 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6708 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6709 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6710 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6711 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6712 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6713 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6714 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6715 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6716 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6717 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6718
6719C...Parameters. Combinations of the energy.
6720 AEM=PARU(101)
6721 PMTH=PARP(102)
6722 S=VINT(2)
6723 SRT=VINT(1)
6724 SEPS=S**EPS
6725 SETA=S**ETA
6726 SLOG=LOG(S)
6727
6728C...Ratio of gamma/pi (for rescaling in parton distributions).
6729 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6730 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6731 VINT(317)=1D0
6732 IF(MINT(50).NE.1) RETURN
6733
6734C...Order flavours of incoming particles: KF1 < KF2.
6735 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6736 KF1=IABS(MINT(11))
6737 KF2=IABS(MINT(12))
6738 IORD=1
6739 ELSE
6740 KF1=IABS(MINT(12))
6741 KF2=IABS(MINT(11))
6742 IORD=2
6743 ENDIF
6744 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6745
6746C...Find process number (for lookup tables).
6747 IF(KF1.GT.1000) THEN
6748 IPROC=1
6749 IF(ISGN12.LT.0) IPROC=2
6750 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6751 IPROC=3
6752 IF(ISGN12.LT.0) IPROC=4
6753 IF(KF1.EQ.111) IPROC=5
6754 ELSEIF(KF1.GT.100) THEN
6755 IPROC=11
6756 ELSEIF(KF2.GT.1000) THEN
6757 IPROC=21
6758 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6759 ELSEIF(KF2.GT.100) THEN
6760 IPROC=23
6761 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6762 ELSE
6763 IPROC=25
6764 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6765 ENDIF
6766
6767C... Number of multiple processes to be stored; beam/target side.
6768 NPR=NPROC(IPROC)
6769 MINT(101)=1
6770 MINT(102)=1
6771 IF(NPR.EQ.3) THEN
6772 MINT(100+IORD)=4
6773 ELSEIF(NPR.EQ.6) THEN
6774 MINT(101)=4
6775 MINT(102)=4
6776 ENDIF
6777 N1=0
6778 IF(MINT(101).EQ.4) N1=4
6779 N2=0
6780 IF(MINT(102).EQ.4) N2=4
6781
6782C...Do not do any more for user-set or undefined cross-sections.
6783 IF(MSTP(31).LE.0) RETURN
6784 IF(NPR.EQ.0) CALL PYERRM(26,
6785 &'(PYXTOT:) cross section for this process not yet implemented')
6786
6787C...Parameters. Combinations of the energy.
6788 AEM=PARU(101)
6789 PMTH=PARP(102)
6790 S=VINT(2)
6791 SRT=VINT(1)
6792 SEPS=S**EPS
6793 SETA=S**ETA
6794 SLOG=LOG(S)
6795
6796C...Loop over multiple processes (for VDM).
6797 DO 110 I=1,NPR
6798 IF(NPR.EQ.1) THEN
6799 IPR=IPROC
6800 ELSEIF(NPR.EQ.3) THEN
6801 IPR=I+4
6802 IF(KF2.LT.1000) IPR=I+10
6803 ELSEIF(NPR.EQ.6) THEN
6804 IPR=I+10
6805 ENDIF
6806
6807C...Evaluate hadron species, mass, slope contribution and fit number.
6808 IHA=IHADA(IPR)
6809 IHB=IHADB(IPR)
6810 PMA=PMHAD(IHA)
6811 PMB=PMHAD(IHB)
6812 BHA=BHAD(IHA)
6813 BHB=BHAD(IHB)
6814 ISD=IFITSD(IPR)
6815 IDD=IFITDD(IPR)
6816
6817C...Skip if energy too low relative to masses.
6818 DO 100 J=0,5
6819 SIGTMP(I,J)=0D0
6820 100 CONTINUE
6821 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6822
6823C...Total cross-section. Elastic slope parameter and cross-section.
6824 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6825 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6826 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6827
6828C...Diffractive scattering A + B -> X + B.
6829 BSD=2D0*BHB
6830 SQML=(PMA+PMTH)**2
6831 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6832 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6833 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6834 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6835 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6836 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6837 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6838
6839C...Diffractive scattering A + B -> A + X.
6840 BSD=2D0*BHA
6841 SQML=(PMB+PMTH)**2
6842 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6843 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6844 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6845 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6846 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6847 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6848 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6849
6850C...Order single diffractive correctly.
6851 IF(IORD.EQ.2) THEN
6852 SIGSAV=SIGTMP(I,2)
6853 SIGTMP(I,2)=SIGTMP(I,3)
6854 SIGTMP(I,3)=SIGSAV
6855 ENDIF
6856
6857C...Double diffractive scattering A + B -> X1 + X2.
6858 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6859 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6860 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6861 IF(YEFF.LE.0) SUM1=0D0
6862 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6863 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6864 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6865 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6866 & (2D0*ALP)
6867 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6868 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6869 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6870 & (2D0*ALP)
6871 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6872 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6873 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6874 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6875 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6876
6877C...Non-diffractive by unitarity.
6878 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6879 & SIGTMP(I,4)
6880 110 CONTINUE
6881
6882C...Put temporary results in output array: only one process.
6883 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6884 DO 120 J=0,5
6885 SIGT(0,0,J)=SIGTMP(1,J)
6886 120 CONTINUE
6887
6888C...Beam multiple processes.
6889 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6890 IF(MINT(107).EQ.2) THEN
6891 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6892 ELSE
6893 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6894 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6895 ENDIF
6896 IF(MSTP(20).GT.0) THEN
6897 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6898 ENDIF
6899 DO 140 I=1,4
6900 IF(MINT(107).EQ.2) THEN
6901 CONV=(AEM/PARP(160+I))*VINT(317)
6902 ELSEIF(VINT(154).GT.PARP(15)) THEN
6903 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6904 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6905 ELSE
6906 CONV=0D0
6907 ENDIF
6908 I1=MAX(1,I-1)
6909 DO 130 J=0,5
6910 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6911 130 CONTINUE
6912 140 CONTINUE
6913 DO 150 J=0,5
6914 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6915 150 CONTINUE
6916
6917C...Target multiple processes.
6918 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6919 IF(MINT(108).EQ.2) THEN
6920 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6921 ELSE
6922 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6923 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6924 ENDIF
6925 IF(MSTP(20).GT.0) THEN
6926 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6927 ENDIF
6928 DO 170 I=1,4
6929 IF(MINT(108).EQ.2) THEN
6930 CONV=(AEM/PARP(160+I))*VINT(317)
6931 ELSEIF(VINT(154).GT.PARP(15)) THEN
6932 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6933 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6934 ELSE
6935 CONV=0D0
6936 ENDIF
6937 IV=MAX(1,I-1)
6938 DO 160 J=0,5
6939 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6940 160 CONTINUE
6941 170 CONTINUE
6942 DO 180 J=0,5
6943 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6944 180 CONTINUE
6945
6946C...Both beam and target multiple processes.
6947 ELSE
6948 IF(MINT(107).EQ.2) THEN
6949 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6950 ELSE
6951 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6952 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6953 ENDIF
6954 IF(MINT(108).EQ.2) THEN
6955 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6956 ELSE
6957 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6958 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6959 ENDIF
6960 IF(MSTP(20).GT.0) THEN
6961 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6962 & VINT(308)))**MSTP(20)
6963 ENDIF
6964 DO 210 I1=1,4
6965 DO 200 I2=1,4
6966 IF(MINT(107).EQ.2) THEN
6967 CONV=(AEM/PARP(160+I1))*VINT(317)
6968 ELSEIF(VINT(154).GT.PARP(15)) THEN
6969 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6970 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6971 ELSE
6972 CONV=0D0
6973 ENDIF
6974 IF(MINT(108).EQ.2) THEN
6975 CONV=CONV*(AEM/PARP(160+I2))
6976 ELSEIF(VINT(154).GT.PARP(15)) THEN
6977 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6978 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6979 ELSE
6980 CONV=0D0
6981 ENDIF
6982 IF(I1.LE.2) THEN
6983 IV=MAX(1,I2-1)
6984 ELSEIF(I2.LE.2) THEN
6985 IV=MAX(1,I1-1)
6986 ELSEIF(I1.EQ.I2) THEN
6987 IV=2*I1-2
6988 ELSE
6989 IV=5
6990 ENDIF
6991 DO 190 J=0,5
6992 JV=J
6993 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6994 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
6995 190 CONTINUE
6996 200 CONTINUE
6997 210 CONTINUE
6998 DO 230 J=0,5
6999 DO 220 I=1,4
7000 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7001 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7002 220 CONTINUE
7003 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7004 230 CONTINUE
7005 ENDIF
7006
7007C...Scale up uniformly for Donnachie-Landshoff parametrization.
7008 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7009 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7010 DO 260 I1=0,N1
7011 DO 250 I2=0,N2
7012 DO 240 J=0,5
7013 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7014 240 CONTINUE
7015 250 CONTINUE
7016 260 CONTINUE
7017 ENDIF
7018
7019 RETURN
7020 END
7021
7022C*********************************************************************
7023
7024C...PYMAXI
7025C...Finds optimal set of coefficients for kinematical variable selection
7026C...and the maximum of the part of the differential cross-section used
7027C...in the event weighting.
7028
7029 SUBROUTINE PYMAXI
7030
7031C...Double precision and integer declarations.
7032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7033 IMPLICIT INTEGER(I-N)
7034 INTEGER PYK,PYCHGE,PYCOMP
7035C...Parameter statement to help give large particle numbers.
7036 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7037 &KEXCIT=4000000,KDIMEN=5000000)
7038
7039C...User process initialization commonblock.
7040 INTEGER MAXPUP
7041 PARAMETER (MAXPUP=100)
7042 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7043 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7044 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7045 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7046 &LPRUP(MAXPUP)
7047 SAVE /HEPRUP/
7048
7049C...Commonblocks.
7050 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7051 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7052 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7053 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7054 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7055 COMMON/PYINT1/MINT(400),VINT(400)
7056 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7057 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7058 COMMON/PYINT4/MWID(500),WIDS(500,5)
7059 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7060 COMMON/PYINT6/PROC(0:500)
7061 CHARACTER PROC*28
7062 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7063 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7064 COMMON/PYTCCO/COEFX(194:380,2)
7065 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7066 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7067 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7068 &/PYTCSM/,/TCPARA/
7069C...Local arrays, character variables and data.
7070 LOGICAL IOK
7071 CHARACTER CVAR(4)*4
7072 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7073 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7074 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7075 DATA CVAR/'tau ','tau''','y* ','cth '/
7076 DATA SIGSSM/3*0D0/
7077
7078C...Initial values and loop over subprocesses.
7079 NPOSI=0
7080 VINT(143)=1D0
7081 VINT(144)=1D0
7082 XSEC(0,1)=0D0
7083 ITECH=0
7084 DO 460 ISUB=1,500
7085 MINT(1)=ISUB
7086 MINT(51)=0
7087
7088C...Find maximum weight factors for photon flux.
7089 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7090 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7091 ENDIF
7092
7093C...Select subprocess to study: skip cases not applicable.
7094 IF(ISET(ISUB).EQ.11) THEN
7095 IF(MSUB(ISUB).NE.1) GOTO 460
7096C...User process intialization: cross section model dependent.
7097 IF(IABS(IDWTUP).EQ.1) THEN
7098 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7099 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7100 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7101 ELSE
7102 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7103 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7104 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7105 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7106 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7107 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7108 ENDIF
7109 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7110 & WTGAGA*XSEC(ISUB,1)
7111 NPOSI=NPOSI+1
7112 GOTO 450
7113 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7114 CALL PYSIGH(NCHN,SIGS)
7115 XSEC(ISUB,1)=SIGS
7116 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7117 & WTGAGA*XSEC(ISUB,1)
7118 IF(MSUB(ISUB).NE.1) GOTO 460
7119 NPOSI=NPOSI+1
7120 GOTO 450
7121 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7122 CALL PYSIGH(NCHN,SIGS)
7123 XSEC(ISUB,1)=SIGS
7124 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7125 & WTGAGA*XSEC(ISUB,1)
7126 IF(XSEC(ISUB,1).EQ.0D0) THEN
7127 MSUB(ISUB)=0
7128 ELSE
7129 NPOSI=NPOSI+1
7130 ENDIF
7131 GOTO 450
7132 ELSEIF(ISUB.EQ.96) THEN
7133 IF(MINT(50).EQ.0) GOTO 460
7134 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7135 & GOTO 460
7136 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7137 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7138 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7139 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7140 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7141 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7142 ELSE
7143 IF(MSUB(ISUB).NE.1) GOTO 460
7144 ENDIF
7145 ISTSB=ISET(ISUB)
7146 IF(ISUB.EQ.96) ISTSB=2
7147 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7148 MWTXS=0
7149 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7150 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7151
7152C...Find resonances (explicit or implicit in cross-section).
7153 MINT(72)=0
7154 KFR1=0
7155 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7156 KFR1=KFPR(ISUB,1)
7157 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7158 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7159 KFR1=23
7160 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7161 & .OR.ISUB.EQ.177) THEN
7162 KFR1=24
7163 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7164 KFR1=25
7165 IF(MSTP(46).EQ.5) THEN
7166 KFR1=89
7167 PMAS(89,1)=PARP(45)
7168 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7169 ENDIF
7170 ENDIF
7171 CKMX=CKIN(2)
7172 IF(CKMX.LE.0D0) CKMX=VINT(1)
7173 KCR1=PYCOMP(KFR1)
7174 IF(KFR1.NE.0) THEN
7175 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7176 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7177 ENDIF
7178 IF(KFR1.NE.0) THEN
7179 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7180 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7181 MINT(72)=1
7182 MINT(73)=KFR1
7183 VINT(73)=TAUR1
7184 VINT(74)=GAMR1
7185 ENDIF
7186 KFR2=0
7187 KFR3=0
7188 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7189 $ (ISUB.GE.361.AND.ISUB.LE.380))
7190 $ THEN
7191 KFR2=23
7192 IF(ISUB.EQ.141) THEN
7193 KCR2=PYCOMP(KFR2)
7194 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7195 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7196 KFR2=0
7197 ELSE
7198 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7199 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7200 MINT(72)=2
7201 MINT(74)=KFR2
7202 VINT(75)=TAUR2
7203 VINT(76)=GAMR2
7204 ENDIF
7205 ELSEIF(ITECH.EQ.0) THEN
7206 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7207 ITECH=1
7208 KFR1=KTECHN+113
7209 KCR1=PYCOMP(KFR1)
7210 KFR2=KTECHN+223
7211 KCR2=PYCOMP(KFR2)
7212 KFR3=KTECHN+115
7213 KCR3=PYCOMP(KFR3)
7214 IRES=0
7215C...Order the resonances
7216 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7217 KCT=KCR3
7218 KCR3=KCR2
7219 KCR2=KCT
7220 ENDIF
7221 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7222 KCT=KCR3
7223 KCR3=KCR1
7224 KCR1=KCT
7225 ENDIF
7226 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7227 KCT=KCR2
7228 KCR2=KCR1
7229 KCR1=KCT
7230 ENDIF
7231 DO 101 I=1,3
7232 IF(I.EQ.1) THEN
7233 SHN0=PMAS(KCR1,1)**2
7234 ELSEIF(I.EQ.2) THEN
7235 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7236 SHN0=PMAS(KCR2,1)**2
7237 ELSEIF(I.EQ.3) THEN
7238 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7239 SHN0=PMAS(KCR3,1)**2
7240 ENDIF
7241 AEM=PYALEM(SHN0)
7242 FAR=SQRT(AEM/ALPRHT)
7243 SHN=SHN0*(1D0-FAR)
7244 CALL PYTECM(SHN,S1,WIDO,1)
7245 RES=SHN-S1
7246 SHN=S1*.99D0
7247 SHSTEP=2D0
7248 102 SHN=SHN+SHSTEP
7249 CALL PYTECM(SHN,S1,WIDO,1)
7250 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7251 IOK=.FALSE.
7252 IF(IRES.GT.0) THEN
7253 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7254 ELSEIF(IRES.EQ.0) THEN
7255 IOK=.TRUE.
7256 ENDIF
7257 IF(IOK) THEN
7258 IRES=IRES+1
7259 XMAS(IRES)=SQRT(S1)
7260 XWID(IRES)=WIDO
7261 ENDIF
7262 ENDIF
7263 RES=SHN-S1
7264 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7265 101 CONTINUE
7266 JRES=0
7267 KFR1=KTECHN+213
7268 KCR1=PYCOMP(KFR1)
7269 KFR2=KTECHN+215
7270 KCR2=PYCOMP(KFR2)
7271 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7272 KCT=KCR2
7273 KCR2=KCR1
7274 KCR1=KCT
7275 ENDIF
7276 DO 103 I=1,2
7277 IF(I.EQ.1) THEN
7278 SHN0=PMAS(KCR1,1)**2
7279 ELSEIF(I.EQ.2) THEN
7280 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7281 SHN0=PMAS(KCR2,1)**2
7282 ENDIF
7283 AEM=PYALEM(SHN0)
7284 FAR=SQRT(AEM/ALPRHT)
7285 SHN=SHN0*(1D0-FAR)
7286 CALL PYTECM(SHN,S1,WIDO,2)
7287 RES=SHN-S1
7288 SHN=S1*.99D0
7289 SHSTEP=2D0
7290 104 SHN=SHN+SHSTEP
7291 CALL PYTECM(SHN,S1,WIDO,2)
7292 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7293 IOK=.FALSE.
7294 IF(JRES.GT.0) THEN
7295 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7296 ELSEIF(JRES.EQ.0) THEN
7297 IOK=.TRUE.
7298 ENDIF
7299 IF(IOK) THEN
7300 JRES=JRES+1
7301 YMAS(JRES)=SQRT(S1)
7302 YWID(JRES)=WIDO
7303 ENDIF
7304 ENDIF
7305 RES=SHN-S1
7306 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7307 103 CONTINUE
7308 ENDIF
7309 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7310 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7311 MINT(72)=IRES
7312 IF(IRES.GE.1) THEN
7313 VINT(73)=XMAS(1)**2/VINT(2)
7314 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7315 TAUR1=VINT(73)
7316 GAMR1=VINT(74)
7317 XM1=XMAS(1)
7318 XG1=XWID(1)
7319 KFR1=1
7320 ENDIF
7321 IF(IRES.GE.2) THEN
7322 VINT(75)=XMAS(2)**2/VINT(2)
7323 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7324 TAUR2=VINT(75)
7325 GAMR2=VINT(76)
7326 XM2=XMAS(2)
7327 XG2=XWID(2)
7328 KFR2=2
7329 ENDIF
7330 IF(IRES.EQ.3) THEN
7331 VINT(77)=XMAS(3)**2/VINT(2)
7332 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7333 TAUR3=VINT(77)
7334 GAMR3=VINT(78)
7335 XM3=XMAS(3)
7336 XG3=XWID(3)
7337 KFR3=3
7338 ENDIF
7339C...Charged current: rho+- and a+-
7340 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7341 MINT(72)=IRES
7342 IF(JRES.GE.1) THEN
7343 VINT(73)=YMAS(1)**2/VINT(2)
7344 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7345 KFR1=1
7346 TAUR1=VINT(73)
7347 GAMR1=VINT(74)
7348 XM1=YMAS(1)
7349 XG1=YWID(1)
7350 ENDIF
7351 IF(JRES.GE.2) THEN
7352 VINT(75)=YMAS(2)**2/VINT(2)
7353 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7354 KFR2=2
7355 TAUR2=VINT(73)
7356 GAMR2=VINT(74)
7357 XM2=YMAS(2)
7358 XG2=YWID(2)
7359 ENDIF
7360 KFR3=0
7361 ENDIF
7362 IF(ISUB.NE.141) THEN
7363 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7364 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7365 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7366 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7367 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7368 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7369 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7370
7371 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7372 MINT(72)=2
7373 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7374 MINT(72)=2
7375 MINT(74)=KFR3
7376 VINT(75)=TAUR3
7377 VINT(76)=GAMR3
7378 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7379 MINT(72)=2
7380 MINT(73)=KFR2
7381 VINT(73)=TAUR2
7382 VINT(74)=GAMR2
7383 MINT(74)=KFR3
7384 VINT(75)=TAUR3
7385 VINT(76)=GAMR3
7386 ELSEIF(KFR1.NE.0) THEN
7387 MINT(72)=1
7388 ELSEIF(KFR2.NE.0) THEN
7389 MINT(72)=1
7390 MINT(73)=KFR2
7391 VINT(73)=TAUR2
7392 VINT(74)=GAMR2
7393 ELSEIF(KFR3.NE.0) THEN
7394 MINT(72)=1
7395 MINT(73)=KFR3
7396 VINT(73)=TAUR3
7397 VINT(74)=GAMR3
7398 ELSE
7399 MINT(72)=0
7400 ENDIF
7401 ELSE
7402 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7403
7404 ELSEIF(KFR2.NE.0) THEN
7405 KFR1=KFR2
7406 TAUR1=TAUR2
7407 GAMR1=GAMR2
7408 MINT(72)=1
7409 MINT(73)=KFR1
7410 VINT(73)=TAUR1
7411 VINT(74)=GAMR1
7412 KFR2=0
7413 ELSE
7414 MINT(72)=0
7415 ENDIF
7416 ENDIF
7417 ENDIF
7418
7419C...Find product masses and minimum pT of process.
7420 SQM3=0D0
7421 SQM4=0D0
7422 MINT(71)=0
7423 VINT(71)=CKIN(3)
7424 VINT(80)=1D0
7425 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7426 NBW=0
7427 DO 110 I=1,2
7428 PMMN(I)=0D0
7429 IF(KFPR(ISUB,I).EQ.0) THEN
7430 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7431 & PARP(41)) THEN
7432 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7433 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7434 ELSE
7435 NBW=NBW+1
7436C...This prevents SUSY/t particles from becoming too light.
7437 KFLW=KFPR(ISUB,I)
7438 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7439 KCW=PYCOMP(KFLW)
7440 PMMN(I)=PMAS(KCW,1)
7441 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7442 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7443 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7444 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7445 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7446 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7447 PMMN(I)=MIN(PMMN(I),PMSUM)
7448 ENDIF
7449 100 CONTINUE
7450 ELSEIF(KFLW.EQ.6) THEN
7451 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7452 ENDIF
7453 ENDIF
7454 110 CONTINUE
7455 IF(NBW.GE.1) THEN
7456 CKIN41=CKIN(41)
7457 CKIN43=CKIN(43)
7458 CKIN(41)=MAX(PMMN(1),CKIN(41))
7459 CKIN(43)=MAX(PMMN(2),CKIN(43))
7460 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7461 CKIN(41)=CKIN41
7462 CKIN(43)=CKIN43
7463 IF(MINT(51).EQ.1) THEN
7464 WRITE(MSTU(11),5100) ISUB
7465 MSUB(ISUB)=0
7466 GOTO 460
7467 ENDIF
7468 SQM3=PQM3**2
7469 SQM4=PQM4**2
7470 ENDIF
7471 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7472 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7473 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7474 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7475 ELSEIF(ISUB.EQ.96) THEN
7476 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7477 ENDIF
7478 ENDIF
7479 VINT(63)=SQM3
7480 VINT(64)=SQM4
7481
7482C...Prepare for additional variable choices in 2 -> 3.
7483 IF(ISTSB.EQ.5) THEN
7484 VINT(201)=0D0
7485 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7486 VINT(206)=VINT(201)
7487 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7488 VINT(204)=PMAS(23,1)
7489 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7490 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7491 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7492 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7493 & VINT(204)=VINT(201)
7494 VINT(209)=VINT(204)
7495 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7496 ENDIF
7497
7498C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7499 IPEAK7=0
7500 NPTS(1)=2+2*MINT(72)
7501 IF(MINT(47).EQ.1) THEN
7502 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7503 ELSEIF(MINT(47).GE.5) THEN
7504 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7505 NPTS(1)=NPTS(1)+1
7506 IPEAK7=1
7507 ENDIF
7508 ENDIF
7509 NPTS(2)=1
7510 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7511 IF(MINT(47).GE.2) NPTS(2)=2
7512 IF(MINT(47).GE.5) NPTS(2)=3
7513 ENDIF
7514 NPTS(3)=1
7515 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7516 NPTS(3)=3
7517 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7518 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7519 ENDIF
7520 NPTS(4)=1
7521 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7522 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7523
7524C...Reset coefficients of cross-section weighting.
7525 DO 120 J=1,20
7526 COEF(ISUB,J)=0D0
7527 120 CONTINUE
7528 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7529 & .AND.ISUB.LE.380)) THEN
7530 DO 125 J=1,2
7531 COEFX(ISUB,J)=0D0
7532 125 CONTINUE
7533 ENDIF
7534 COEF(ISUB,1)=1D0
7535 COEF(ISUB,8)=0.5D0
7536 COEF(ISUB,9)=0.5D0
7537 COEF(ISUB,13)=1D0
7538 COEF(ISUB,18)=1D0
7539 MCTH=0
7540 MTAUP=0
7541 METAUP=0
7542 VINT(23)=0D0
7543 VINT(26)=0D0
7544 SIGSAM=0D0
7545
7546C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7547C...in grid of phase space points.
7548 CALL PYKLIM(1)
7549 METAU=MINT(51)
7550 NACC=0
7551 DO 150 ITRY=1,NTRY
7552 MINT(51)=0
7553 IF(METAU.EQ.1) GOTO 150
7554 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7555 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7556 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7557 MTAU=7
7558 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7559 MTAU=MTAU+1
7560 ENDIF
7561 RTAU=0.5D0
7562C...Special case when both resonances have same mass,
7563C...as is often the case in process 194.
7564c IF(MINT(72).GE.2) THEN
7565c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7566c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7567c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7568c RTAU=0.4D0
7569c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7570c RTAU=0.6D0
7571c ENDIF
7572c ENDIF
7573c ENDIF
7574 CALL PYKMAP(1,MTAU,RTAU)
7575 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7576 METAUP=MINT(51)
7577 ENDIF
7578 IF(METAUP.EQ.1) GOTO 150
7579 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7580 & .EQ.0) THEN
7581 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7582 CALL PYKMAP(4,MTAUP,0.5D0)
7583 ENDIF
7584 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7585 CALL PYKLIM(2)
7586 MEYST=MINT(51)
7587 ENDIF
7588 IF(MEYST.EQ.1) GOTO 150
7589 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7590 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7591 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7592 CALL PYKMAP(2,MYST,0.5D0)
7593 CALL PYKLIM(3)
7594 MECTH=MINT(51)
7595 ENDIF
7596 IF(MECTH.EQ.1) GOTO 150
7597 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7598 MCTH=1+MOD(ITRY-1,NPTS(4))
7599 CALL PYKMAP(3,MCTH,0.5D0)
7600 ENDIF
7601 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7602
7603C...Store position and limits.
7604 MINT(51)=0
7605 CALL PYKLIM(0)
7606 IF(MINT(51).EQ.1) GOTO 150
7607 NACC=NACC+1
7608 MVARPT(NACC,1)=MTAU
7609 MVARPT(NACC,2)=MTAUP
7610 MVARPT(NACC,3)=MYST
7611 MVARPT(NACC,4)=MCTH
7612 DO 130 J=1,30
7613 VINTPT(NACC,J)=VINT(10+J)
7614 130 CONTINUE
7615
7616C...Normal case: calculate cross-section.
7617 IF(ISTSB.NE.5) THEN
7618 CALL PYSIGH(NCHN,SIGS)
7619 IF(MWTXS.EQ.1) THEN
7620 CALL PYEVWT(WTXS)
7621 SIGS=WTXS*SIGS
7622 ENDIF
7623
7624C..2 -> 3: find highest value out of a number of tries.
7625 ELSE
7626 SIGS=0D0
7627 DO 140 IKIN3=1,MSTP(129)
7628 CALL PYKMAP(5,0,0D0)
7629 IF(MINT(51).EQ.1) GOTO 140
7630 CALL PYSIGH(NCHN,SIGTMP)
7631 IF(MWTXS.EQ.1) THEN
7632 CALL PYEVWT(WTXS)
7633 SIGTMP=WTXS*SIGTMP
7634 ENDIF
7635 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7636 140 CONTINUE
7637 ENDIF
7638
7639C...Store cross-section.
7640 SIGSPT(NACC)=SIGS
7641 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7642 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7643 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7644 150 CONTINUE
7645 IF(NACC.EQ.0) THEN
7646 WRITE(MSTU(11),5100) ISUB
7647 MSUB(ISUB)=0
7648 GOTO 460
7649 ELSEIF(SIGSAM.EQ.0D0) THEN
7650 WRITE(MSTU(11),5300) ISUB
7651 MSUB(ISUB)=0
7652 GOTO 460
7653 ENDIF
7654 IF(ISUB.NE.96) NPOSI=NPOSI+1
7655
7656C...Calculate integrals in tau over maximal phase space limits.
7657 TAUMIN=VINT(11)
7658 TAUMAX=VINT(31)
7659 ATAU1=LOG(TAUMAX/TAUMIN)
7660 IF(NPTS(1).GE.2) THEN
7661 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7662 ENDIF
7663 IF(NPTS(1).GE.4) THEN
7664 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7665 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7666 & GAMR1
7667 ENDIF
7668 IF(NPTS(1).GE.6) THEN
7669 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7670 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7671 & GAMR2
7672 ENDIF
7673 IF(NPTS(1).GE.8) THEN
7674 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7675 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7676 & GAMR3
7677 ENDIF
7678 IF(IPEAK7.EQ.1) THEN
7679 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7680 ENDIF
7681
7682C...Reset. Sum up cross-sections in points calculated.
7683 DO 320 IVAR=1,4
7684 IF(NPTS(IVAR).EQ.1) GOTO 320
7685 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7686 NBIN=NPTS(IVAR)
7687 DO 170 J1=1,NBIN
7688 NAREL(J1)=0
7689 WTREL(J1)=0D0
7690 COEFU(J1)=0D0
7691 DO 160 J2=1,NBIN
7692 WTMAT(J1,J2)=0D0
7693 160 CONTINUE
7694 170 CONTINUE
7695 DO 180 IACC=1,NACC
7696 IBIN=MVARPT(IACC,IVAR)
7697 IF(IVAR.EQ.1) THEN
7698 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7699 IBIN=IBIN-1
7700 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7701 IBIN=3+2*MINT(72)
7702 ENDIF
7703 ENDIF
7704 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7705 NAREL(IBIN)=NAREL(IBIN)+1
7706 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7707
7708C...Sum up tau cross-section pieces in points used.
7709 IF(IVAR.EQ.1) THEN
7710 TAU=VINTPT(IACC,11)
7711 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7712 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7713 IF(NBIN.GE.4) THEN
7714 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7715 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7716 & ((TAU-TAUR1)**2+GAMR1**2)
7717 ENDIF
7718 IF(NBIN.GE.6) THEN
7719 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7720 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7721 & ((TAU-TAUR2)**2+GAMR2**2)
7722 ENDIF
7723 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7724 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7725 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7726 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7727 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7728 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7729 ENDIF
7730 IF(MINT(72).EQ.3) THEN
7731 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7732 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7733 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7734 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7735 ENDIF
7736C...Sum up tau' cross-section pieces in points used.
7737 ELSEIF(IVAR.EQ.2) THEN
7738 TAU=VINTPT(IACC,11)
7739 TAUP=VINTPT(IACC,16)
7740 TAUPMN=VINTPT(IACC,6)
7741 TAUPMX=VINTPT(IACC,26)
7742 ATAUP1=LOG(TAUPMX/TAUPMN)
7743 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7744 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7745 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7746 & (1D0-TAU/TAUP)**3/TAUP
7747 IF(NBIN.GE.3) THEN
7748 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7749 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7750 & TAUP/MAX(2D-10,1D0-TAUP)
7751 ENDIF
7752
7753C...Sum up y* cross-section pieces in points used.
7754 ELSEIF(IVAR.EQ.3) THEN
7755 YST=VINTPT(IACC,12)
7756 YSTMIN=VINTPT(IACC,2)
7757 YSTMAX=VINTPT(IACC,22)
7758 AYST0=YSTMAX-YSTMIN
7759 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7760 AYST2=AYST1
7761 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7762 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7763 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7764 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7765 IF(MINT(45).EQ.3) THEN
7766 TAUE=VINTPT(IACC,11)
7767 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7768 YST0=-0.5D0*LOG(TAUE)
7769 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7770 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7771 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7772 & MAX(1D-10,1D0-EXP(YST-YST0))
7773 ENDIF
7774 IF(MINT(46).EQ.3) THEN
7775 TAUE=VINTPT(IACC,11)
7776 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7777 YST0=-0.5D0*LOG(TAUE)
7778 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7779 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7780 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7781 & MAX(1D-10,1D0-EXP(-YST-YST0))
7782 ENDIF
7783
7784C...Sum up cos(theta-hat) cross-section pieces in points used.
7785 ELSE
7786 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7787 RSQM=1D0+RM34
7788 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7789 CTHMIN=-CTHMAX
7790 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7791 & (TAUMAX*VINT(2)))
7792 ACTH1=CTHMAX-CTHMIN
7793 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7794 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7795 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7796 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7797 CTH=VINTPT(IACC,13)
7798 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7799 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7800 & MAX(RM34,RSQM-CTH)
7801 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7802 & MAX(RM34,RSQM+CTH)
7803 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7804 & MAX(RM34,RSQM-CTH)**2
7805 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7806 & MAX(RM34,RSQM+CTH)**2
7807 ENDIF
7808 180 CONTINUE
7809
7810C...Check that equation system solvable.
7811 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7812 MSOLV=1
7813 WTRELS=0D0
7814 DO 190 IBIN=1,NBIN
7815 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7816 & IRED=1,NBIN),WTREL(IBIN)
7817 IF(NAREL(IBIN).EQ.0) MSOLV=0
7818 WTRELS=WTRELS+WTREL(IBIN)
7819 190 CONTINUE
7820 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7821
7822C...Solve to find relative importance of cross-section pieces.
7823 IF(MSOLV.EQ.1) THEN
7824 DO 200 IBIN=1,NBIN
7825 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7826 200 CONTINUE
7827 DO 230 IRED=1,NBIN-1
7828 DO 220 IBIN=IRED+1,NBIN
7829 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7830 MSOLV=0
7831 GOTO 260
7832 ENDIF
7833 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7834 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7835 DO 210 ICOE=IRED,NBIN
7836 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7837 210 CONTINUE
7838 220 CONTINUE
7839 230 CONTINUE
7840 DO 250 IRED=NBIN,1,-1
7841 DO 240 ICOE=IRED+1,NBIN
7842 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7843 240 CONTINUE
7844 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7845 250 CONTINUE
7846 ENDIF
7847
7848C...Share evenly if failure.
7849 260 IF(MSOLV.EQ.0) THEN
7850 DO 270 IBIN=1,NBIN
7851 COEFU(IBIN)=1D0
7852 WTRELN(IBIN)=0.1D0
7853 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7854 & WTREL(IBIN)/WTRELS)
7855 270 CONTINUE
7856 ENDIF
7857
7858C...Normalize coefficients, with piece shared democratically.
7859 COEFSU=0D0
7860 WTRELS=0D0
7861 DO 280 IBIN=1,NBIN
7862 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7863 COEFSU=COEFSU+COEFU(IBIN)
7864 WTRELS=WTRELS+WTRELN(IBIN)
7865 280 CONTINUE
7866 IF(COEFSU.GT.0D0) THEN
7867 DO 290 IBIN=1,NBIN
7868 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7869 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7870 290 CONTINUE
7871 ELSE
7872 DO 300 IBIN=1,NBIN
7873 COEFO(IBIN)=1D0/NBIN
7874 300 CONTINUE
7875 ENDIF
7876 IF(IVAR.EQ.1) IOFF=0
7877 IF(IVAR.EQ.2) IOFF=17
7878 IF(IVAR.EQ.3) IOFF=7
7879 IF(IVAR.EQ.4) IOFF=12
7880 DO 310 IBIN=1,NBIN
7881 ICOF=IOFF+IBIN
7882 IF(IVAR.EQ.1) THEN
7883 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
7884 ICOF=7
7885 ENDIF
7886 ENDIF
7887 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7888 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
7889 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
7890 ELSE
7891 COEF(ISUB,ICOF)=COEFO(IBIN)
7892 ENDIF
7893 310 CONTINUE
7894
7895 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7896 & (COEFO(IBIN),IBIN=1,NBIN)
7897
7898 320 CONTINUE
7899
7900C...Find two most promising maxima among points previously determined.
7901 DO 330 J=1,4
7902 IACCMX(J)=0
7903 SIGSMX(J)=0D0
7904 330 CONTINUE
7905 NMAX=0
7906 DO 390 IACC=1,NACC
7907 DO 340 J=1,30
7908 VINT(10+J)=VINTPT(IACC,J)
7909 340 CONTINUE
7910 IF(ISTSB.NE.5) THEN
7911 CALL PYSIGH(NCHN,SIGS)
7912 IF(MWTXS.EQ.1) THEN
7913 CALL PYEVWT(WTXS)
7914 SIGS=WTXS*SIGS
7915 ENDIF
7916 ELSE
7917 SIGS=0D0
7918 DO 350 IKIN3=1,MSTP(129)
7919 CALL PYKMAP(5,0,0D0)
7920 IF(MINT(51).EQ.1) GOTO 350
7921 CALL PYSIGH(NCHN,SIGTMP)
7922 IF(MWTXS.EQ.1) THEN
7923 CALL PYEVWT(WTXS)
7924 SIGTMP=WTXS*SIGTMP
7925 ENDIF
7926 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7927 350 CONTINUE
7928 ENDIF
7929 IEQ=0
7930 DO 360 IMV=1,NMAX
7931 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7932 360 CONTINUE
7933 IF(IEQ.EQ.0) THEN
7934 DO 370 IMV=NMAX,1,-1
7935 IIN=IMV+1
7936 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7937 IACCMX(IMV+1)=IACCMX(IMV)
7938 SIGSMX(IMV+1)=SIGSMX(IMV)
7939 370 CONTINUE
7940 IIN=1
7941 380 IACCMX(IIN)=IACC
7942 SIGSMX(IIN)=SIGS
7943 IF(NMAX.LE.1) NMAX=NMAX+1
7944 ENDIF
7945 390 CONTINUE
7946
7947C...Read out starting position for search.
7948 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7949 SIGSAM=SIGSMX(1)
7950 DO 440 IMAX=1,NMAX
7951 IACC=IACCMX(IMAX)
7952 MTAU=MVARPT(IACC,1)
7953 MTAUP=MVARPT(IACC,2)
7954 MYST=MVARPT(IACC,3)
7955 MCTH=MVARPT(IACC,4)
7956 VTAU=0.5D0
7957 VYST=0.5D0
7958 VCTH=0.5D0
7959 VTAUP=0.5D0
7960
7961C...Starting point and step size in parameter space.
7962 DO 430 IRPT=1,2
7963 DO 420 IVAR=1,4
7964 IF(NPTS(IVAR).EQ.1) GOTO 420
7965 IF(IVAR.EQ.1) VVAR=VTAU
7966 IF(IVAR.EQ.2) VVAR=VTAUP
7967 IF(IVAR.EQ.3) VVAR=VYST
7968 IF(IVAR.EQ.4) VVAR=VCTH
7969 IF(IVAR.EQ.1) MVAR=MTAU
7970 IF(IVAR.EQ.2) MVAR=MTAUP
7971 IF(IVAR.EQ.3) MVAR=MYST
7972 IF(IVAR.EQ.4) MVAR=MCTH
7973 IF(IRPT.EQ.1) VDEL=0.1D0
7974 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7975 & 0.98D0-VVAR))
7976 IF(IRPT.EQ.1) VMAR=0.02D0
7977 IF(IRPT.EQ.2) VMAR=0.002D0
7978 IMOV0=1
7979 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7980 DO 410 IMOV=IMOV0,8
7981
7982C...Define new point in parameter space.
7983 IF(IMOV.EQ.0) THEN
7984 INEW=2
7985 VNEW=VVAR
7986 ELSEIF(IMOV.EQ.1) THEN
7987 INEW=3
7988 VNEW=VVAR+VDEL
7989 ELSEIF(IMOV.EQ.2) THEN
7990 INEW=1
7991 VNEW=VVAR-VDEL
7992 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7993 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7994 VVAR=VVAR+VDEL
7995 SIGSSM(1)=SIGSSM(2)
7996 SIGSSM(2)=SIGSSM(3)
7997 INEW=3
7998 VNEW=VVAR+VDEL
7999 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8000 & VVAR-2D0*VDEL.GT.VMAR) THEN
8001 VVAR=VVAR-VDEL
8002 SIGSSM(3)=SIGSSM(2)
8003 SIGSSM(2)=SIGSSM(1)
8004 INEW=1
8005 VNEW=VVAR-VDEL
8006 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8007 VDEL=0.5D0*VDEL
8008 VVAR=VVAR+VDEL
8009 SIGSSM(1)=SIGSSM(2)
8010 INEW=2
8011 VNEW=VVAR
8012 ELSE
8013 VDEL=0.5D0*VDEL
8014 VVAR=VVAR-VDEL
8015 SIGSSM(3)=SIGSSM(2)
8016 INEW=2
8017 VNEW=VVAR
8018 ENDIF
8019
8020C...Convert to relevant variables and find derived new limits.
8021 ILERR=0
8022 IF(IVAR.EQ.1) THEN
8023 VTAU=VNEW
8024 CALL PYKMAP(1,MTAU,VTAU)
8025 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8026 CALL PYKLIM(4)
8027 IF(MINT(51).EQ.1) ILERR=1
8028 ENDIF
8029 ENDIF
8030 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8031 & ILERR.EQ.0) THEN
8032 IF(IVAR.EQ.2) VTAUP=VNEW
8033 CALL PYKMAP(4,MTAUP,VTAUP)
8034 ENDIF
8035 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8036 CALL PYKLIM(2)
8037 IF(MINT(51).EQ.1) ILERR=1
8038 ENDIF
8039 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8040 IF(IVAR.EQ.3) VYST=VNEW
8041 CALL PYKMAP(2,MYST,VYST)
8042 CALL PYKLIM(3)
8043 IF(MINT(51).EQ.1) ILERR=1
8044 ENDIF
8045 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8046 & ILERR.EQ.0) THEN
8047 IF(IVAR.EQ.4) VCTH=VNEW
8048 CALL PYKMAP(3,MCTH,VCTH)
8049 ENDIF
8050 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8051
8052C...Evaluate cross-section. Save new maximum. Final maximum.
8053 IF(ILERR.NE.0) THEN
8054 SIGS=0.
8055 ELSEIF(ISTSB.NE.5) THEN
8056 CALL PYSIGH(NCHN,SIGS)
8057 IF(MWTXS.EQ.1) THEN
8058 CALL PYEVWT(WTXS)
8059 SIGS=WTXS*SIGS
8060 ENDIF
8061 ELSE
8062 SIGS=0D0
8063 DO 400 IKIN3=1,MSTP(129)
8064 CALL PYKMAP(5,0,0D0)
8065 IF(MINT(51).EQ.1) GOTO 400
8066 CALL PYSIGH(NCHN,SIGTMP)
8067 IF(MWTXS.EQ.1) THEN
8068 CALL PYEVWT(WTXS)
8069 SIGTMP=WTXS*SIGTMP
8070 ENDIF
8071 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8072 400 CONTINUE
8073 ENDIF
8074 SIGSSM(INEW)=SIGS
8075 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8076 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8077 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8078 410 CONTINUE
8079 420 CONTINUE
8080 430 CONTINUE
8081 440 CONTINUE
8082 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8083 XSEC(ISUB,1)=1.05D0*SIGSAM
8084 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8085 & WTGAGA*XSEC(ISUB,1)
8086 450 CONTINUE
8087 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8088 & PARP(174)*XSEC(ISUB,1)
8089 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8090 460 CONTINUE
8091 MINT(51)=0
8092
8093C...Print summary table.
8094 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8095 IF(MSTP(127).NE.1) THEN
8096 WRITE(MSTU(11),5900)
8097 CALL PYSTOP(1)
8098 ELSE
8099 WRITE(MSTU(11),6400)
8100 MSTI(53)=1
8101 ENDIF
8102 ENDIF
8103 IF(MSTP(122).GE.1) THEN
8104 WRITE(MSTU(11),6000)
8105 WRITE(MSTU(11),6100)
8106 DO 470 ISUB=1,500
8107 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8108 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8109 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8110 & GOTO 470
8111 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8112 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8113 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8114 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8115 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8116 470 CONTINUE
8117 WRITE(MSTU(11),6300)
8118 ENDIF
8119
8120C...Format statements for maximization results.
8121 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8122 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8123 &'cth',9X,'tau''',7X,'sigma')
8124 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8125 &'phase space.'/1X,'Process switched off!')
8126 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8127 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8128 &'cross-section.'/1X,'Process switched off!')
8129 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8130 5500 FORMAT(1X,1P,10D11.3)
8131 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8132 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8133 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8134 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8135 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8136 &'cross-section.'/1X,'Execution stopped!')
8137 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8138 &'cross-section maximum search',1X,8('*'))
8139 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8140 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8141 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8142 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8143 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8144 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8145 &'cross-section.'/
8146 &1X,'Execution will stop if you try to generate events.')
8147
8148 RETURN
8149 END
8150
8151C*********************************************************************
8152
8153C...PYPILE
8154C...Initializes multiplicity distribution and selects mutliplicity
8155C...of pileup events, i.e. several events occuring at the same
8156C...beam crossing.
8157
8158 SUBROUTINE PYPILE(MPILE)
8159
8160C...Double precision and integer declarations.
8161 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8162 IMPLICIT INTEGER(I-N)
8163 INTEGER PYK,PYCHGE,PYCOMP
8164C...Commonblocks.
8165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8166 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8167 COMMON/PYINT1/MINT(400),VINT(400)
8168 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8169 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8170C...Local arrays and saved variables.
8171 DIMENSION WTI(0:200)
8172 SAVE IMIN,IMAX,WTI,WTS
8173
8174C...Sum of allowed cross-sections for pileup events.
8175 IF(MPILE.EQ.1) THEN
8176 VINT(131)=SIGT(0,0,5)
8177 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8178 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8179 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8180 IF(MSTP(133).LE.0) RETURN
8181
8182C...Initialize multiplicity distribution at maximum.
8183 XNAVE=VINT(131)*PARP(131)
8184 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8185 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8186 WTI(INAVE)=1D0
8187 WTS=WTI(INAVE)
8188 WTN=WTI(INAVE)*INAVE
8189
8190C...Find shape of multiplicity distribution below maximum.
8191 IMIN=INAVE
8192 DO 100 I=INAVE-1,1,-1
8193 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8194 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8195 IF(WTI(I).LT.1D-6) GOTO 110
8196 WTS=WTS+WTI(I)
8197 WTN=WTN+WTI(I)*I
8198 IMIN=I
8199 100 CONTINUE
8200
8201C...Find shape of multiplicity distribution above maximum.
8202 110 IMAX=INAVE
8203 DO 120 I=INAVE+1,200
8204 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8205 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8206 IF(WTI(I).LT.1D-6) GOTO 130
8207 WTS=WTS+WTI(I)
8208 WTN=WTN+WTI(I)*I
8209 IMAX=I
8210 120 CONTINUE
8211 130 VINT(132)=XNAVE
8212 VINT(133)=WTN/WTS
8213 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8214 & WTS/(WTS+WTI(1)/XNAVE)
8215 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8216 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8217
8218C...Pick multiplicity of pileup events.
8219 ELSE
8220 IF(MSTP(133).LE.0) THEN
8221 MINT(81)=MAX(1,MSTP(134))
8222 ELSE
8223 WTR=WTS*PYR(0)
8224 DO 140 I=IMIN,IMAX
8225 MINT(81)=I
8226 WTR=WTR-WTI(I)
8227 IF(WTR.LE.0D0) GOTO 150
8228 140 CONTINUE
8229 150 CONTINUE
8230 ENDIF
8231 ENDIF
8232
8233C...Format statement for error message.
8234 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8235 &'crossing too large, ',1P,D12.4)
8236
8237 RETURN
8238 END
8239
8240C*********************************************************************
8241
8242C...PYSAVE
8243C...Saves and restores parameter and cross section values for the
8244C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8245C...Also makes random choice between alternatives.
8246
8247 SUBROUTINE PYSAVE(ISAVE,IGA)
8248
8249C...Double precision and integer declarations.
8250 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8251 IMPLICIT INTEGER(I-N)
8252 INTEGER PYK,PYCHGE,PYCOMP
8253C...Commonblocks.
8254 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8255 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8256 COMMON/PYINT1/MINT(400),VINT(400)
8257 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8258 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8259 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8260 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8261C...Local arrays and saved variables.
8262 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8263 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8264 &INTCP(15,20),RECP(15,20)
8265 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8266
8267C...Save list of subprocesses and cross-section information.
8268 IF(ISAVE.EQ.1) THEN
8269 ICP=0
8270 DO 120 I=1,500
8271 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8272 ICP=ICP+1
8273 NSUBCP(IGA,ICP)=I
8274 MSUBCP(IGA,ICP)=MSUB(I)
8275 DO 100 J=1,20
8276 COEFCP(IGA,ICP,J)=COEF(I,J)
8277 100 CONTINUE
8278 DO 110 J=1,3
8279 NGENCP(IGA,ICP,J)=NGEN(I,J)
8280 XSECCP(IGA,ICP,J)=XSEC(I,J)
8281 110 CONTINUE
8282 120 CONTINUE
8283 NCP(IGA)=ICP
8284 DO 130 J=1,3
8285 NGENCP(IGA,0,J)=NGEN(0,J)
8286 XSECCP(IGA,0,J)=XSEC(0,J)
8287 130 CONTINUE
8288 DO 160 I1=0,6
8289 DO 150 I2=0,6
8290 DO 140 J=0,5
8291 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8292 140 CONTINUE
8293 150 CONTINUE
8294 160 CONTINUE
8295
8296C...Save various common process variables.
8297 DO 170 J=1,10
8298 INTCP(IGA,J)=MINT(40+J)
8299 170 CONTINUE
8300 INTCP(IGA,11)=MINT(101)
8301 INTCP(IGA,12)=MINT(102)
8302 INTCP(IGA,13)=MINT(107)
8303 INTCP(IGA,14)=MINT(108)
8304 INTCP(IGA,15)=MINT(123)
8305 RECP(IGA,1)=CKIN(3)
8306 RECP(IGA,2)=VINT(318)
8307
8308C...Save cross-section information only.
8309 ELSEIF(ISAVE.EQ.2) THEN
8310 DO 190 ICP=1,NCP(IGA)
8311 I=NSUBCP(IGA,ICP)
8312 DO 180 J=1,3
8313 NGENCP(IGA,ICP,J)=NGEN(I,J)
8314 XSECCP(IGA,ICP,J)=XSEC(I,J)
8315 180 CONTINUE
8316 190 CONTINUE
8317 DO 200 J=1,3
8318 NGENCP(IGA,0,J)=NGEN(0,J)
8319 XSECCP(IGA,0,J)=XSEC(0,J)
8320 200 CONTINUE
8321
8322C...Choose between allowed alternatives.
8323 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8324 IF(ISAVE.EQ.4) THEN
8325 XSUMCP=0D0
8326 DO 210 IG=1,MINT(121)
8327 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8328 210 CONTINUE
8329 XSUMCP=XSUMCP*PYR(0)
8330 DO 220 IG=1,MINT(121)
8331 IGA=IG
8332 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8333 IF(XSUMCP.LE.0D0) GOTO 230
8334 220 CONTINUE
8335 230 CONTINUE
8336 ENDIF
8337
8338C...Restore cross-section information.
8339 DO 240 I=1,500
8340 MSUB(I)=0
8341 240 CONTINUE
8342 DO 270 ICP=1,NCP(IGA)
8343 I=NSUBCP(IGA,ICP)
8344 MSUB(I)=MSUBCP(IGA,ICP)
8345 DO 250 J=1,20
8346 COEF(I,J)=COEFCP(IGA,ICP,J)
8347 250 CONTINUE
8348 DO 260 J=1,3
8349 NGEN(I,J)=NGENCP(IGA,ICP,J)
8350 XSEC(I,J)=XSECCP(IGA,ICP,J)
8351 260 CONTINUE
8352 270 CONTINUE
8353 DO 280 J=1,3
8354 NGEN(0,J)=NGENCP(IGA,0,J)
8355 XSEC(0,J)=XSECCP(IGA,0,J)
8356 280 CONTINUE
8357 DO 310 I1=0,6
8358 DO 300 I2=0,6
8359 DO 290 J=0,5
8360 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8361 290 CONTINUE
8362 300 CONTINUE
8363 310 CONTINUE
8364
8365C...Restore various common process variables.
8366 DO 320 J=1,10
8367 MINT(40+J)=INTCP(IGA,J)
8368 320 CONTINUE
8369 MINT(101)=INTCP(IGA,11)
8370 MINT(102)=INTCP(IGA,12)
8371 MINT(107)=INTCP(IGA,13)
8372 MINT(108)=INTCP(IGA,14)
8373 MINT(123)=INTCP(IGA,15)
8374 CKIN(3)=RECP(IGA,1)
8375 CKIN(1)=2D0*CKIN(3)
8376 VINT(318)=RECP(IGA,2)
8377
8378C...Sum up cross-section info (for PYSTAT).
8379 ELSEIF(ISAVE.EQ.5) THEN
8380 DO 330 I=1,500
8381 MSUB(I)=0
8382 NGEN(I,1)=0
8383 NGEN(I,3)=0
8384 XSEC(I,3)=0D0
8385 330 CONTINUE
8386 NGEN(0,1)=0
8387 NGEN(0,2)=0
8388 NGEN(0,3)=0
8389 XSEC(0,3)=0
8390 DO 350 IG=1,MINT(121)
8391 DO 340 ICP=1,NCP(IG)
8392 I=NSUBCP(IG,ICP)
8393 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8394 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8395 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8396 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8397 340 CONTINUE
8398 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8399 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8400 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8401 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8402 350 CONTINUE
8403 ENDIF
8404
8405 RETURN
8406 END
8407
8408C*********************************************************************
8409
8410C...PYGAGA
8411C...For lepton beams it gives photon-hadron or photon-photon systems
8412C...to be treated with the ordinary machinery and combines this with a
8413C...description of the lepton -> lepton + photon branching.
8414
8415 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8416
8417C...Double precision and integer declarations.
8418 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8419 IMPLICIT INTEGER(I-N)
8420 INTEGER PYK,PYCHGE,PYCOMP
8421C...Commonblocks.
8422 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8424 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8425 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8426 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8427 COMMON/PYINT1/MINT(400),VINT(400)
8428 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8429 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8430 &/PYINT5/
8431C...Local variables and data statement.
8432 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8433 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8434 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8435 DATA EPS/1D-4/
8436
8437C...Initialize generation of photons inside leptons.
8438 IF(IGAGA.EQ.1) THEN
8439
8440C...Save quantities on incoming lepton system.
8441 VINT(301)=VINT(1)
8442 VINT(302)=VINT(2)
8443 PMS(1)=VINT(303)**2
8444 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8445 PMS(2)=VINT(304)**2
8446 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8447 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8448 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8449
8450C...Calculate range of x and Q2 values allowed in generation.
8451 DO 100 I=1,2
8452 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8453 IF(MINT(140+I).NE.0) THEN
8454 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8455 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8456 & PMC(I),1D0-EPS)
8457 YMIN=MAX(CKIN(71+2*I),EPS)
8458 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8459 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8460 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8461 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8462 THEMIN=MAX(CKIN(67+2*I),0D0)
8463 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8464 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8465 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8466 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8467 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8468 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8469 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8470 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8471 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8472C...W limits when lepton on one side only.
8473 IF(MINT(143-I).EQ.0) THEN
8474 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8475 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8476 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8477 ENDIF
8478 ENDIF
8479 100 CONTINUE
8480
8481C...W limits when lepton on both sides.
8482 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8483 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8484 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8485 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8486 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8487 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8488 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8489 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8490 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8491 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8492 ELSE
8493 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8494 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8495 ENDIF
8496 ENDIF
8497
8498C...Q2 and W values and photon flux weight factors for initialization.
8499 ELSEIF(IGAGA.EQ.2) THEN
8500 ISUB=MINT(1)
8501 MINT(15)=0
8502 MINT(16)=0
8503
8504C...W value for photon on one or both sides, and for processes
8505C...with gamma-gamma cross section peaked at small shat.
8506 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8507 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8508 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8509 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8510 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8511 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8512 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8513 ELSE
8514 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8515 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8516 ENDIF
8517 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8518
8519C...Upper estimate of photon flux weight factor.
8520C...Initialization Q2 scale. Flag incoming unresolved photon.
8521 WTGAGA=1D0
8522 DO 110 I=1,2
8523 IF(MINT(140+I).NE.0) THEN
8524 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8525 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8526 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8527 & THEN
8528 Q2INIT=5D0+Q2MIN(3-I)
8529 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8530 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8531 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8532 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8533 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8534 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8535 Q2INIT=VINT(2)/3D0
8536 ELSEIF(ISUB.EQ.140) THEN
8537 Q2INIT=VINT(2)/2D0
8538 ELSE
8539 Q2INIT=Q2MIN(I)
8540 ENDIF
8541 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8542 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8543 & MINT(14+I)=22
8544 VINT(306+I)=VINT(2+I)**2
8545 ENDIF
8546 110 CONTINUE
8547 VINT(320)=WTGAGA
8548
8549C...Update pTmin and cross section information.
8550 IF(MSTP(82).LE.1) THEN
8551 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8552 ELSE
8553 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8554 ENDIF
8555 VINT(149)=4D0*PTMN**2/VINT(2)
8556 VINT(154)=PTMN
8557 CALL PYXTOT
8558 VINT(318)=VINT(317)
8559
8560C...Generate photons inside leptons and
8561C...calculate photon flux weight factors.
8562 ELSEIF(IGAGA.EQ.3) THEN
8563 ISUB=MINT(1)
8564 MINT(15)=0
8565 MINT(16)=0
8566
8567C...Generate phase space point and check against cuts.
8568 LOOP=0
8569 120 LOOP=LOOP+1
8570 DO 130 I=1,2
8571 IF(MINT(140+I).NE.0) THEN
8572C...Pick x and Q2
8573 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8574 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8575C...Cuts on internal consistency in x and Q2.
8576 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8577 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8578 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8579C...Cuts on y and theta.
8580 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8581 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8582 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8583 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8584 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8585 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8586 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8587 & GOTO 120
8588
8589C...Phi angle isotropic. Reconstruct pT.
8590 PHI(I)=PARU(2)*PYR(0)
8591 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8592 & PMS(I))*SIN(THETA(I))
8593
8594C...Store info on variables selected, for documentation purposes.
8595 VINT(2+I)=-SQRT(Q2(I))
8596 VINT(304+I)=X(I)
8597 VINT(306+I)=Q2(I)
8598 VINT(308+I)=Y(I)
8599 VINT(310+I)=THETA(I)
8600 VINT(312+I)=PHI(I)
8601 ELSE
8602 VINT(304+I)=1D0
8603 VINT(306+I)=0D0
8604 VINT(308+I)=1D0
8605 VINT(310+I)=0D0
8606 VINT(312+I)=0D0
8607 ENDIF
8608 130 CONTINUE
8609
8610C...Cut on W combines info from two sides.
8611 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8612 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8613 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8614 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8615 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8616 IF(W2.LT.W2MIN) GOTO 120
8617 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8618 PMS1=-Q2(1)
8619 PMS2=-Q2(2)
8620 ELSEIF(MINT(141).NE.0) THEN
8621 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8622 PMS1=-Q2(1)
8623 PMS2=PMS(2)
8624 ELSEIF(MINT(142).NE.0) THEN
8625 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8626 PMS1=PMS(1)
8627 PMS2=-Q2(2)
8628 ENDIF
8629
8630C...Store kinematics info for photon(s) in subsystem cm frame.
8631 VINT(2)=W2
8632 VINT(1)=SQRT(W2)
8633 VINT(291)=0D0
8634 VINT(292)=0D0
8635 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8636 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8637 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8638 VINT(296)=0D0
8639 VINT(297)=0D0
8640 VINT(298)=-VINT(293)
8641 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8642 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8643
8644C...Assign weight for photon flux; different for transverse and
8645C...longitudinal photons. Flag incoming unresolved photon.
8646 WTGAGA=1D0
8647 DO 140 I=1,2
8648 IF(MINT(140+I).NE.0) THEN
8649 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8650 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8651 IF(MSTP(16).EQ.0) THEN
8652 XY=X(I)
8653 ELSE
8654 WTGAGA=WTGAGA*X(I)/Y(I)
8655 XY=Y(I)
8656 ENDIF
8657 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8658 WTGAGA=WTGAGA*(1D0-XY)
8659 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8660 WTGAGA=WTGAGA*(1D0-XY)
8661 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8662 WTGAGA=WTGAGA*(1D0-XY)
8663 ELSE
8664 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8665 & PMS(I)*XY**2/Q2(I))
8666 ENDIF
8667 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8668 ENDIF
8669 140 CONTINUE
8670 VINT(319)=WTGAGA
8671 MINT(143)=LOOP
8672
8673C...Update pTmin and cross section information.
8674 IF(MSTP(82).LE.1) THEN
8675 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8676 ELSE
8677 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8678 ENDIF
8679 VINT(149)=4D0*PTMN**2/VINT(2)
8680 VINT(154)=PTMN
8681 CALL PYXTOT
8682
8683C...Reconstruct kinematics of photons inside leptons.
8684 ELSEIF(IGAGA.EQ.4) THEN
8685
8686C...Make place for incoming particles and scattered leptons.
8687 MOVE=3
8688 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8689 MINT(4)=MINT(4)+MOVE
8690 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8691 IF(K(I,1).EQ.21) THEN
8692 DO 150 J=1,5
8693 K(I+MOVE,J)=K(I,J)
8694 P(I+MOVE,J)=P(I,J)
8695 V(I+MOVE,J)=V(I,J)
8696 150 CONTINUE
8697 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8698 & K(I+MOVE,3)=K(I,3)+MOVE
8699 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8700 & K(I+MOVE,4)=K(I,4)+MOVE
8701 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8702 & K(I+MOVE,5)=K(I,5)+MOVE
8703 ENDIF
8704 160 CONTINUE
8705 DO 170 I=MINT(84)+1,N
8706 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8707 & K(I,3)=K(I,3)+MOVE
8708 170 CONTINUE
8709
8710C...Fill in incoming particles.
8711 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8712 DO 180 J=1,5
8713 K(I,J)=0
8714 P(I,J)=0D0
8715 V(I,J)=0D0
8716 180 CONTINUE
8717 190 CONTINUE
8718 DO 200 I=1,2
8719 K(MINT(83)+I,1)=21
8720 IF(MINT(140+I).NE.0) THEN
8721 K(MINT(83)+I,2)=MINT(140+I)
8722 P(MINT(83)+I,5)=VINT(302+I)
8723 ELSE
8724 K(MINT(83)+I,2)=MINT(10+I)
8725 P(MINT(83)+I,5)=VINT(2+I)
8726 ENDIF
8727 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8728 & VINT(302))*(-1D0)**(I+1)
8729 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8730 200 CONTINUE
8731
8732C...New mother-daughter relations in documentation section.
8733 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8734 K(MINT(83)+1,4)=MINT(83)+3
8735 K(MINT(83)+1,5)=MINT(83)+5
8736 K(MINT(83)+2,4)=MINT(83)+4
8737 K(MINT(83)+2,5)=MINT(83)+6
8738 K(MINT(83)+3,3)=MINT(83)+1
8739 K(MINT(83)+5,3)=MINT(83)+1
8740 K(MINT(83)+4,3)=MINT(83)+2
8741 K(MINT(83)+6,3)=MINT(83)+2
8742 ELSEIF(MINT(141).NE.0) THEN
8743 K(MINT(83)+1,4)=MINT(83)+3
8744 K(MINT(83)+1,5)=MINT(83)+4
8745 K(MINT(83)+2,4)=MINT(83)+5
8746 K(MINT(83)+3,3)=MINT(83)+1
8747 K(MINT(83)+4,3)=MINT(83)+1
8748 K(MINT(83)+5,3)=MINT(83)+2
8749 ELSEIF(MINT(142).NE.0) THEN
8750 K(MINT(83)+1,4)=MINT(83)+4
8751 K(MINT(83)+2,4)=MINT(83)+3
8752 K(MINT(83)+2,5)=MINT(83)+5
8753 K(MINT(83)+3,3)=MINT(83)+2
8754 K(MINT(83)+4,3)=MINT(83)+1
8755 K(MINT(83)+5,3)=MINT(83)+2
8756 ENDIF
8757
8758C...Fill scattered lepton(s).
8759 DO 210 I=1,2
8760 IF(MINT(140+I).NE.0) THEN
8761 LSC=MINT(83)+MIN(I+2,MOVE)
8762 K(LSC,1)=21
8763 K(LSC,2)=MINT(140+I)
8764 P(LSC,1)=PT(I)*COS(PHI(I))
8765 P(LSC,2)=PT(I)*SIN(PHI(I))
8766 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8767 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8768 & (-1D0)**(I-1)
8769 P(LSC,5)=VINT(302+I)
8770 ENDIF
8771 210 CONTINUE
8772
8773C...Find incoming four-vectors to subprocess.
8774 K(N+1,1)=21
8775 IF(MINT(141).NE.0) THEN
8776 DO 220 J=1,4
8777 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8778 220 CONTINUE
8779 ELSE
8780 DO 230 J=1,4
8781 P(N+1,J)=P(MINT(83)+1,J)
8782 230 CONTINUE
8783 ENDIF
8784 K(N+2,1)=21
8785 IF(MINT(142).NE.0) THEN
8786 DO 240 J=1,4
8787 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8788 240 CONTINUE
8789 ELSE
8790 DO 250 J=1,4
8791 P(N+2,J)=P(MINT(83)+2,J)
8792 250 CONTINUE
8793 ENDIF
8794
8795C...Define boost and rotation between hadronic subsystem and
8796C...collision rest frame; boost hadronic subsystem to this frame.
8797 DO 260 J=1,3
8798 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8799 260 CONTINUE
8800 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8801 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8802 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8803 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8804 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8805 & BETA(3))
8806
8807C...Add on scattered leptons to final state.
8808 DO 280 I=1,2
8809 IF(MINT(140+I).NE.0) THEN
8810 LSC=MINT(83)+MIN(I+2,MOVE)
8811 N=N+1
8812 DO 270 J=1,5
8813 K(N,J)=K(LSC,J)
8814 P(N,J)=P(LSC,J)
8815 V(N,J)=V(LSC,J)
8816 270 CONTINUE
8817 K(N,1)=1
8818 K(N,3)=LSC
8819 ENDIF
8820 280 CONTINUE
8821 ENDIF
8822
8823 RETURN
8824 END
8825
8826C*********************************************************************
8827
8828C...PYRAND
8829C...Generates quantities characterizing the high-pT scattering at the
8830C...parton level according to the matrix elements. Chooses incoming,
8831C...reacting partons, their momentum fractions and one of the possible
8832C...subprocesses.
8833
8834 SUBROUTINE PYRAND
8835
8836C...Double precision and integer declarations.
8837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8838 IMPLICIT INTEGER(I-N)
8839 INTEGER PYK,PYCHGE,PYCOMP
8840C...Parameter statement to help give large particle numbers.
8841 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8842 &KEXCIT=4000000,KDIMEN=5000000)
8843
8844C...User process initialization and event commonblocks.
8845 INTEGER MAXPUP
8846 PARAMETER (MAXPUP=100)
8847 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8848 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8849 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8850 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8851 &LPRUP(MAXPUP)
8852 INTEGER MAXNUP
8853 PARAMETER (MAXNUP=500)
8854 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8855 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8856 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8857 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8858 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8859 SAVE /HEPRUP/,/HEPEUP/
8860
8861C...Commonblocks.
8862 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8863 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8864 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8865 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8866 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8867 COMMON/PYINT1/MINT(400),VINT(400)
8868 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8869 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8870 COMMON/PYINT4/MWID(500),WIDS(500,5)
8871 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8872 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8873 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8874 COMMON/PYTCCO/COEFX(194:380,2)
8875 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
8876 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8877 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
8878 &/TCPARA/
8879C...Local arrays.
8880 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8881
8882C...Parameters and data used in elastic/diffractive treatment.
8883 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8884 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8885
8886C...Initial values, specifically for (first) semihard interaction.
8887 MINT(10)=0
8888 MINT(17)=0
8889 MINT(18)=0
8890 VINT(143)=1D0
8891 VINT(144)=1D0
8892 VINT(157)=0D0
8893 VINT(158)=0D0
8894 MFAIL=0
8895 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8896 ISUB=0
8897 ISTSB=0
8898 LOOP=0
8899 100 LOOP=LOOP+1
8900 MINT(51)=0
8901 MINT(143)=1
8902 VINT(97)=1D0
8903
8904C...Start by assuming incoming photon is entering subprocess.
8905 IF(MINT(11).EQ.22) THEN
8906 MINT(15)=22
8907 VINT(307)=VINT(3)**2
8908 ENDIF
8909 IF(MINT(12).EQ.22) THEN
8910 MINT(16)=22
8911 VINT(308)=VINT(4)**2
8912 ENDIF
8913 MINT(103)=MINT(11)
8914 MINT(104)=MINT(12)
8915
8916C...Choice of process type - first event of pileup.
8917 INMULT=0
8918 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8919 ELSEIF(MINT(82).EQ.1) THEN
8920
8921C...For gamma-p or gamma-gamma first pick between alternatives.
8922 IGA=0
8923 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8924 MINT(122)=IGA
8925
8926C...For real gamma + gamma with different nature, flip at random.
8927 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8928 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8929 MINTSV=MINT(41)
8930 MINT(41)=MINT(42)
8931 MINT(42)=MINTSV
8932 MINTSV=MINT(45)
8933 MINT(45)=MINT(46)
8934 MINT(46)=MINTSV
8935 MINTSV=MINT(107)
8936 MINT(107)=MINT(108)
8937 MINT(108)=MINTSV
8938 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8939 ENDIF
8940
8941C...Pick process type, possibly by user process machinery.
8942C...(If the latter, also event will be picked here.)
8943 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8944 CALL UPEVNT
8945 CALL PYUPRE
8946 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8947 CALL UPEVNT
8948 CALL PYUPRE
8949 ISUB=0
8950 110 ISUB=ISUB+1
8951 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8952 & ISUB.LT.500) GOTO 110
8953 ELSE
8954 RSUB=XSEC(0,1)*PYR(0)
8955 DO 120 I=1,500
8956 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8957 ISUB=I
8958 RSUB=RSUB-XSEC(I,1)
8959 IF(RSUB.LE.0D0) GOTO 130
8960 120 CONTINUE
8961 130 IF(ISUB.EQ.95) ISUB=96
8962 IF(ISUB.EQ.96) INMULT=1
8963 IF(ISET(ISUB).EQ.11) THEN
8964 IDPRUP=KFPR(ISUB,2)
8965 CALL UPEVNT
8966 CALL PYUPRE
8967 ENDIF
8968 ENDIF
8969
8970C...Choice of inclusive process type - pileup events.
8971 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8972 RSUB=VINT(131)*PYR(0)
8973 ISUB=96
8974 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8975 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8976 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8977 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8978 & ISUB=91
8979 IF(ISUB.EQ.96) INMULT=1
8980 ENDIF
8981
8982C...Choice of photon energy and flux factor inside lepton.
8983 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8984 CALL PYGAGA(3,WTGAGA)
8985 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8986 CKIN(3)=MAX(VINT(285),VINT(154))
8987 CKIN(1)=2D0*CKIN(3)
8988 ENDIF
8989C...When necessary set direct/resolved photon by hand.
8990 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8991 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8992 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8993 ENDIF
8994
8995C...Restrict direct*resolved processes to pTmin >= Q,
8996C...to avoid doublecounting with DIS.
8997 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8998 IF(MINT(15).EQ.22) THEN
8999 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9000 ELSE
9001 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9002 ENDIF
9003 CKIN(1)=2D0*CKIN(3)
9004 ENDIF
9005
9006C...Set up for multiple interactions (may include impact parameter).
9007 IF(INMULT.EQ.1) THEN
9008 IF(MINT(35).LE.1) CALL PYMULT(2)
9009 IF(MINT(35).GE.2) CALL PYMIGN(2)
9010 ENDIF
9011
9012C...Loopback point for minimum bias in photon physics.
9013 LOOP2=0
9014 140 LOOP2=LOOP2+1
9015 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9016 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9017 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9018 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9019 MINT(1)=ISUB
9020 ISTSB=ISET(ISUB)
9021
9022C...Random choice of flavour for some SUSY processes.
9023 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9024C...~e_L ~nu_e or ~mu_L ~nu_mu.
9025 IF(ISUB.EQ.210) THEN
9026 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9027 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9028C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9029 ELSEIF(ISUB.EQ.213) THEN
9030 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9031 KFPR(ISUB,2)=KFPR(ISUB,1)
9032C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9033 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9034 & ISUB.NE.257) THEN
9035 IF(ISUB.GE.258) THEN
9036 RKF=4D0
9037 ELSE
9038 RKF=5D0
9039 ENDIF
9040 IF(MOD(ISUB,2).EQ.0) THEN
9041 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9042 ELSE
9043 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9044 ENDIF
9045C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9046 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9047 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9048 KSU1=KSUSY1
9049 KSU2=KSUSY1
9050 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9051 KSU1=KSUSY2
9052 KSU2=KSUSY2
9053 ELSEIF(PYR(0).LT.0.5D0) THEN
9054 KSU1=KSUSY1
9055 KSU2=KSUSY2
9056 ELSE
9057 KSU1=KSUSY2
9058 KSU2=KSUSY1
9059 ENDIF
9060 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9061 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9062C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9063 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9064 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9065 KFPR(ISUB,2)=KFPR(ISUB,1)
9066 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9067 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9068 KFPR(ISUB,2)=KFPR(ISUB,1)
9069C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9070 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9071 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9072 KSU1=KSUSY1
9073 KSU2=KSUSY1
9074 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9075 KSU1=KSUSY2
9076 KSU2=KSUSY2
9077 ELSEIF(PYR(0).LT.0.5D0) THEN
9078 KSU1=KSUSY1
9079 KSU2=KSUSY2
9080 ELSE
9081 KSU1=KSUSY2
9082 KSU2=KSUSY1
9083 ENDIF
9084 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9085 RKF=5D0
9086 ELSE
9087 RKF=4D0
9088 ENDIF
9089 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9090 ENDIF
9091 ENDIF
9092
9093C...Find resonances (explicit or implicit in cross-section).
9094 MINT(72)=0
9095 KFR1=0
9096 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9097 KFR1=KFPR(ISUB,1)
9098 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9099 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9100 KFR1=23
9101 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9102 & ISUB.EQ.177) THEN
9103 KFR1=24
9104 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9105 KFR1=25
9106 IF(MSTP(46).EQ.5) THEN
9107 KFR1=89
9108 PMAS(89,1)=PARP(45)
9109 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9110 ENDIF
9111 ENDIF
9112 CKMX=CKIN(2)
9113 IF(CKMX.LE.0D0) CKMX=VINT(1)
9114 KCR1=PYCOMP(KFR1)
9115 IF(KFR1.NE.0) THEN
9116 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9117 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9118 ENDIF
9119 IF(KFR1.NE.0) THEN
9120 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9121 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9122 MINT(72)=1
9123 MINT(73)=KFR1
9124 VINT(73)=TAUR1
9125 VINT(74)=GAMR1
9126 ENDIF
9127 KFR2=0
9128 KFR3=0
9129 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9130 $(ISUB.GE.361.AND.ISUB.LE.380))
9131 $THEN
9132 KFR2=23
9133 IF(ISUB.EQ.141) THEN
9134 KCR2=PYCOMP(KFR2)
9135 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9136 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9137 KFR2=0
9138 ELSE
9139 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9140 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9141 MINT(72)=2
9142 MINT(74)=KFR2
9143 VINT(75)=TAUR2
9144 VINT(76)=GAMR2
9145 ENDIF
9146C...3 resonances at work: rho, omega, a
9147 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9148 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9149 MINT(72)=IRES
9150 IF(IRES.GE.1) THEN
9151 VINT(73)=XMAS(1)**2/VINT(2)
9152 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9153 TAUR1=VINT(73)
9154 GAMR1=VINT(74)
9155 KFR1=1
9156 ENDIF
9157 IF(IRES.GE.2) THEN
9158 VINT(75)=XMAS(2)**2/VINT(2)
9159 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9160 TAUR2=VINT(75)
9161 GAMR2=VINT(76)
9162 KFR2=2
9163 ENDIF
9164 IF(IRES.EQ.3) THEN
9165 VINT(77)=XMAS(3)**2/VINT(2)
9166 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9167 TAUR3=VINT(77)
9168 GAMR3=VINT(78)
9169 KFR3=3
9170 ENDIF
9171C...Charged current: rho+- and a+-
9172 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9173 MINT(72)=IRES
9174 IF(JRES.GE.1) THEN
9175 VINT(73)=YMAS(1)**2/VINT(2)
9176 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9177 KFR1=1
9178 TAUR1=VINT(73)
9179 GAMR1=VINT(74)
9180 ENDIF
9181 IF(JRES.GE.2) THEN
9182 VINT(75)=YMAS(2)**2/VINT(2)
9183 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9184 KFR2=2
9185 TAUR2=VINT(73)
9186 GAMR2=VINT(74)
9187 ENDIF
9188 KFR3=0
9189 ENDIF
9190 IF(ISUB.NE.141) THEN
9191 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9192
9193 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9194 MINT(72)=2
9195 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9196 MINT(72)=2
9197 MINT(74)=KFR3
9198 VINT(75)=TAUR3
9199 VINT(76)=GAMR3
9200 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9201 MINT(72)=2
9202 MINT(73)=KFR2
9203 VINT(73)=TAUR2
9204 VINT(74)=GAMR2
9205 MINT(74)=KFR3
9206 VINT(75)=TAUR3
9207 VINT(76)=GAMR3
9208 ELSEIF(KFR1.NE.0) THEN
9209 MINT(72)=1
9210 ELSEIF(KFR2.NE.0) THEN
9211 MINT(72)=1
9212 MINT(73)=KFR2
9213 VINT(73)=TAUR2
9214 VINT(74)=GAMR2
9215 ELSEIF(KFR3.NE.0) THEN
9216 MINT(72)=1
9217 MINT(73)=KFR3
9218 VINT(73)=TAUR3
9219 VINT(74)=GAMR3
9220 ELSE
9221 MINT(72)=0
9222 ENDIF
9223 ELSE
9224 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9225
9226 ELSEIF(KFR2.NE.0) THEN
9227 KFR1=KFR2
9228 TAUR1=TAUR2
9229 GAMR1=GAMR2
9230 MINT(72)=1
9231 MINT(73)=KFR1
9232 VINT(73)=TAUR1
9233 VINT(74)=GAMR1
9234 KFR2=0
9235 ELSE
9236 MINT(72)=0
9237 ENDIF
9238 ENDIF
9239 ENDIF
9240
9241C...Find product masses and minimum pT of process,
9242C...optionally with broadening according to a truncated Breit-Wigner.
9243 VINT(63)=0D0
9244 VINT(64)=0D0
9245 MINT(71)=0
9246 VINT(71)=CKIN(3)
9247 IF(MINT(82).GE.2) VINT(71)=0D0
9248 VINT(80)=1D0
9249 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9250 NBW=0
9251 DO 160 I=1,2
9252 PMMN(I)=0D0
9253 IF(KFPR(ISUB,I).EQ.0) THEN
9254 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9255 & PARP(41)) THEN
9256 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9257 ELSE
9258 NBW=NBW+1
9259C...This prevents SUSY/t particles from becoming too light.
9260 KFLW=KFPR(ISUB,I)
9261 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9262 KCW=PYCOMP(KFLW)
9263 PMMN(I)=PMAS(KCW,1)
9264 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9265 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9266 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9267 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9268 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9269 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9270 PMMN(I)=MIN(PMMN(I),PMSUM)
9271 ENDIF
9272 150 CONTINUE
9273 ELSEIF(KFLW.EQ.6) THEN
9274 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9275 ENDIF
9276 ENDIF
9277 160 CONTINUE
9278 IF(NBW.GE.1) THEN
9279 CKIN41=CKIN(41)
9280 CKIN43=CKIN(43)
9281 CKIN(41)=MAX(PMMN(1),CKIN(41))
9282 CKIN(43)=MAX(PMMN(2),CKIN(43))
9283 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9284 CKIN(41)=CKIN41
9285 CKIN(43)=CKIN43
9286 IF(MINT(51).EQ.1) THEN
9287 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9288 IF(MFAIL.EQ.1) THEN
9289 MSTI(61)=1
9290 RETURN
9291 ENDIF
9292 GOTO 100
9293 ENDIF
9294 VINT(63)=PQM3**2
9295 VINT(64)=PQM4**2
9296 ENDIF
9297 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9298 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9299 ENDIF
9300
9301C...Prepare for additional variable choices in 2 -> 3.
9302 IF(ISTSB.EQ.5) THEN
9303 VINT(201)=0D0
9304 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9305 VINT(206)=VINT(201)
9306 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9307 VINT(204)=PMAS(23,1)
9308 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9309 & VINT(204)=PMAS(24,1)
9310 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9311 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9312 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9313 & VINT(204)=VINT(201)
9314 VINT(209)=VINT(204)
9315 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9316 ENDIF
9317
9318C...Select incoming VDM particle (rho/omega/phi/J/psi).
9319 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9320 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9321 VRN=PYR(0)*SIGT(0,0,5)
9322 IF(MINT(101).LE.1) THEN
9323 I1MN=0
9324 I1MX=0
9325 ELSE
9326 I1MN=1
9327 I1MX=MINT(101)
9328 ENDIF
9329 IF(MINT(102).LE.1) THEN
9330 I2MN=0
9331 I2MX=0
9332 ELSE
9333 I2MN=1
9334 I2MX=MINT(102)
9335 ENDIF
9336 DO 180 I1=I1MN,I1MX
9337 KFV1=110*I1+3
9338 DO 170 I2=I2MN,I2MX
9339 KFV2=110*I2+3
9340 VRN=VRN-SIGT(I1,I2,5)
9341 IF(VRN.LE.0D0) GOTO 190
9342 170 CONTINUE
9343 180 CONTINUE
9344 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9345 IF(MINT(102).GE.2) MINT(104)=KFV2
9346 ENDIF
9347
9348 IF(ISTSB.EQ.0) THEN
9349C...Elastic scattering or single or double diffractive scattering.
9350
9351C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9352 MINT(103)=MINT(11)
9353 MINT(104)=MINT(12)
9354 PMM(1)=VINT(3)
9355 PMM(2)=VINT(4)
9356 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9357 JJ=ISUB-90
9358 VRN=PYR(0)*SIGT(0,0,JJ)
9359 IF(MINT(101).LE.1) THEN
9360 I1MN=0
9361 I1MX=0
9362 ELSE
9363 I1MN=1
9364 I1MX=MINT(101)
9365 ENDIF
9366 IF(MINT(102).LE.1) THEN
9367 I2MN=0
9368 I2MX=0
9369 ELSE
9370 I2MN=1
9371 I2MX=MINT(102)
9372 ENDIF
9373 DO 210 I1=I1MN,I1MX
9374 KFV1=110*I1+3
9375 DO 200 I2=I2MN,I2MX
9376 KFV2=110*I2+3
9377 VRN=VRN-SIGT(I1,I2,JJ)
9378 IF(VRN.LE.0D0) GOTO 220
9379 200 CONTINUE
9380 210 CONTINUE
9381 220 IF(MINT(101).GE.2) THEN
9382 MINT(103)=KFV1
9383 PMM(1)=PYMASS(KFV1)
9384 ENDIF
9385 IF(MINT(102).GE.2) THEN
9386 MINT(104)=KFV2
9387 PMM(2)=PYMASS(KFV2)
9388 ENDIF
9389 ENDIF
9390 VINT(67)=PMM(1)
9391 VINT(68)=PMM(2)
9392
9393C...Select mass for GVMD states (rejecting previous assignment).
9394 Q0S=4D0*PARP(15)**2
9395 Q1S=4D0*VINT(154)**2
9396 LOOP3=0
9397 230 LOOP3=LOOP3+1
9398 DO 240 JT=1,2
9399 IF(MINT(106+JT).EQ.3) THEN
9400 PS=VINT(2+JT)**2
9401 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9402 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9403 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9404 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9405 ENDIF
9406 240 CONTINUE
9407 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9408 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9409 & GOTO 230
9410 GOTO 100
9411 ENDIF
9412
9413C...Side/sides of diffractive system.
9414 MINT(17)=0
9415 MINT(18)=0
9416 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9417 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9418
9419C...Find masses of particles and minimal masses of diffractive states.
9420 DO 250 JT=1,2
9421 PDIF(JT)=PMM(JT)
9422 VINT(68+JT)=PDIF(JT)
9423 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9424 250 CONTINUE
9425 SH=VINT(2)
9426 SQM1=PMM(1)**2
9427 SQM2=PMM(2)**2
9428 SQM3=PDIF(1)**2
9429 SQM4=PDIF(2)**2
9430 SMRES1=(PMM(1)+PMRC)**2
9431 SMRES2=(PMM(2)+PMRC)**2
9432
9433C...Find elastic slope and lower limit diffractive slope.
9434 IHA=MAX(2,IABS(MINT(103))/110)
9435 IF(IHA.GE.5) IHA=1
9436 IHB=MAX(2,IABS(MINT(104))/110)
9437 IF(IHB.GE.5) IHB=1
9438 IF(ISUB.EQ.91) THEN
9439 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9440 ELSEIF(ISUB.EQ.92) THEN
9441 BMN=MAX(2D0,2D0*BHAD(IHB))
9442 ELSEIF(ISUB.EQ.93) THEN
9443 BMN=MAX(2D0,2D0*BHAD(IHA))
9444 ELSEIF(ISUB.EQ.94) THEN
9445 BMN=2D0*ALP*4D0
9446 ENDIF
9447
9448C...Determine maximum possible t range and coefficient of generation.
9449 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9450 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9451 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9452 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9453 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9454 & (SQM1*SQM4-SQM2*SQM3)/SH
9455 THL=-0.5D0*(THA+THB)
9456 THU=THC/THL
9457 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9458
9459C...Select diffractive mass/masses according to dm^2/m^2.
9460 LOOP3=0
9461 260 LOOP3=LOOP3+1
9462 DO 270 JT=1,2
9463 IF(MINT(16+JT).EQ.0) THEN
9464 PDIF(2+JT)=PDIF(JT)
9465 ELSE
9466 PMMIN=PDIF(JT)
9467 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9468 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9469 ENDIF
9470 270 CONTINUE
9471 SQM3=PDIF(3)**2
9472 SQM4=PDIF(4)**2
9473
9474C..Additional mass factors, including resonance enhancement.
9475 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9476 IF(LOOP3.LT.100) GOTO 260
9477 GOTO 100
9478 ENDIF
9479 IF(ISUB.EQ.92) THEN
9480 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9481 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9482 ELSEIF(ISUB.EQ.93) THEN
9483 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9484 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9485 ELSEIF(ISUB.EQ.94) THEN
9486 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9487 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9488 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9489 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9490 ENDIF
9491
9492C...Select t according to exp(Bmn*t) and correct to right slope.
9493 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9494 IF(ISUB.GE.92) THEN
9495 IF(ISUB.EQ.92) THEN
9496 BADD=2D0*ALP*LOG(SH/SQM3)
9497 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9498 ELSEIF(ISUB.EQ.93) THEN
9499 BADD=2D0*ALP*LOG(SH/SQM4)
9500 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9501 ELSEIF(ISUB.EQ.94) THEN
9502 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9503 ENDIF
9504 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9505 ENDIF
9506
9507C...Check whether m^2 and t choices are consistent.
9508 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9509 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9510 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9511 IF(THB.LE.1D-8) GOTO 260
9512 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9513 & (SQM1*SQM4-SQM2*SQM3)/SH
9514 THLM=-0.5D0*(THA+THB)
9515 THUM=THC/THLM
9516 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9517
9518C...Information to output.
9519 VINT(21)=1D0
9520 VINT(22)=0D0
9521 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9522 VINT(45)=TH
9523 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9524 VINT(63)=PDIF(3)**2
9525 VINT(64)=PDIF(4)**2
9526 VINT(283)=PMM(1)**2/4D0
9527 VINT(284)=PMM(2)**2/4D0
9528
9529C...Note: in the following, by In is meant the integral over the
9530C...quantity multiplying coefficient cn.
9531C...Choose tau according to h1(tau)/tau, where
9532C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9533C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9534C...I1/I5*c5*1/(tau+tau_R') +
9535C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9536C...I1/I7*c7*tau/(1.-tau), and
9537C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9538 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9539 CALL PYKLIM(1)
9540 IF(MINT(51).NE.0) THEN
9541 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9542 IF(MFAIL.EQ.1) THEN
9543 MSTI(61)=1
9544 RETURN
9545 ENDIF
9546 GOTO 100
9547 ENDIF
9548 RTAU=PYR(0)
9549 MTAU=1
9550 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9551 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9552 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9553 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9554 & MTAU=5
9555 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9556 & COEF(ISUB,5)) MTAU=6
9557 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9558 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9559C...Additional check to handle techni-processes with extra resonance
9560C....Only modify tau treatment
9561 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9562 & THEN
9563 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9564 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9565 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9566 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9567 & +COEFX(ISUB,1)) MTAU=9
9568 ENDIF
9569 CALL PYKMAP(1,MTAU,PYR(0))
9570
9571C...2 -> 3, 4 processes:
9572C...Choose tau' according to h4(tau,tau')/tau', where
9573C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9574C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9575 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9576 CALL PYKLIM(4)
9577 IF(MINT(51).NE.0) THEN
9578 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9579 IF(MFAIL.EQ.1) THEN
9580 MSTI(61)=1
9581 RETURN
9582 ENDIF
9583 GOTO 100
9584 ENDIF
9585 RTAUP=PYR(0)
9586 MTAUP=1
9587 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9588 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9589 CALL PYKMAP(4,MTAUP,PYR(0))
9590 ENDIF
9591
9592C...Choose y* according to h2(y*), where
9593C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9594C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9595C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9596C...and c1 + c2 + c3 + c4 + c5 = 1.
9597 CALL PYKLIM(2)
9598 IF(MINT(51).NE.0) THEN
9599 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9600 IF(MFAIL.EQ.1) THEN
9601 MSTI(61)=1
9602 RETURN
9603 ENDIF
9604 GOTO 100
9605 ENDIF
9606 RYST=PYR(0)
9607 MYST=1
9608 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9609 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9610 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9611 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9612 & COEF(ISUB,11)) MYST=5
9613 CALL PYKMAP(2,MYST,PYR(0))
9614
9615C...2 -> 2 processes:
9616C...Choose cos(theta-hat) (cth) according to h3(cth), where
9617C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9618C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9619C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9620C...and c0 + c1 + c2 + c3 + c4 = 1.
9621 CALL PYKLIM(3)
9622 IF(MINT(51).NE.0) THEN
9623 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9624 IF(MFAIL.EQ.1) THEN
9625 MSTI(61)=1
9626 RETURN
9627 ENDIF
9628 GOTO 100
9629 ENDIF
9630 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9631 RCTH=PYR(0)
9632 MCTH=1
9633 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9634 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9635 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9636 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9637 & COEF(ISUB,16)) MCTH=5
9638 CALL PYKMAP(3,MCTH,PYR(0))
9639 ENDIF
9640
9641C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9642 IF(ISTSB.EQ.5) THEN
9643 CALL PYKMAP(5,0,0D0)
9644 IF(MINT(51).NE.0) THEN
9645 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9646 IF(MFAIL.EQ.1) THEN
9647 MSTI(61)=1
9648 RETURN
9649 ENDIF
9650 GOTO 100
9651 ENDIF
9652 ENDIF
9653
9654C...DIS as f + gamma* -> f process: set dummy values.
9655 ELSEIF(ISTSB.EQ.8) THEN
9656 VINT(21)=0.9D0
9657 VINT(22)=0D0
9658 VINT(23)=0D0
9659 VINT(47)=0D0
9660 VINT(48)=0D0
9661
9662C...Low-pT or multiple interactions (first semihard interaction).
9663 ELSEIF(ISTSB.EQ.9) THEN
9664 IF(MINT(35).LE.1) CALL PYMULT(3)
9665 IF(MINT(35).GE.2) CALL PYMIGN(3)
9666 ISUB=MINT(1)
9667
9668C...Study user-defined process: kinematics plus weight.
9669 ELSEIF(ISTSB.EQ.11) THEN
9670 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9671 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9672 MSTI(51)=0
9673 IF(NUP.LE.0) THEN
9674 MINT(51)=2
9675 MSTI(51)=1
9676 IF(MINT(82).EQ.1) THEN
9677 NGEN(0,1)=NGEN(0,1)-1
9678 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9679 ENDIF
9680 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9681 RETURN
9682 ENDIF
9683
9684C...Extract cross section event weight.
9685 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9686 SIGS=1D-9*XWGTUP
9687 ELSE
9688 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9689 ENDIF
9690 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9691 VINT(97)=SIGN(1D0,XWGTUP)
9692 ELSE
9693 VINT(97)=1D-9*XWGTUP
9694 ENDIF
9695
9696C...Construct 'trivial' kinematical variables needed.
9697 KFL1=IDUP(1)
9698 KFL2=IDUP(2)
9699 VINT(41)=PUP(4,1)/EBMUP(1)
9700 VINT(42)=PUP(4,2)/EBMUP(2)
9701 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
9702 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
9703 & '(listing follows):')
9704 CALL PYLIST(7)
9705 ENDIF
9706 VINT(21)=VINT(41)*VINT(42)
9707 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9708 VINT(44)=VINT(21)*VINT(2)
9709 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9710 VINT(55)=SCALUP
9711 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9712 VINT(56)=VINT(55)**2
9713 VINT(57)=AQEDUP
9714 VINT(58)=AQCDUP
9715
9716C...Construct other kinematical variables needed (approximately).
9717 VINT(23)=0D0
9718 VINT(26)=VINT(21)
9719 VINT(45)=-0.5D0*VINT(44)
9720 VINT(46)=-0.5D0*VINT(44)
9721 VINT(49)=VINT(43)
9722 VINT(50)=VINT(44)
9723 VINT(51)=VINT(55)
9724 VINT(52)=VINT(56)
9725 VINT(53)=VINT(55)
9726 VINT(54)=VINT(56)
9727 VINT(25)=0D0
9728 VINT(48)=0D0
9729 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9730 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9731 DO 280 IUP=3,NUP
9732 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9733 & '(PYRAND:) unacceptable ISTUP code for particles')
9734 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9735 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9736 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9737 & PUP(2,IUP)**2)
9738 280 CONTINUE
9739 VINT(47)=SQRT(VINT(48))
9740 ENDIF
9741
9742C...Choose azimuthal angle.
9743 VINT(24)=0D0
9744 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9745
9746C...Check against user cuts on kinematics at parton level.
9747 MINT(51)=0
9748 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9749 IF(MINT(51).NE.0) THEN
9750 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9751 IF(MFAIL.EQ.1) THEN
9752 MSTI(61)=1
9753 RETURN
9754 ENDIF
9755 GOTO 100
9756 ENDIF
9757 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9758 MCUT=0
9759 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9760 & CALL PYKCUT(MCUT)
9761 IF(MCUT.NE.0) THEN
9762 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9763 IF(MFAIL.EQ.1) THEN
9764 MSTI(61)=1
9765 RETURN
9766 ENDIF
9767 GOTO 100
9768 ENDIF
9769 ENDIF
9770
9771C...Calculate differential cross-section for different subprocesses.
9772 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9773 SIGSOR=SIGS
9774 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9775
9776C...Multiply cross section by lepton -> photon flux factor.
9777 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9778 SIGS=WTGAGA*SIGS
9779 DO 290 ICHN=1,NCHN
9780 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9781 290 CONTINUE
9782 SIGLPT=WTGAGA*SIGLPT
9783 ENDIF
9784
9785C...Multiply cross-section by user-defined weights.
9786 IF(MSTP(173).EQ.1) THEN
9787 SIGS=PARP(173)*SIGS
9788 DO 300 ICHN=1,NCHN
9789 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9790 300 CONTINUE
9791 SIGLPT=PARP(173)*SIGLPT
9792 ENDIF
9793 WTXS=1D0
9794 SIGSWT=SIGS
9795 VINT(99)=1D0
9796 VINT(100)=1D0
9797 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9798 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9799 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9800 SIGSWT=WTXS*SIGS
9801 VINT(99)=WTXS
9802 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9803 ENDIF
9804
9805C...Calculations for Monte Carlo estimate of all cross-sections.
9806 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9807 IF(MSTP(142).LE.1) THEN
9808 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9809 ELSE
9810 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9811 ENDIF
9812 ELSEIF(MINT(82).EQ.1) THEN
9813 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9814 ENDIF
9815 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9816 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9817
9818C...Multiple interactions: store results of cross-section calculation.
9819 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9820 VINT(153)=SIGSOR
9821 IF(MINT(35).LE.1) CALL PYMULT(4)
9822 IF(MINT(35).GE.2) CALL PYMIGN(4)
9823 ENDIF
9824
9825C...Ratio of actual to maximum cross section.
9826 IF(ISTSB.NE.11) THEN
9827 VIOL=SIGSWT/XSEC(ISUB,1)
9828 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9829 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9830 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9831 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9832 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9833 ELSE
9834 VIOL=1D0
9835 ENDIF
9836
9837C...Check that weight not negative.
9838 IF(MSTP(123).LE.0) THEN
9839 IF(VIOL.LT.-1D-3) THEN
9840 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9841 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9842 & VINT(22),VINT(23),VINT(26)
9843 CALL PYSTOP(2)
9844 ENDIF
9845 ELSE
9846 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9847 VINT(109)=VIOL
9848 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9849 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9850 & VINT(22),VINT(23),VINT(26)
9851 ENDIF
9852 ENDIF
9853
9854C...Weighting using estimate of maximum of differential cross-section.
9855 RATND=1D0
9856 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9857 IF(VIOL.LT.PYR(0)) THEN
9858 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9859 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9860 GOTO 100
9861 ENDIF
9862 ELSEIF(MFAIL.EQ.0) THEN
9863 RATND=SIGLPT/XSEC(95,1)
9864 VIOL=VIOL/RATND
9865 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9866 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9867 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9868 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9869 ISUB=0
9870 GOTO 100
9871 ENDIF
9872 IF(VIOL.LT.PYR(0)) THEN
9873 GOTO 140
9874 ENDIF
9875 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9876 IF(VIOL.LT.PYR(0)) THEN
9877 MSTI(61)=1
9878 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9879 RETURN
9880 ENDIF
9881 ELSE
9882 RATND=SIGLPT/XSEC(95,1)
9883 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9884 MSTI(61)=1
9885 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9886 RETURN
9887 ENDIF
9888 VIOL=VIOL/RATND
9889 IF(VIOL.LT.PYR(0)) THEN
9890 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9891 GOTO 100
9892 ENDIF
9893 ENDIF
9894
9895C...Check for possible violation of estimated maximum of differential
9896C...cross-section used in weighting.
9897 IF(MSTP(123).LE.0) THEN
9898 IF(VIOL.GT.1D0) THEN
9899 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9900 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9901 & VINT(22),VINT(23),VINT(26)
9902 CALL PYSTOP(2)
9903 ENDIF
9904 ELSEIF(MSTP(123).EQ.1) THEN
9905 IF(VIOL.GT.VINT(108)) THEN
9906 VINT(108)=VIOL
9907 IF(VIOL.GT.1.0001D0) THEN
9908 MINT(10)=1
9909 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9910 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9911 & VINT(22),VINT(23),VINT(26)
9912 ENDIF
9913 ENDIF
9914 ELSEIF(VIOL.GT.VINT(108)) THEN
9915 VINT(108)=VIOL
9916 IF(VIOL.GT.1D0) THEN
9917 MINT(10)=1
9918 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9919 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9920 & THEN
9921 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9922 IF(KFPR(ISUB,1).LE.9) THEN
9923 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9924 & XMAXUP(KFPR(ISUB,1))
9925 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9926 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9927 & XMAXUP(KFPR(ISUB,1))
9928 ELSE
9929 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9930 & XMAXUP(KFPR(ISUB,1))
9931 ENDIF
9932 ENDIF
9933 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9934 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9935 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9936 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9937 & XSEC(0,1)=XSEC(0,1)+XDIF
9938 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9939 & VINT(22),VINT(23),VINT(26)
9940 IF(ISUB.LE.9) THEN
9941 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9942 ELSEIF(ISUB.LE.99) THEN
9943 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9944 ELSE
9945 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9946 ENDIF
9947 ENDIF
9948 VINT(108)=1D0
9949 ENDIF
9950 ENDIF
9951
9952C...Multiple interactions: choose impact parameter (if not already done).
9953 IF(MINT(39).EQ.0) VINT(148)=1D0
9954 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9955 &MSTP(82).GE.3) THEN
9956 IF(MINT(35).LE.1) CALL PYMULT(5)
9957 IF(MINT(35).GE.2) CALL PYMIGN(5)
9958 IF(VINT(150).LT.PYR(0)) THEN
9959 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9960 IF(MFAIL.EQ.1) THEN
9961 MSTI(61)=1
9962 RETURN
9963 ENDIF
9964 GOTO 100
9965 ENDIF
9966 ENDIF
9967 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9968 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9969 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9970 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9971 ENDIF
9972 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9973
9974C...Choose flavour of reacting partons (and subprocess).
9975 IF(ISTSB.GE.11) GOTO 320
9976 RSIGS=SIGS*PYR(0)
9977 QT2=VINT(48)
9978 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9979 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9980 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9981 &PYR(0).GT.RQQBAR)) THEN
9982 DO 310 ICHN=1,NCHN
9983 KFL1=ISIG(ICHN,1)
9984 KFL2=ISIG(ICHN,2)
9985 MINT(2)=ISIG(ICHN,3)
9986 RSIGS=RSIGS-SIGH(ICHN)
9987 IF(RSIGS.LE.0D0) GOTO 320
9988 310 CONTINUE
9989
9990C...Multiple interactions: choose qqbar preferentially at small pT.
9991 ELSEIF(ISUB.EQ.96) THEN
9992 MINT(105)=MINT(103)
9993 MINT(109)=MINT(107)
9994 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9995 MINT(105)=MINT(104)
9996 MINT(109)=MINT(108)
9997 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
9998 MINT(1)=11
9999 MINT(2)=1
10000 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10001
10002C...Low-pT: choose string drawing configuration.
10003 ELSE
10004 KFL1=21
10005 KFL2=21
10006 RSIGS=6D0*PYR(0)
10007 MINT(2)=1
10008 IF(RSIGS.GT.1D0) MINT(2)=2
10009 IF(RSIGS.GT.2D0) MINT(2)=3
10010 ENDIF
10011
10012C...Reassign QCD process. Partons before initial state radiation.
10013 320 IF(MINT(2).GT.10) THEN
10014 MINT(1)=MINT(2)/10
10015 MINT(2)=MOD(MINT(2),10)
10016 ENDIF
10017 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10018 &NGEN(MINT(1),2)+1
10019 MINT(15)=KFL1
10020 MINT(16)=KFL2
10021 MINT(13)=MINT(15)
10022 MINT(14)=MINT(16)
10023 VINT(141)=VINT(41)
10024 VINT(142)=VINT(42)
10025 VINT(151)=0D0
10026 VINT(152)=0D0
10027
10028C...Calculate x value of photon for parton inside photon inside e.
10029 DO 350 JT=1,2
10030 MINT(18+JT)=0
10031 VINT(154+JT)=0D0
10032 MSPLI=0
10033 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10034 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10035 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10036 IF(MSPLI.EQ.2) THEN
10037 KFLH=MINT(14+JT)
10038 XHRD=VINT(140+JT)
10039 Q2HRD=VINT(54)
10040 MINT(105)=MINT(102+JT)
10041 MINT(109)=MINT(106+JT)
10042 VINT(120)=VINT(2+JT)
10043 IF(MSTP(57).LE.1) THEN
10044 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10045 ELSE
10046 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10047 ENDIF
10048 WTMX=4D0*XPQ(KFLH)
10049 IF(MSTP(13).EQ.2) THEN
10050 Q2PMS=Q2HRD/PMAS(11,1)**2
10051 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10052 ENDIF
10053 330 XE=XHRD**PYR(0)
10054 XG=MIN(1D0-1D-10,XHRD/XE)
10055 IF(MSTP(57).LE.1) THEN
10056 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10057 ELSE
10058 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10059 ENDIF
10060 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10061 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10062 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10063 MINT(18+JT)=1
10064 VINT(154+JT)=XE
10065 DO 340 KFLS=-25,25
10066 XSFX(JT,KFLS)=XPQ(KFLS)
10067 340 CONTINUE
10068 ENDIF
10069 350 CONTINUE
10070
10071C...Pick scale where photon is resolved.
10072 Q0S=PARP(15)**2
10073 Q1S=VINT(154)**2
10074 VINT(283)=0D0
10075 IF(MINT(107).EQ.3) THEN
10076 IF(MSTP(66).EQ.1) THEN
10077 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10078 ELSEIF(MSTP(66).EQ.2) THEN
10079 PS=VINT(3)**2
10080 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10081 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10082 Q2INT=SQRT(Q0S*Q2EFF)
10083 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10084 ELSEIF(MSTP(66).EQ.3) THEN
10085 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10086 ELSEIF(MSTP(66).GE.4) THEN
10087 PS=0.25D0*VINT(3)**2
10088 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10089 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10090 ENDIF
10091 ENDIF
10092 VINT(284)=0D0
10093 IF(MINT(108).EQ.3) THEN
10094 IF(MSTP(66).EQ.1) THEN
10095 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10096 ELSEIF(MSTP(66).EQ.2) THEN
10097 PS=VINT(4)**2
10098 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10099 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10100 Q2INT=SQRT(Q0S*Q2EFF)
10101 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10102 ELSEIF(MSTP(66).EQ.3) THEN
10103 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10104 ELSEIF(MSTP(66).GE.4) THEN
10105 PS=0.25D0*VINT(4)**2
10106 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10107 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10108 ENDIF
10109 ENDIF
10110 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10111
10112C...Format statements for differential cross-section maximum violations.
10113 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10114 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10115 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10116 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10117 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10118 &'in event',1X,I7)
10119 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10120 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10121 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10122 &'in event',1X,I7)
10123 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10124 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10125 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10126 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10127 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10128 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10129
10130 RETURN
10131 END
10132
10133C*********************************************************************
10134
10135C...PYSCAT
10136C...Finds outgoing flavours and event type; sets up the kinematics
10137C...and colour flow of the hard scattering
10138
10139 SUBROUTINE PYSCAT
10140
10141C...Double precision and integer declarations
10142 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10143 IMPLICIT INTEGER(I-N)
10144 INTEGER PYK,PYCHGE,PYCOMP
10145C...Parameter statement to help give large particle numbers.
10146 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10147 &KEXCIT=4000000,KDIMEN=5000000)
10148C...Parameter statement for maximum size of showers.
10149 PARAMETER (MAXNUR=1000)
10150
10151C...User process event common block.
10152 INTEGER MAXNUP
10153 PARAMETER (MAXNUP=500)
10154 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10155 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10156 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10157 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10158 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10159 SAVE /HEPEUP/
10160
10161C...Commonblocks.
10162 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10163 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10164 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10165 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10166 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10167 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10168 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10169 COMMON/PYINT1/MINT(400),VINT(400)
10170 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10171 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10172 COMMON/PYINT4/MWID(500),WIDS(500,5)
10173 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10174 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10175 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10176 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10177 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10178 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10179 &/PYTCSM/
10180C...Local arrays and saved variables
10181 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10182 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10183 SAVE VINTSV
10184
10185C...Read out process
10186 ISUB=MINT(1)
10187 ISUBSV=ISUB
10188
10189C...Restore information for low-pT processes
10190 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10191 DO 100 J=41,66
10192 100 VINT(J)=VINTSV(J)
10193 ENDIF
10194
10195C...Convert H' or A process into equivalent H one
10196 IHIGG=1
10197 KFHIGG=25
10198 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10199 &ISUB.LE.190)) THEN
10200 IHIGG=2
10201 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10202 KFHIGG=33+IHIGG
10203 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10204 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10205 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10206 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10207 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10208 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10209 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10210 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10211 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10212 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10213 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10214 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10215 ENDIF
10216
10217 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10218
10219C...Convert bottomonium process into equivalent charmonium ones.
10220 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10221
10222C...Choice of subprocess, number of documentation lines
10223 IDOC=6+ISET(ISUB)
10224 IF(ISUB.EQ.95) IDOC=8
10225 IF(ISET(ISUB).EQ.5) IDOC=9
10226 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10227 MINT(3)=IDOC-6
10228 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10229 MINT(4)=IDOC
10230 IPU1=MINT(84)+1
10231 IPU2=MINT(84)+2
10232 IPU3=MINT(84)+3
10233 IPU4=MINT(84)+4
10234 IPU5=MINT(84)+5
10235 IPU6=MINT(84)+6
10236
10237C...Reset K, P and V vectors. Store incoming particles
10238 DO 120 JT=1,MSTP(126)+100
10239 I=MINT(83)+JT
10240 IF(I.GT.MSTU(4)) GOTO 120
10241 DO 110 J=1,5
10242 K(I,J)=0
10243 P(I,J)=0D0
10244 V(I,J)=0D0
10245 110 CONTINUE
10246 120 CONTINUE
10247 DO 140 JT=1,2
10248 I=MINT(83)+JT
10249 K(I,1)=21
10250 K(I,2)=MINT(10+JT)
10251 DO 130 J=1,5
10252 P(I,J)=VINT(285+5*JT+J)
10253 130 CONTINUE
10254 140 CONTINUE
10255 MINT(6)=2
10256 KFRES=0
10257
10258C...Store incoming partons in their CM-frame. Save pdf value.
10259 SH=VINT(44)
10260 SHR=SQRT(SH)
10261 SHP=VINT(26)*VINT(2)
10262 SHPR=SQRT(SHP)
10263 SHUSER=SHR
10264 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10265 DO 150 JT=1,2
10266 I=MINT(84)+JT
10267 K(I,1)=14
10268 K(I,2)=MINT(14+JT)
10269 K(I,3)=MINT(83)+2+JT
10270 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10271 P(I,4)=0.5D0*SHUSER
10272 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10273 150 CONTINUE
10274
10275C...Copy incoming partons to documentation lines
10276 DO 170 JT=1,2
10277 I1=MINT(83)+4+JT
10278 I2=MINT(84)+JT
10279 K(I1,1)=21
10280 K(I1,2)=K(I2,2)
10281 K(I1,3)=I1-2
10282 DO 160 J=1,5
10283 P(I1,J)=P(I2,J)
10284 160 CONTINUE
10285 170 CONTINUE
10286
10287C...Choose new quark/lepton flavour for relevant annihilation graphs
10288 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10289 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10290 IGLGA=21
10291 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10292 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10293 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10294 DO 190 I=1,MDCY(IGLGA,3)
10295 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10296 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10297 IF(RKFL.LE.0D0) GOTO 200
10298 190 CONTINUE
10299 200 CONTINUE
10300 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
10301 IF(KFLF.GE.4) GOTO 180
10302 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
10303 KFLF=4
10304 MINT(2)=MINT(2)-2
10305 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
10306 KFLF=5
10307 MINT(2)=MINT(2)-4
10308 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10309 & .AND.IABS(KFLF).GE.3) THEN
10310 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10311 & VINT(44)**2
10312 FACCIB=VINT(46)**2/RTCM(41)**4
10313 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10314 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10315 KFLF=5
10316 MINT(2)=1
10317 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10318 IF(KFLF.EQ.5) GOTO 180
10319 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10320 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10321 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10322 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10323 ENDIF
10324 ENDIF
10325
10326C...Final state flavours and colour flow: default values
10327 JS=1
10328 MINT(21)=MINT(15)
10329 MINT(22)=MINT(16)
10330 MINT(23)=0
10331 MINT(24)=0
10332 KCC=20
10333 KCS=ISIGN(1,MINT(15))
10334
10335 IF(ISET(ISUB).EQ.11) THEN
10336C...User-defined processes: find products
10337 MINT(3)=0
10338 DO 210 IUP=3,NUP
10339 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10340 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10341 MINT(21+IUP)=IDUP(IUP)
10342 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10343 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10344 ELSEIF(IDUP(IUP).EQ.0) THEN
10345 ELSE
10346 MINT(3)=MINT(3)+1
10347 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10348 ENDIF
10349 210 CONTINUE
10350
10351 ELSEIF(ISUB.LE.10) THEN
10352 IF(ISUB.EQ.1) THEN
10353C...f + fbar -> gamma*/Z0
10354 KFRES=23
10355
10356 ELSEIF(ISUB.EQ.2) THEN
10357C...f + fbar' -> W+/-
10358 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10359 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10360 KFRES=ISIGN(24,KCH1+KCH2)
10361
10362 ELSEIF(ISUB.EQ.3) THEN
10363C...f + fbar -> h0 (or H0, or A0)
10364 KFRES=KFHIGG
10365
10366 ELSEIF(ISUB.EQ.4) THEN
10367C...gamma + W+/- -> W+/-
10368
10369 ELSEIF(ISUB.EQ.5) THEN
10370C...Z0 + Z0 -> h0
10371 XH=SH/SHP
10372 MINT(21)=MINT(15)
10373 MINT(22)=MINT(16)
10374 PMQ(1)=PYMASS(MINT(21))
10375 PMQ(2)=PYMASS(MINT(22))
10376 220 JT=INT(1.5D0+PYR(0))
10377 ZMIN=2D0*PMQ(JT)/SHPR
10378 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10379 & (SHPR*(SHPR-PMQ(3-JT)))
10380 ZMAX=MIN(1D0-XH,ZMAX)
10381 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10382 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10383 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10384 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10385 IF(SQC1.LT.1D-8) GOTO 220
10386 C1=SQRT(SQC1)
10387 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10388 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10389 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10390 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10391 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10392 IF(SQC1.LT.1D-8) GOTO 220
10393 C1=SQRT(SQC1)
10394 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10395 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10396 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10397 PHIR=PARU(2)*PYR(0)
10398 CPHI=COS(PHIR)
10399 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10400 & SQRT(1D0-CTHE(2)**2)*CPHI
10401 Z1=2D0-Z(JT)
10402 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10403 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10404 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10405 & PMQ(3-JT)**2/SHP))
10406 ZMIN=2D0*PMQ(3-JT)/SHPR
10407 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10408 ZMAX=MIN(1D0-XH,ZMAX)
10409 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10410 KCC=22
10411 KFRES=25
10412
10413 ELSEIF(ISUB.EQ.6) THEN
10414C...Z0 + W+/- -> W+/-
10415
10416 ELSEIF(ISUB.EQ.7) THEN
10417C...W+ + W- -> Z0
10418
10419 ELSEIF(ISUB.EQ.8) THEN
10420C...W+ + W- -> h0
10421 XH=SH/SHP
10422 230 DO 260 JT=1,2
10423 I=MINT(14+JT)
10424 IA=IABS(I)
10425 IF(IA.LE.10) THEN
10426 RVCKM=VINT(180+I)*PYR(0)
10427 DO 240 J=1,MSTP(1)
10428 IB=2*J-1+MOD(IA,2)
10429 IPM=(5-ISIGN(1,I))/2
10430 IDC=J+MDCY(IA,2)+2
10431 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10432 MINT(20+JT)=ISIGN(IB,I)
10433 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10434 IF(RVCKM.LE.0D0) GOTO 250
10435 240 CONTINUE
10436 ELSE
10437 IB=2*((IA+1)/2)-1+MOD(IA,2)
10438 MINT(20+JT)=ISIGN(IB,I)
10439 ENDIF
10440 250 PMQ(JT)=PYMASS(MINT(20+JT))
10441 260 CONTINUE
10442 JT=INT(1.5D0+PYR(0))
10443 ZMIN=2D0*PMQ(JT)/SHPR
10444 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10445 & (SHPR*(SHPR-PMQ(3-JT)))
10446 ZMAX=MIN(1D0-XH,ZMAX)
10447 IF(ZMIN.GE.ZMAX) GOTO 230
10448 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10449 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10450 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10451 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10452 IF(SQC1.LT.1D-8) GOTO 230
10453 C1=SQRT(SQC1)
10454 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10455 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10456 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10457 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10458 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10459 IF(SQC1.LT.1D-8) GOTO 230
10460 C1=SQRT(SQC1)
10461 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10462 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10463 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10464 PHIR=PARU(2)*PYR(0)
10465 CPHI=COS(PHIR)
10466 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10467 & SQRT(1D0-CTHE(2)**2)*CPHI
10468 Z1=2D0-Z(JT)
10469 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10470 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10471 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10472 & PMQ(3-JT)**2/SHP))
10473 ZMIN=2D0*PMQ(3-JT)/SHPR
10474 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10475 ZMAX=MIN(1D0-XH,ZMAX)
10476 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10477 KCC=22
10478 KFRES=25
10479
10480 ELSEIF(ISUB.EQ.10) THEN
10481C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10482 IF(MINT(2).EQ.1) THEN
10483 KCC=22
10484 ELSE
10485C...W exchange: need to mix flavours according to CKM matrix
10486 DO 280 JT=1,2
10487 I=MINT(14+JT)
10488 IA=IABS(I)
10489 IF(IA.LE.10) THEN
10490 RVCKM=VINT(180+I)*PYR(0)
10491 DO 270 J=1,MSTP(1)
10492 IB=2*J-1+MOD(IA,2)
10493 IPM=(5-ISIGN(1,I))/2
10494 IDC=J+MDCY(IA,2)+2
10495 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10496 MINT(20+JT)=ISIGN(IB,I)
10497 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10498 IF(RVCKM.LE.0D0) GOTO 280
10499 270 CONTINUE
10500 ELSE
10501 IB=2*((IA+1)/2)-1+MOD(IA,2)
10502 MINT(20+JT)=ISIGN(IB,I)
10503 ENDIF
10504 280 CONTINUE
10505 KCC=22
10506 ENDIF
10507 ENDIF
10508
10509 ELSEIF(ISUB.LE.20) THEN
10510 IF(ISUB.EQ.11) THEN
10511C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10512 KCC=MINT(2)
10513 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10514
10515 ELSEIF(ISUB.EQ.12) THEN
10516C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10517 MINT(21)=ISIGN(KFLF,MINT(15))
10518 MINT(22)=-MINT(21)
10519 KCC=4
10520
10521 ELSEIF(ISUB.EQ.13) THEN
10522C...f + fbar -> g + g; th arbitrary
10523 MINT(21)=21
10524 MINT(22)=21
10525 KCC=MINT(2)+4
10526
10527 ELSEIF(ISUB.EQ.14) THEN
10528C...f + fbar -> g + gamma; th arbitrary
10529 IF(PYR(0).GT.0.5D0) JS=2
10530 MINT(20+JS)=21
10531 MINT(23-JS)=22
10532 KCC=17+JS
10533
10534 ELSEIF(ISUB.EQ.15) THEN
10535C...f + fbar -> g + Z0; th arbitrary
10536 IF(PYR(0).GT.0.5D0) JS=2
10537 MINT(20+JS)=21
10538 MINT(23-JS)=23
10539 KCC=17+JS
10540
10541 ELSEIF(ISUB.EQ.16) THEN
10542C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10543 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10544 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10545 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10546 MINT(20+JS)=21
10547 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10548 KCC=17+JS
10549
10550 ELSEIF(ISUB.EQ.17) THEN
10551C...f + fbar -> g + h0; th arbitrary
10552 IF(PYR(0).GT.0.5D0) JS=2
10553 MINT(20+JS)=21
10554 MINT(23-JS)=25
10555 KCC=17+JS
10556
10557 ELSEIF(ISUB.EQ.18) THEN
10558C...f + fbar -> gamma + gamma; th arbitrary
10559 MINT(21)=22
10560 MINT(22)=22
10561
10562 ELSEIF(ISUB.EQ.19) THEN
10563C...f + fbar -> gamma + Z0; th arbitrary
10564 IF(PYR(0).GT.0.5D0) JS=2
10565 MINT(20+JS)=22
10566 MINT(23-JS)=23
10567
10568 ELSEIF(ISUB.EQ.20) THEN
10569C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10570C...(p(fbar')-p(W+))**2
10571 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10572 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10573 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10574 MINT(20+JS)=22
10575 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10576 ENDIF
10577
10578 ELSEIF(ISUB.LE.30) THEN
10579 IF(ISUB.EQ.21) THEN
10580C...f + fbar -> gamma + h0; th arbitrary
10581 IF(PYR(0).GT.0.5D0) JS=2
10582 MINT(20+JS)=22
10583 MINT(23-JS)=25
10584
10585 ELSEIF(ISUB.EQ.22) THEN
10586C...f + fbar -> Z0 + Z0; th arbitrary
10587 MINT(21)=23
10588 MINT(22)=23
10589
10590 ELSEIF(ISUB.EQ.23) THEN
10591C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10592 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10593 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10594 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10595 MINT(20+JS)=23
10596 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10597
10598 ELSEIF(ISUB.EQ.24) THEN
10599C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10600 IF(PYR(0).GT.0.5D0) JS=2
10601 MINT(20+JS)=23
10602 MINT(23-JS)=KFHIGG
10603
10604 ELSEIF(ISUB.EQ.25) THEN
10605C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10606 MINT(21)=-ISIGN(24,MINT(15))
10607 MINT(22)=-MINT(21)
10608
10609 ELSEIF(ISUB.EQ.26) THEN
10610C...f + fbar' -> W+/- + h0 (or H0, or A0);
10611C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10612 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10613 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10614 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10615 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10616 MINT(23-JS)=KFHIGG
10617
10618 ELSEIF(ISUB.EQ.27) THEN
10619C...f + fbar -> h0 + h0
10620
10621 ELSEIF(ISUB.EQ.28) THEN
10622C...f + g -> f + g; th = (p(f)-p(f))**2
10623 IF(MINT(15).EQ.21) JS=2
10624 KCC=MINT(2)+6
10625 IF(MINT(15).EQ.21) KCC=KCC+2
10626 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10627 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10628
10629 ELSEIF(ISUB.EQ.29) THEN
10630C...f + g -> f + gamma; th = (p(f)-p(f))**2
10631 IF(MINT(15).EQ.21) JS=2
10632 MINT(23-JS)=22
10633 KCC=15+JS
10634 KCS=ISIGN(1,MINT(14+JS))
10635
10636 ELSEIF(ISUB.EQ.30) THEN
10637C...f + g -> f + Z0; th = (p(f)-p(f))**2
10638 IF(MINT(15).EQ.21) JS=2
10639 MINT(23-JS)=23
10640 KCC=15+JS
10641 KCS=ISIGN(1,MINT(14+JS))
10642 ENDIF
10643
10644 ELSEIF(ISUB.LE.40) THEN
10645 IF(ISUB.EQ.31) THEN
10646C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10647 IF(MINT(15).EQ.21) JS=2
10648 I=MINT(14+JS)
10649 IA=IABS(I)
10650 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10651 RVCKM=VINT(180+I)*PYR(0)
10652 DO 290 J=1,MSTP(1)
10653 IB=2*J-1+MOD(IA,2)
10654 IPM=(5-ISIGN(1,I))/2
10655 IDC=J+MDCY(IA,2)+2
10656 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10657 MINT(20+JS)=ISIGN(IB,I)
10658 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10659 IF(RVCKM.LE.0D0) GOTO 300
10660 290 CONTINUE
10661 300 KCC=15+JS
10662 KCS=ISIGN(1,MINT(14+JS))
10663
10664 ELSEIF(ISUB.EQ.32) THEN
10665C...f + g -> f + h0; th = (p(f)-p(f))**2
10666 IF(MINT(15).EQ.21) JS=2
10667 MINT(23-JS)=25
10668 KCC=15+JS
10669 KCS=ISIGN(1,MINT(14+JS))
10670
10671 ELSEIF(ISUB.EQ.33) THEN
10672C...f + gamma -> f + g; th=(p(f)-p(f))**2
10673 IF(MINT(15).EQ.22) JS=2
10674 MINT(23-JS)=21
10675 KCC=24+JS
10676 KCS=ISIGN(1,MINT(14+JS))
10677
10678 ELSEIF(ISUB.EQ.34) THEN
10679C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10680 IF(MINT(15).EQ.22) JS=2
10681 KCC=22
10682 KCS=ISIGN(1,MINT(14+JS))
10683
10684 ELSEIF(ISUB.EQ.35) THEN
10685C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10686 IF(MINT(15).EQ.22) JS=2
10687 MINT(23-JS)=23
10688 KCC=22
10689
10690 ELSEIF(ISUB.EQ.36) THEN
10691C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10692 IF(MINT(15).EQ.22) JS=2
10693 I=MINT(14+JS)
10694 IA=IABS(I)
10695 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10696 IF(IA.LE.10) THEN
10697 RVCKM=VINT(180+I)*PYR(0)
10698 DO 310 J=1,MSTP(1)
10699 IB=2*J-1+MOD(IA,2)
10700 IPM=(5-ISIGN(1,I))/2
10701 IDC=J+MDCY(IA,2)+2
10702 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10703 MINT(20+JS)=ISIGN(IB,I)
10704 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10705 IF(RVCKM.LE.0D0) GOTO 320
10706 310 CONTINUE
10707 ELSE
10708 IB=2*((IA+1)/2)-1+MOD(IA,2)
10709 MINT(20+JS)=ISIGN(IB,I)
10710 ENDIF
10711 320 KCC=22
10712
10713 ELSEIF(ISUB.EQ.37) THEN
10714C...f + gamma -> f + h0
10715
10716 ELSEIF(ISUB.EQ.38) THEN
10717C...f + Z0 -> f + g
10718
10719 ELSEIF(ISUB.EQ.39) THEN
10720C...f + Z0 -> f + gamma
10721
10722 ELSEIF(ISUB.EQ.40) THEN
10723C...f + Z0 -> f + Z0
10724 ENDIF
10725
10726 ELSEIF(ISUB.LE.50) THEN
10727 IF(ISUB.EQ.41) THEN
10728C...f + Z0 -> f' + W+/-
10729
10730 ELSEIF(ISUB.EQ.42) THEN
10731C...f + Z0 -> f + h0
10732
10733 ELSEIF(ISUB.EQ.43) THEN
10734C...f + W+/- -> f' + g
10735
10736 ELSEIF(ISUB.EQ.44) THEN
10737C...f + W+/- -> f' + gamma
10738
10739 ELSEIF(ISUB.EQ.45) THEN
10740C...f + W+/- -> f' + Z0
10741
10742 ELSEIF(ISUB.EQ.46) THEN
10743C...f + W+/- -> f' + W+/-
10744
10745 ELSEIF(ISUB.EQ.47) THEN
10746C...f + W+/- -> f' + h0
10747
10748 ELSEIF(ISUB.EQ.48) THEN
10749C...f + h0 -> f + g
10750
10751 ELSEIF(ISUB.EQ.49) THEN
10752C...f + h0 -> f + gamma
10753
10754 ELSEIF(ISUB.EQ.50) THEN
10755C...f + h0 -> f + Z0
10756 ENDIF
10757
10758 ELSEIF(ISUB.LE.60) THEN
10759 IF(ISUB.EQ.51) THEN
10760C...f + h0 -> f' + W+/-
10761
10762 ELSEIF(ISUB.EQ.52) THEN
10763C...f + h0 -> f + h0
10764
10765 ELSEIF(ISUB.EQ.53) THEN
10766C...g + g -> f + fbar; th arbitrary
10767 KCS=(-1)**INT(1.5D0+PYR(0))
10768 MINT(21)=ISIGN(KFLF,KCS)
10769 MINT(22)=-MINT(21)
10770 KCC=MINT(2)+10
10771
10772 ELSEIF(ISUB.EQ.54) THEN
10773C...g + gamma -> f + fbar; th arbitrary
10774 KCS=(-1)**INT(1.5D0+PYR(0))
10775 MINT(21)=ISIGN(KFLF,KCS)
10776 MINT(22)=-MINT(21)
10777 KCC=27
10778 IF(MINT(16).EQ.21) KCC=28
10779
10780 ELSEIF(ISUB.EQ.55) THEN
10781C...g + Z0 -> f + fbar
10782
10783 ELSEIF(ISUB.EQ.56) THEN
10784C...g + W+/- -> f + fbar'
10785
10786 ELSEIF(ISUB.EQ.57) THEN
10787C...g + h0 -> f + fbar
10788
10789 ELSEIF(ISUB.EQ.58) THEN
10790C...gamma + gamma -> f + fbar; th arbitrary
10791 KCS=(-1)**INT(1.5D0+PYR(0))
10792 MINT(21)=ISIGN(KFLF,KCS)
10793 MINT(22)=-MINT(21)
10794 KCC=21
10795
10796 ELSEIF(ISUB.EQ.59) THEN
10797C...gamma + Z0 -> f + fbar
10798
10799 ELSEIF(ISUB.EQ.60) THEN
10800C...gamma + W+/- -> f + fbar'
10801 ENDIF
10802
10803 ELSEIF(ISUB.LE.70) THEN
10804 IF(ISUB.EQ.61) THEN
10805C...gamma + h0 -> f + fbar
10806
10807 ELSEIF(ISUB.EQ.62) THEN
10808C...Z0 + Z0 -> f + fbar
10809
10810 ELSEIF(ISUB.EQ.63) THEN
10811C...Z0 + W+/- -> f + fbar'
10812
10813 ELSEIF(ISUB.EQ.64) THEN
10814C...Z0 + h0 -> f + fbar
10815
10816 ELSEIF(ISUB.EQ.65) THEN
10817C...W+ + W- -> f + fbar
10818
10819 ELSEIF(ISUB.EQ.66) THEN
10820C...W+/- + h0 -> f + fbar'
10821
10822 ELSEIF(ISUB.EQ.67) THEN
10823C...h0 + h0 -> f + fbar
10824
10825 ELSEIF(ISUB.EQ.68) THEN
10826C...g + g -> g + g; th arbitrary
10827 KCC=MINT(2)+12
10828 KCS=(-1)**INT(1.5D0+PYR(0))
10829
10830 ELSEIF(ISUB.EQ.69) THEN
10831C...gamma + gamma -> W+ + W-; th arbitrary
10832 MINT(21)=24
10833 MINT(22)=-24
10834 KCC=21
10835
10836 ELSEIF(ISUB.EQ.70) THEN
10837C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10838 IF(MINT(15).EQ.22) MINT(21)=23
10839 IF(MINT(16).EQ.22) MINT(22)=23
10840 KCC=21
10841 ENDIF
10842
10843 ELSEIF(ISUB.LE.80) THEN
10844 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10845C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10846 XH=SH/SHP
10847 MINT(21)=MINT(15)
10848 MINT(22)=MINT(16)
10849 PMQ(1)=PYMASS(MINT(21))
10850 PMQ(2)=PYMASS(MINT(22))
10851 330 JT=INT(1.5D0+PYR(0))
10852 ZMIN=2D0*PMQ(JT)/SHPR
10853 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10854 & (SHPR*(SHPR-PMQ(3-JT)))
10855 ZMAX=MIN(1D0-XH,ZMAX)
10856 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10857 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10858 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10859 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10860 IF(SQC1.LT.1D-8) GOTO 330
10861 C1=SQRT(SQC1)
10862 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10863 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10864 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10865 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10866 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10867 IF(SQC1.LT.1D-8) GOTO 330
10868 C1=SQRT(SQC1)
10869 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10870 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10871 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10872 PHIR=PARU(2)*PYR(0)
10873 CPHI=COS(PHIR)
10874 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10875 & SQRT(1D0-CTHE(2)**2)*CPHI
10876 Z1=2D0-Z(JT)
10877 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10878 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10879 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10880 & PMQ(3-JT)**2/SHP))
10881 ZMIN=2D0*PMQ(3-JT)/SHPR
10882 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10883 ZMAX=MIN(1D0-XH,ZMAX)
10884 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10885 KCC=22
10886
10887 ELSEIF(ISUB.EQ.73) THEN
10888C...Z0 + W+/- -> Z0 + W+/-
10889 JS=MINT(2)
10890 XH=SH/SHP
10891 340 JT=3-MINT(2)
10892 I=MINT(14+JT)
10893 IA=IABS(I)
10894 IF(IA.LE.10) THEN
10895 RVCKM=VINT(180+I)*PYR(0)
10896 DO 350 J=1,MSTP(1)
10897 IB=2*J-1+MOD(IA,2)
10898 IPM=(5-ISIGN(1,I))/2
10899 IDC=J+MDCY(IA,2)+2
10900 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10901 MINT(20+JT)=ISIGN(IB,I)
10902 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10903 IF(RVCKM.LE.0D0) GOTO 360
10904 350 CONTINUE
10905 ELSE
10906 IB=2*((IA+1)/2)-1+MOD(IA,2)
10907 MINT(20+JT)=ISIGN(IB,I)
10908 ENDIF
10909 360 PMQ(JT)=PYMASS(MINT(20+JT))
10910 MINT(23-JT)=MINT(17-JT)
10911 PMQ(3-JT)=PYMASS(MINT(23-JT))
10912 JT=INT(1.5D0+PYR(0))
10913 ZMIN=2D0*PMQ(JT)/SHPR
10914 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10915 & (SHPR*(SHPR-PMQ(3-JT)))
10916 ZMAX=MIN(1D0-XH,ZMAX)
10917 IF(ZMIN.GE.ZMAX) GOTO 340
10918 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10919 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10920 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10921 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10922 IF(SQC1.LT.1D-8) GOTO 340
10923 C1=SQRT(SQC1)
10924 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10925 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10926 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10927 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10928 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10929 IF(SQC1.LT.1D-8) GOTO 340
10930 C1=SQRT(SQC1)
10931 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10932 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10933 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10934 PHIR=PARU(2)*PYR(0)
10935 CPHI=COS(PHIR)
10936 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10937 & SQRT(1D0-CTHE(2)**2)*CPHI
10938 Z1=2D0-Z(JT)
10939 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10940 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10941 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10942 & PMQ(3-JT)**2/SHP))
10943 ZMIN=2D0*PMQ(3-JT)/SHPR
10944 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10945 ZMAX=MIN(1D0-XH,ZMAX)
10946 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10947 KCC=22
10948
10949 ELSEIF(ISUB.EQ.74) THEN
10950C...Z0 + h0 -> Z0 + h0
10951
10952 ELSEIF(ISUB.EQ.75) THEN
10953C...W+ + W- -> gamma + gamma
10954
10955 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10956C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10957 XH=SH/SHP
10958 370 DO 400 JT=1,2
10959 I=MINT(14+JT)
10960 IA=IABS(I)
10961 IF(IA.LE.10) THEN
10962 RVCKM=VINT(180+I)*PYR(0)
10963 DO 380 J=1,MSTP(1)
10964 IB=2*J-1+MOD(IA,2)
10965 IPM=(5-ISIGN(1,I))/2
10966 IDC=J+MDCY(IA,2)+2
10967 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10968 MINT(20+JT)=ISIGN(IB,I)
10969 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10970 IF(RVCKM.LE.0D0) GOTO 390
10971 380 CONTINUE
10972 ELSE
10973 IB=2*((IA+1)/2)-1+MOD(IA,2)
10974 MINT(20+JT)=ISIGN(IB,I)
10975 ENDIF
10976 390 PMQ(JT)=PYMASS(MINT(20+JT))
10977 400 CONTINUE
10978 JT=INT(1.5D0+PYR(0))
10979 ZMIN=2D0*PMQ(JT)/SHPR
10980 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10981 & (SHPR*(SHPR-PMQ(3-JT)))
10982 ZMAX=MIN(1D0-XH,ZMAX)
10983 IF(ZMIN.GE.ZMAX) GOTO 370
10984 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10985 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10986 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10987 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10988 IF(SQC1.LT.1D-8) GOTO 370
10989 C1=SQRT(SQC1)
10990 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10991 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10992 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10993 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10994 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10995 IF(SQC1.LT.1D-8) GOTO 370
10996 C1=SQRT(SQC1)
10997 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10998 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10999 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11000 PHIR=PARU(2)*PYR(0)
11001 CPHI=COS(PHIR)
11002 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11003 & SQRT(1D0-CTHE(2)**2)*CPHI
11004 Z1=2D0-Z(JT)
11005 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11006 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11007 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11008 & PMQ(3-JT)**2/SHP))
11009 ZMIN=2D0*PMQ(3-JT)/SHPR
11010 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11011 ZMAX=MIN(1D0-XH,ZMAX)
11012 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11013 KCC=22
11014
11015 ELSEIF(ISUB.EQ.78) THEN
11016C...W+/- + h0 -> W+/- + h0
11017
11018 ELSEIF(ISUB.EQ.79) THEN
11019C...h0 + h0 -> h0 + h0
11020
11021 ELSEIF(ISUB.EQ.80) THEN
11022C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11023 IF(MINT(15).EQ.22) JS=2
11024 I=MINT(14+JS)
11025 IA=IABS(I)
11026 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11027 IB=3-IA
11028 MINT(20+JS)=ISIGN(IB,I)
11029 KCC=22
11030 ENDIF
11031
11032 ELSEIF(ISUB.LE.90) THEN
11033 IF(ISUB.EQ.81) THEN
11034C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11035 MINT(21)=ISIGN(MINT(55),MINT(15))
11036 MINT(22)=-MINT(21)
11037 KCC=4
11038
11039 ELSEIF(ISUB.EQ.82) THEN
11040C...g + g -> Q + Qbar; th arbitrary
11041 KCS=(-1)**INT(1.5D0+PYR(0))
11042 MINT(21)=ISIGN(MINT(55),KCS)
11043 MINT(22)=-MINT(21)
11044 KCC=MINT(2)+10
11045
11046 ELSEIF(ISUB.EQ.83) THEN
11047C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11048 KFOLD=MINT(16)
11049 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11050 KFAOLD=IABS(KFOLD)
11051 IF(KFAOLD.GT.10) THEN
11052 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11053 ELSE
11054 RCKM=VINT(180+KFOLD)*PYR(0)
11055 IPM=(5-ISIGN(1,KFOLD))/2
11056 KFANEW=-MOD(KFAOLD+1,2)
11057 410 KFANEW=KFANEW+2
11058 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11059 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11060 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11061 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11062 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11063 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11064 ENDIF
11065 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11066 ENDIF
11067 IF(MINT(2).EQ.1) THEN
11068 MINT(21)=ISIGN(MINT(55),MINT(15))
11069 MINT(22)=ISIGN(KFANEW,MINT(16))
11070 ELSE
11071 MINT(21)=ISIGN(KFANEW,MINT(15))
11072 MINT(22)=ISIGN(MINT(55),MINT(16))
11073 JS=2
11074 ENDIF
11075 KCC=22
11076
11077 ELSEIF(ISUB.EQ.84) THEN
11078C...g + gamma -> Q + Qbar; th arbitary
11079 KCS=(-1)**INT(1.5D0+PYR(0))
11080 MINT(21)=ISIGN(MINT(55),KCS)
11081 MINT(22)=-MINT(21)
11082 KCC=27
11083 IF(MINT(16).EQ.21) KCC=28
11084
11085 ELSEIF(ISUB.EQ.85) THEN
11086C...gamma + gamma -> F + Fbar; th arbitary
11087 KCS=(-1)**INT(1.5D0+PYR(0))
11088 MINT(21)=ISIGN(MINT(56),KCS)
11089 MINT(22)=-MINT(21)
11090 KCC=21
11091
11092 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11093C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11094 MINT(21)=KFPR(ISUB,1)
11095 MINT(22)=KFPR(ISUB,2)
11096 KCC=24
11097 KCS=(-1)**INT(1.5D0+PYR(0))
11098 ENDIF
11099
11100 ELSEIF(ISUB.LE.100) THEN
11101 IF(ISUB.EQ.95) THEN
11102C...Low-pT ( = energyless g + g -> g + g)
11103 KCC=MINT(2)+12
11104 KCS=(-1)**INT(1.5D0+PYR(0))
11105
11106 ELSEIF(ISUB.EQ.96) THEN
11107C...Multiple interactions (should be reassigned to QCD process)
11108 ENDIF
11109
11110 ELSEIF(ISUB.LE.110) THEN
11111 IF(ISUB.EQ.101) THEN
11112C...g + g -> gamma*/Z0
11113 KCC=21
11114 KFRES=22
11115
11116 ELSEIF(ISUB.EQ.102) THEN
11117C...g + g -> h0 (or H0, or A0)
11118 KCC=21
11119 KFRES=KFHIGG
11120
11121 ELSEIF(ISUB.EQ.103) THEN
11122C...gamma + gamma -> h0 (or H0, or A0)
11123 KCC=21
11124 KFRES=KFHIGG
11125
11126 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11127C...g + g -> chi_0c or chi_2c.
11128 KCC=21
11129 KFRES=KFPR(ISUB,1)
11130
11131 ELSEIF(ISUB.EQ.106) THEN
11132C...g + g -> J/Psi + gamma
11133 MINT(21)=KFPR(ISUB,1)
11134 MINT(22)=KFPR(ISUB,2)
11135 KCC=21
11136
11137 ELSEIF(ISUB.EQ.107) THEN
11138C...g + gamma -> J/Psi + g
11139 MINT(21)=KFPR(ISUB,1)
11140 MINT(22)=KFPR(ISUB,2)
11141 KCC=22
11142 IF(MINT(16).EQ.22) KCC=33
11143
11144 ELSEIF(ISUB.EQ.108) THEN
11145C...gamma + gamma -> J/Psi + gamma
11146 MINT(21)=KFPR(ISUB,1)
11147 MINT(22)=KFPR(ISUB,2)
11148
11149 ELSEIF(ISUB.EQ.110) THEN
11150C...f + fbar -> gamma + h0; th arbitrary
11151 IF(PYR(0).GT.0.5D0) JS=2
11152 MINT(20+JS)=22
11153 MINT(23-JS)=KFHIGG
11154 ENDIF
11155
11156 ELSEIF(ISUB.LE.120) THEN
11157 IF(ISUB.EQ.111) THEN
11158C...f + fbar -> g + h0; th arbitrary
11159 IF(PYR(0).GT.0.5D0) JS=2
11160 MINT(20+JS)=21
11161 MINT(23-JS)=KFHIGG
11162 KCC=17+JS
11163
11164 ELSEIF(ISUB.EQ.112) THEN
11165C...f + g -> f + h0; th = (p(f) - p(f))**2
11166 IF(MINT(15).EQ.21) JS=2
11167 MINT(23-JS)=KFHIGG
11168 KCC=15+JS
11169 KCS=ISIGN(1,MINT(14+JS))
11170
11171 ELSEIF(ISUB.EQ.113) THEN
11172C...g + g -> g + h0; th arbitrary
11173 IF(PYR(0).GT.0.5D0) JS=2
11174 MINT(23-JS)=KFHIGG
11175 KCC=22+JS
11176 KCS=(-1)**INT(1.5D0+PYR(0))
11177
11178 ELSEIF(ISUB.EQ.114) THEN
11179C...g + g -> gamma + gamma; th arbitrary
11180 IF(PYR(0).GT.0.5D0) JS=2
11181 MINT(21)=22
11182 MINT(22)=22
11183 KCC=21
11184
11185 ELSEIF(ISUB.EQ.115) THEN
11186C...g + g -> g + gamma; th arbitrary
11187 IF(PYR(0).GT.0.5D0) JS=2
11188 MINT(23-JS)=22
11189 KCC=22+JS
11190 KCS=(-1)**INT(1.5D0+PYR(0))
11191
11192 ELSEIF(ISUB.EQ.116) THEN
11193C...g + g -> gamma + Z0
11194
11195 ELSEIF(ISUB.EQ.117) THEN
11196C...g + g -> Z0 + Z0
11197
11198 ELSEIF(ISUB.EQ.118) THEN
11199C...g + g -> W+ + W-
11200 ENDIF
11201
11202 ELSEIF(ISUB.LE.140) THEN
11203 IF(ISUB.EQ.121) THEN
11204C...g + g -> Q + Qbar + h0
11205 KCS=(-1)**INT(1.5D0+PYR(0))
11206 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11207 MINT(22)=-MINT(21)
11208 KCC=11+INT(0.5D0+PYR(0))
11209 KFRES=KFHIGG
11210
11211 ELSEIF(ISUB.EQ.122) THEN
11212C...q + qbar -> Q + Qbar + h0
11213 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11214 MINT(22)=-MINT(21)
11215 KCC=4
11216 KFRES=KFHIGG
11217
11218 ELSEIF(ISUB.EQ.123) THEN
11219C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11220C...inner process)
11221 KCC=22
11222 KFRES=KFHIGG
11223
11224 ELSEIF(ISUB.EQ.124) THEN
11225C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11226C...inner process)
11227 DO 430 JT=1,2
11228 I=MINT(14+JT)
11229 IA=IABS(I)
11230 IF(IA.LE.10) THEN
11231 RVCKM=VINT(180+I)*PYR(0)
11232 DO 420 J=1,MSTP(1)
11233 IB=2*J-1+MOD(IA,2)
11234 IPM=(5-ISIGN(1,I))/2
11235 IDC=J+MDCY(IA,2)+2
11236 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11237 MINT(20+JT)=ISIGN(IB,I)
11238 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11239 IF(RVCKM.LE.0D0) GOTO 430
11240 420 CONTINUE
11241 ELSE
11242 IB=2*((IA+1)/2)-1+MOD(IA,2)
11243 MINT(20+JT)=ISIGN(IB,I)
11244 ENDIF
11245 430 CONTINUE
11246 KCC=22
11247 KFRES=KFHIGG
11248
11249 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11250C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11251 IF(MINT(15).EQ.22) JS=2
11252 MINT(23-JS)=21
11253 KCC=24+JS
11254 KCS=ISIGN(1,MINT(14+JS))
11255
11256 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11257C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11258 IF(MINT(15).EQ.22) JS=2
11259 KCC=22
11260 KCS=ISIGN(1,MINT(14+JS))
11261
11262 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11263C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11264 KCS=(-1)**INT(1.5D0+PYR(0))
11265 MINT(21)=ISIGN(KFLF,KCS)
11266 MINT(22)=-MINT(21)
11267 KCC=27
11268 IF(MINT(16).EQ.21) KCC=28
11269
11270 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11271C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11272 KCS=(-1)**INT(1.5D0+PYR(0))
11273 MINT(21)=ISIGN(KFLF,KCS)
11274 MINT(22)=-MINT(21)
11275 KCC=21
11276
11277 ENDIF
11278
11279 ELSEIF(ISUB.LE.160) THEN
11280 IF(ISUB.EQ.141) THEN
11281C...f + fbar -> gamma*/Z0/Z'0
11282 KFRES=32
11283
11284 ELSEIF(ISUB.EQ.142) THEN
11285C...f + fbar' -> W'+/-
11286 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11287 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11288 KFRES=ISIGN(34,KCH1+KCH2)
11289
11290 ELSEIF(ISUB.EQ.143) THEN
11291C...f + fbar' -> H+/-
11292 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11293 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11294 KFRES=ISIGN(37,KCH1+KCH2)
11295
11296 ELSEIF(ISUB.EQ.144) THEN
11297C...f + fbar' -> R
11298 KFRES=ISIGN(41,MINT(15)+MINT(16))
11299
11300 ELSEIF(ISUB.EQ.145) THEN
11301C...q + l -> LQ (leptoquark)
11302 IF(IABS(MINT(16)).LE.8) JS=2
11303 KFRES=ISIGN(42,MINT(14+JS))
11304 KCC=28+JS
11305 KCS=ISIGN(1,MINT(14+JS))
11306
11307 ELSEIF(ISUB.EQ.146) THEN
11308C...e + gamma -> e* (excited lepton)
11309 IF(MINT(15).EQ.22) JS=2
11310 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11311 KCC=22
11312
11313 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11314C...q + g -> q* (excited quark)
11315 IF(MINT(15).EQ.21) JS=2
11316 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11317 KCC=30+JS
11318 KCS=ISIGN(1,MINT(14+JS))
11319
11320 ELSEIF(ISUB.EQ.149) THEN
11321C...g + g -> eta_tc
11322 KFRES=KTECHN+331
11323 KCC=23
11324 KCS=(-1)**INT(1.5D0+PYR(0))
11325 ENDIF
11326
11327 ELSEIF(ISUB.LE.200) THEN
11328 IF(ISUB.EQ.161) THEN
11329C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11330 IF(MINT(15).EQ.21) JS=2
11331 I=MINT(14+JS)
11332 IA=IABS(I)
11333 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11334 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11335 MINT(20+JS)=ISIGN(IB,I)
11336 KCC=15+JS
11337 KCS=ISIGN(1,MINT(14+JS))
11338
11339 ELSEIF(ISUB.EQ.162) THEN
11340C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11341 IF(MINT(15).EQ.21) JS=2
11342 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11343 KFLQL=KFDP(MDCY(42,2),2)
11344 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11345 KCC=15+JS
11346 KCS=ISIGN(1,MINT(14+JS))
11347
11348 ELSEIF(ISUB.EQ.163) THEN
11349C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11350 KCS=(-1)**INT(1.5D0+PYR(0))
11351 MINT(21)=ISIGN(42,KCS)
11352 MINT(22)=-MINT(21)
11353 KCC=MINT(2)+10
11354
11355 ELSEIF(ISUB.EQ.164) THEN
11356C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11357 MINT(21)=ISIGN(42,MINT(15))
11358 MINT(22)=-MINT(21)
11359 KCC=4
11360
11361 ELSEIF(ISUB.EQ.165) THEN
11362C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11363 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11364 MINT(22)=-MINT(21)
11365
11366 ELSEIF(ISUB.EQ.166) THEN
11367C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11368 IF(MOD(MINT(15),2).EQ.0) THEN
11369 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11370 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11371 ELSE
11372 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11373 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11374 ENDIF
11375
11376 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11377C...q + q' -> q" + q* (excited quark)
11378 KFQSTR=KFPR(ISUB,2)
11379 KFQEXC=MOD(KFQSTR,KEXCIT)
11380 JS=MINT(2)
11381 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11382 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11383 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11384 KCC=22
11385 JS=3-JS
11386
11387 ELSEIF(ISUB.EQ.169) THEN
11388C...q + qbar -> e + e* (excited lepton)
11389 KFQSTR=KFPR(ISUB,2)
11390 KFQEXC=MOD(KFQSTR,KEXCIT)
11391 JS=MINT(2)
11392 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11393 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11394 JS=3-JS
11395
11396 ELSEIF(ISUB.EQ.191) THEN
11397C...f + fbar -> rho_tc0.
11398 KFRES=KTECHN+113
11399
11400 ELSEIF(ISUB.EQ.192) THEN
11401C...f + fbar' -> rho_tc+/-
11402 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11403 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11404 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11405
11406 ELSEIF(ISUB.EQ.193) THEN
11407C...f + fbar -> omega_tc0.
11408 KFRES=KTECHN+223
11409
11410 ELSEIF(ISUB.EQ.194) THEN
11411C...f + fbar -> f' + fbar' via mixture of s-channel
11412C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11413 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11414 MINT(22)=-MINT(21)
11415
11416 ELSEIF(ISUB.EQ.195) THEN
11417C...f + fbar' -> f'' + fbar''' via s-channel
11418C...rho_tc+ th=(p(f)-p(f'))**2
11419C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11420 IF(MOD(MINT(15),2).EQ.0) THEN
11421 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11422 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11423 ELSE
11424 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11425 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11426 ENDIF
11427 ENDIF
11428
11429CMRENNA++
11430 ELSEIF(ISUB.LE.215) THEN
11431 IF(ISUB.EQ.201) THEN
11432C...f + fbar -> ~e_L + ~e_Lbar
11433 MINT(21)=ISIGN(KSUSY1+11,KCS)
11434 MINT(22)=-MINT(21)
11435
11436 ELSEIF(ISUB.EQ.202) THEN
11437C...f + fbar -> ~e_R + ~e_Rbar
11438 MINT(21)=ISIGN(KSUSY2+11,KCS)
11439 MINT(22)=-MINT(21)
11440
11441 ELSEIF(ISUB.EQ.203) THEN
11442C...f + fbar -> ~e_L + ~e_Rbar
11443 IF(MINT(15).LT.0) JS=2
11444 IF(MINT(2).EQ.1) THEN
11445 MINT(20+JS)=KFPR(ISUB,1)
11446 MINT(23-JS)=-KFPR(ISUB,2)
11447 ELSE
11448 MINT(20+JS)=-KFPR(ISUB,1)
11449 MINT(23-JS)=KFPR(ISUB,2)
11450 ENDIF
11451
11452 ELSEIF(ISUB.EQ.204) THEN
11453C...f + fbar -> ~mu_L + ~mu_Lbar
11454 MINT(21)=ISIGN(KSUSY1+13,KCS)
11455 MINT(22)=-MINT(21)
11456
11457 ELSEIF(ISUB.EQ.205) THEN
11458C...f + fbar -> ~mu_R + ~mu_Rbar
11459 MINT(21)=ISIGN(KSUSY2+13,KCS)
11460 MINT(22)=-MINT(21)
11461
11462 ELSEIF(ISUB.EQ.206) THEN
11463C...f + fbar -> ~mu_L + ~mu_Rbar
11464 IF(MINT(15).LT.0) JS=2
11465 IF(MINT(2).EQ.1) THEN
11466 MINT(20+JS)=KFPR(ISUB,1)
11467 MINT(23-JS)=-KFPR(ISUB,2)
11468 ELSE
11469 MINT(20+JS)=-KFPR(ISUB,1)
11470 MINT(23-JS)=KFPR(ISUB,2)
11471 ENDIF
11472
11473 ELSEIF(ISUB.EQ.207) THEN
11474C...f + fbar -> ~tau_1 + ~tau_1bar
11475 MINT(21)=ISIGN(KSUSY1+15,KCS)
11476 MINT(22)=-MINT(21)
11477
11478 ELSEIF(ISUB.EQ.208) THEN
11479C...f + fbar -> ~tau_2 + ~tau_2bar
11480 MINT(21)=ISIGN(KSUSY2+15,KCS)
11481 MINT(22)=-MINT(21)
11482
11483 ELSEIF(ISUB.EQ.209) THEN
11484C...f + fbar -> ~tau_1 + ~tau_2bar
11485 IF(MINT(15).LT.0) JS=2
11486 IF(MINT(2).EQ.1) THEN
11487 MINT(20+JS)=KFPR(ISUB,1)
11488 MINT(23-JS)=-KFPR(ISUB,2)
11489 ELSE
11490 MINT(20+JS)=-KFPR(ISUB,1)
11491 MINT(23-JS)=KFPR(ISUB,2)
11492 ENDIF
11493
11494 ELSEIF(ISUB.EQ.210) THEN
11495C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11496 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11497 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11498 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11499 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11500
11501 ELSEIF(ISUB.EQ.211) THEN
11502C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11503 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11504 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11505 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11506 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11507
11508 ELSEIF(ISUB.EQ.212) THEN
11509C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11510 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11511 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11512 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11513 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11514
11515 ELSEIF(ISUB.EQ.213) THEN
11516C...f + fbar -> ~nul + ~nulbar
11517 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11518 MINT(22)=-MINT(21)
11519
11520 ELSEIF(ISUB.EQ.214) THEN
11521C...f + fbar -> ~nutau + ~nutaubar
11522 MINT(21)=ISIGN(KSUSY1+16,KCS)
11523 MINT(22)=-MINT(21)
11524 ENDIF
11525
11526 ELSEIF(ISUB.LE.225) THEN
11527 IF(ISUB.EQ.216) THEN
11528C...f + fbar -> ~chi01 + ~chi01
11529 MINT(21)=KSUSY1+22
11530 MINT(22)=KSUSY1+22
11531
11532 ELSEIF(ISUB.EQ.217) THEN
11533C...f + fbar -> ~chi02 + ~chi02
11534 MINT(21)=KSUSY1+23
11535 MINT(22)=KSUSY1+23
11536
11537 ELSEIF(ISUB.EQ.218 ) THEN
11538C...f + fbar -> ~chi03 + ~chi03
11539 MINT(21)=KSUSY1+25
11540 MINT(22)=KSUSY1+25
11541
11542 ELSEIF(ISUB.EQ.219 ) THEN
11543C...f + fbar -> ~chi04 + ~chi04
11544 MINT(21)=KSUSY1+35
11545 MINT(22)=KSUSY1+35
11546
11547 ELSEIF(ISUB.EQ.220 ) THEN
11548C...f + fbar -> ~chi01 + ~chi02
11549 IF(MINT(15).LT.0) JS=2
11550C IF(PYR(0).GT.0.5D0) JS=2
11551 MINT(20+JS)=KSUSY1+22
11552 MINT(23-JS)=KSUSY1+23
11553
11554 ELSEIF(ISUB.EQ.221 ) THEN
11555C...f + fbar -> ~chi01 + ~chi03
11556 IF(MINT(15).LT.0) JS=2
11557C IF(PYR(0).GT.0.5D0) JS=2
11558 MINT(20+JS)=KSUSY1+22
11559 MINT(23-JS)=KSUSY1+25
11560
11561 ELSEIF(ISUB.EQ.222) THEN
11562C...f + fbar -> ~chi01 + ~chi04
11563 IF(MINT(15).LT.0) JS=2
11564C IF(PYR(0).GT.0.5D0) JS=2
11565 MINT(20+JS)=KSUSY1+22
11566 MINT(23-JS)=KSUSY1+35
11567
11568 ELSEIF(ISUB.EQ.223) THEN
11569C...f + fbar -> ~chi02 + ~chi03
11570 IF(MINT(15).LT.0) JS=2
11571C IF(PYR(0).GT.0.5D0) JS=2
11572 MINT(20+JS)=KSUSY1+23
11573 MINT(23-JS)=KSUSY1+25
11574
11575 ELSEIF(ISUB.EQ.224) THEN
11576C...f + fbar -> ~chi02 + ~chi04
11577 IF(MINT(15).LT.0) JS=2
11578C IF(PYR(0).GT.0.5D0) JS=2
11579 MINT(20+JS)=KSUSY1+23
11580 MINT(23-JS)=KSUSY1+35
11581
11582 ELSEIF(ISUB.EQ.225) THEN
11583C...f + fbar -> ~chi03 + ~chi04
11584 IF(MINT(15).LT.0) JS=2
11585C IF(PYR(0).GT.0.5D0) JS=2
11586 MINT(20+JS)=KSUSY1+25
11587 MINT(23-JS)=KSUSY1+35
11588 ENDIF
11589
11590 ELSEIF(ISUB.LE.236) THEN
11591 IF(ISUB.EQ.226) THEN
11592C...f + fbar -> ~chi+-1 + ~chi-+1
11593C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11594 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11595 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11596 MINT(22)=-MINT(21)
11597
11598 ELSEIF(ISUB.EQ.227) THEN
11599C...f + fbar -> ~chi+-2 + ~chi-+2
11600 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11601 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11602 MINT(22)=-MINT(21)
11603
11604 ELSEIF(ISUB.EQ.228) THEN
11605C...f + fbar -> ~chi+-1 + ~chi-+2
11606C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11607C...js=1 if pyr<.5, js=2 if pyr>.5
11608C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11609C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11610C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11611C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11612 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11613 KCH2=INT(1-KCH1)/2
11614 IF(MINT(2).EQ.1) THEN
11615 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11616 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11617c IF(KCH2.EQ.0) JS=2
11618 ELSE
11619 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11620 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11621 JS=2
11622c IF(KCH2.EQ.1) JS=2
11623 ENDIF
11624
11625 ELSEIF(ISUB.EQ.229) THEN
11626C...q + qbar' -> ~chi01 + ~chi+-1
11627C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11628 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11629 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11630C...CHECK THIS
11631 IF(MOD(MINT(15),2).EQ.0) JS=2
11632 MINT(20+JS)=KSUSY1+22
11633 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11634
11635 ELSEIF(ISUB.EQ.230) THEN
11636C...q + qbar' -> ~chi02 + ~chi+-1
11637 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11638 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11639 IF(MOD(MINT(15),2).EQ.0) JS=2
11640 MINT(20+JS)=KSUSY1+23
11641 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11642
11643 ELSEIF(ISUB.EQ.231) THEN
11644C...q + qbar' -> ~chi03 + ~chi+-1
11645 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11646 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11647 IF(MOD(MINT(15),2).EQ.0) JS=2
11648 MINT(20+JS)=KSUSY1+25
11649 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11650
11651 ELSEIF(ISUB.EQ.232) THEN
11652C...q + qbar' -> ~chi04 + ~chi+-1
11653 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11654 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11655 IF(MOD(MINT(15),2).EQ.0) JS=2
11656 MINT(20+JS)=KSUSY1+35
11657 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11658
11659 ELSEIF(ISUB.EQ.233) THEN
11660C...q + qbar' -> ~chi01 + ~chi+-2
11661 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11662 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11663 IF(MOD(MINT(15),2).EQ.0) JS=2
11664 MINT(20+JS)=KSUSY1+22
11665 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11666
11667 ELSEIF(ISUB.EQ.234) THEN
11668C...q + qbar' -> ~chi02 + ~chi+-2
11669 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11670 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11671 IF(MOD(MINT(15),2).EQ.0) JS=2
11672 MINT(20+JS)=KSUSY1+23
11673 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11674
11675 ELSEIF(ISUB.EQ.235) THEN
11676C...q + qbar' -> ~chi03 + ~chi+-2
11677 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11678 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11679 IF(MOD(MINT(15),2).EQ.0) JS=2
11680 MINT(20+JS)=KSUSY1+25
11681 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11682
11683 ELSEIF(ISUB.EQ.236) THEN
11684C...q + qbar' -> ~chi04 + ~chi+-2
11685 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11686 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11687 IF(MOD(MINT(15),2).EQ.0) JS=2
11688 MINT(20+JS)=KSUSY1+35
11689 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11690 ENDIF
11691
11692 ELSEIF(ISUB.LE.245) THEN
11693 IF(ISUB.EQ.237) THEN
11694C...q + qbar -> ~chi01 + ~g
11695C...th arbitrary
11696 IF(PYR(0).GT.0.5D0) JS=2
11697 MINT(20+JS)=KSUSY1+21
11698 MINT(23-JS)=KSUSY1+22
11699 KCC=17+JS
11700
11701 ELSEIF(ISUB.EQ.238) THEN
11702C...q + qbar -> ~chi02 + ~g
11703C...th arbitrary
11704 IF(PYR(0).GT.0.5D0) JS=2
11705 MINT(20+JS)=KSUSY1+21
11706 MINT(23-JS)=KSUSY1+23
11707 KCC=17+JS
11708
11709 ELSEIF(ISUB.EQ.239) THEN
11710C...q + qbar -> ~chi03 + ~g
11711C...th arbitrary
11712 IF(PYR(0).GT.0.5D0) JS=2
11713 MINT(20+JS)=KSUSY1+21
11714 MINT(23-JS)=KSUSY1+25
11715 KCC=17+JS
11716
11717 ELSEIF(ISUB.EQ.240) THEN
11718C...q + qbar -> ~chi04 + ~g
11719C...th arbitrary
11720 IF(PYR(0).GT.0.5D0) JS=2
11721 MINT(20+JS)=KSUSY1+21
11722 MINT(23-JS)=KSUSY1+35
11723 KCC=17+JS
11724
11725 ELSEIF(ISUB.EQ.241) THEN
11726C...q + qbar' -> ~chi+-1 + ~g
11727C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11728C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11729C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11730C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11731C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11734 JS=1
11735 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11736 MINT(20+JS)=KSUSY1+21
11737 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11738 KCC=17+JS
11739
11740 ELSEIF(ISUB.EQ.242) THEN
11741C...q + qbar' -> ~chi+-2 + ~g
11742C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11743C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11744C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11745C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11746C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11747 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11748 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11749 JS=1
11750 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11751 MINT(20+JS)=KSUSY1+21
11752 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11753 KCC=17+JS
11754
11755 ELSEIF(ISUB.EQ.243) THEN
11756C...q + qbar -> ~g + ~g ; th arbitrary
11757 MINT(21)=KSUSY1+21
11758 MINT(22)=KSUSY1+21
11759 KCC=MINT(2)+4
11760
11761 ELSEIF(ISUB.EQ.244) THEN
11762C...g + g -> ~g + ~g ; th arbitrary
11763 KCC=MINT(2)+12
11764 KCS=(-1)**INT(1.5D0+PYR(0))
11765 MINT(21)=KSUSY1+21
11766 MINT(22)=KSUSY1+21
11767 ENDIF
11768
11769 ELSEIF(ISUB.LE.260) THEN
11770 IF(ISUB.EQ.246) THEN
11771C...qj + g -> ~qj_L + ~chi01
11772 IF(MINT(15).EQ.21) JS=2
11773 I=MINT(14+JS)
11774 IA=IABS(I)
11775 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11776 MINT(23-JS)=KSUSY1+22
11777 KCC=15+JS
11778 KCS=ISIGN(1,MINT(14+JS))
11779
11780 ELSEIF(ISUB.EQ.247) THEN
11781C...qj + g -> ~qj_R + ~chi01
11782 IF(MINT(15).EQ.21) JS=2
11783 I=MINT(14+JS)
11784 IA=IABS(I)
11785 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11786 MINT(23-JS)=KSUSY1+22
11787 KCC=15+JS
11788 KCS=ISIGN(1,MINT(14+JS))
11789
11790 ELSEIF(ISUB.EQ.248) THEN
11791C...qj + g -> ~qj_L + ~chi02
11792 IF(MINT(15).EQ.21) JS=2
11793 I=MINT(14+JS)
11794 IA=IABS(I)
11795 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11796 MINT(23-JS)=KSUSY1+23
11797 KCC=15+JS
11798 KCS=ISIGN(1,MINT(14+JS))
11799
11800 ELSEIF(ISUB.EQ.249) THEN
11801C...qj + g -> ~qj_R + ~chi02
11802 IF(MINT(15).EQ.21) JS=2
11803 I=MINT(14+JS)
11804 IA=IABS(I)
11805 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11806 MINT(23-JS)=KSUSY1+23
11807 KCC=15+JS
11808 KCS=ISIGN(1,MINT(14+JS))
11809
11810 ELSEIF(ISUB.EQ.250) THEN
11811C...qj + g -> ~qj_L + ~chi03
11812 IF(MINT(15).EQ.21) JS=2
11813 I=MINT(14+JS)
11814 IA=IABS(I)
11815 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11816 MINT(23-JS)=KSUSY1+25
11817 KCC=15+JS
11818 KCS=ISIGN(1,MINT(14+JS))
11819
11820 ELSEIF(ISUB.EQ.251) THEN
11821C...qj + g -> ~qj_R + ~chi03
11822 IF(MINT(15).EQ.21) JS=2
11823 I=MINT(14+JS)
11824 IA=IABS(I)
11825 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11826 MINT(23-JS)=KSUSY1+25
11827 KCC=15+JS
11828 KCS=ISIGN(1,MINT(14+JS))
11829
11830 ELSEIF(ISUB.EQ.252) THEN
11831C...qj + g -> ~qj_L + ~chi04
11832 IF(MINT(15).EQ.21) JS=2
11833 I=MINT(14+JS)
11834 IA=IABS(I)
11835 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11836 MINT(23-JS)=KSUSY1+35
11837 KCC=15+JS
11838 KCS=ISIGN(1,MINT(14+JS))
11839
11840 ELSEIF(ISUB.EQ.253) THEN
11841C...qj + g -> ~qj_R + ~chi04
11842 IF(MINT(15).EQ.21) JS=2
11843 I=MINT(14+JS)
11844 IA=IABS(I)
11845 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11846 MINT(23-JS)=KSUSY1+35
11847 KCC=15+JS
11848 KCS=ISIGN(1,MINT(14+JS))
11849
11850 ELSEIF(ISUB.EQ.254) THEN
11851C...qj + g -> ~qk_L + ~chi+-1
11852 IF(MINT(15).EQ.21) JS=2
11853 I=MINT(14+JS)
11854 IA=IABS(I)
11855 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11856 IB=-IA+INT((IA+1)/2)*4-1
11857 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11858 KCC=15+JS
11859 KCS=ISIGN(1,MINT(14+JS))
11860
11861 ELSEIF(ISUB.EQ.255) THEN
11862C...qj + g -> ~qk_L + ~chi+-1
11863 IF(MINT(15).EQ.21) JS=2
11864 I=MINT(14+JS)
11865 IA=IABS(I)
11866 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11867 IB=-IA+INT((IA+1)/2)*4-1
11868 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11869 KCC=15+JS
11870 KCS=ISIGN(1,MINT(14+JS))
11871
11872 ELSEIF(ISUB.EQ.256) THEN
11873C...qj + g -> ~qk_L + ~chi+-2
11874 IF(MINT(15).EQ.21) JS=2
11875 I=MINT(14+JS)
11876 IA=IABS(I)
11877 IB=-IA+INT((IA+1)/2)*4-1
11878 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11879 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11880 KCC=15+JS
11881 KCS=ISIGN(1,MINT(14+JS))
11882
11883 ELSEIF(ISUB.EQ.257) THEN
11884C...qj + g -> ~qk_R + ~chi+-2
11885 IF(MINT(15).EQ.21) JS=2
11886 I=MINT(14+JS)
11887 IA=IABS(I)
11888 IB=-IA+INT((IA+1)/2)*4-1
11889 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11890 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11891 KCC=15+JS
11892 KCS=ISIGN(1,MINT(14+JS))
11893
11894 ELSEIF(ISUB.EQ.258) THEN
11895C...qj + g -> ~qj_L + ~g
11896 IF(MINT(15).EQ.21) JS=2
11897 I=MINT(14+JS)
11898 IA=IABS(I)
11899 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11900 MINT(23-JS)=KSUSY1+21
11901 KCC=MINT(2)+6
11902 IF(JS.EQ.2) KCC=KCC+2
11903 KCS=ISIGN(1,I)
11904
11905 ELSEIF(ISUB.EQ.259) THEN
11906C...qj + g -> ~qj_R + ~g
11907 IF(MINT(15).EQ.21) JS=2
11908 I=MINT(14+JS)
11909 IA=IABS(I)
11910 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11911 MINT(23-JS)=KSUSY1+21
11912 KCC=MINT(2)+6
11913 IF(JS.EQ.2) KCC=KCC+2
11914 KCS=ISIGN(1,I)
11915 ENDIF
11916
11917 ELSEIF(ISUB.LE.270) THEN
11918 IF(ISUB.EQ.261) THEN
11919C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11920 ISGN=1
11921 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11922 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11923 MINT(22)=-MINT(21)
11924C...Correct color combination
11925 IF(MINT(43).EQ.4) KCC=4
11926
11927 ELSEIF(ISUB.EQ.262) THEN
11928C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11929 ISGN=1
11930 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11931 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11932 MINT(22)=-MINT(21)
11933C...Correct color combination
11934 IF(MINT(43).EQ.4) KCC=4
11935
11936 ELSEIF(ISUB.EQ.263) THEN
11937C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11938 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11939 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11940 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11941 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11942 ELSE
11943 JS=2
11944 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11945 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11946 ENDIF
11947C...Correct color combination
11948 IF(MINT(43).EQ.4) KCC=4
11949
11950 ELSEIF(ISUB.EQ.264) THEN
11951C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11952 KCS=(-1)**INT(1.5D0+PYR(0))
11953 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11954 MINT(22)=-MINT(21)
11955 KCC=MINT(2)+10
11956
11957 ELSEIF(ISUB.EQ.265) THEN
11958C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11959 KCS=(-1)**INT(1.5D0+PYR(0))
11960 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11961 MINT(22)=-MINT(21)
11962 KCC=MINT(2)+10
11963 ENDIF
11964
11965 ELSEIF(ISUB.LE.296) THEN
11966 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11967C...qi + qj -> ~qi_L + ~qj_L
11968 KCC=MINT(2)
11969 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11970 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11971 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11972
11973 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11974C...qi + qj -> ~qi_R + ~qj_R
11975 KCC=MINT(2)
11976 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11977 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11978 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11979
11980 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11981C...qi + qj -> ~qi_L + ~qj_R
11982 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11983 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11984 KCC=MINT(2)
11985 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11986
11987 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11988C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11989 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11990 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11991 KCC=MINT(2)
11992 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11993
11994 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11995C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11996 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11997 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11998 KCC=MINT(2)
11999 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12000
12001 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12002C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12003 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12004 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12005 KCC=MINT(2)
12006 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12007
12008 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12009C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12010 ISGN=1
12011 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12012 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12013 MINT(22)=-MINT(21)
12014 IF(MINT(43).EQ.4) KCC=4
12015
12016 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12017C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12018 ISGN=1
12019 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12020 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12021 MINT(22)=-MINT(21)
12022 IF(MINT(43).EQ.4) KCC=4
12023
12024 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12025C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12026C...pure LL + RR
12027 KCS=(-1)**INT(1.5D0+PYR(0))
12028 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12029 MINT(22)=-MINT(21)
12030 KCC=MINT(2)+10
12031
12032 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12033C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12034 KCS=(-1)**INT(1.5D0+PYR(0))
12035 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12036 MINT(22)=-MINT(21)
12037 KCC=MINT(2)+10
12038
12039 ELSEIF(ISUB.EQ.294) THEN
12040C...qj + g -> ~qj_L + ~g
12041 IF(MINT(15).EQ.21) JS=2
12042 I=MINT(14+JS)
12043 IA=IABS(I)
12044 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12045 MINT(23-JS)=KSUSY1+21
12046 KCC=MINT(2)+6
12047 IF(JS.EQ.2) KCC=KCC+2
12048 KCS=ISIGN(1,I)
12049
12050 ELSEIF(ISUB.EQ.295) THEN
12051C...qj + g -> ~qj_R + ~g
12052 IF(MINT(15).EQ.21) JS=2
12053 I=MINT(14+JS)
12054 IA=IABS(I)
12055 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12056 MINT(23-JS)=KSUSY1+21
12057 KCC=MINT(2)+6
12058 IF(JS.EQ.2) KCC=KCC+2
12059 KCS=ISIGN(1,I)
12060 ENDIF
12061
12062 ELSEIF(ISUB.LE.340) THEN
12063
12064 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12065C...q + qbar' -> H+ + H0
12066 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12067 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12068 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12069 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12070 MINT(23-JS)=KFPR(ISUB,2)
12071 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12072C...f + fbar -> A0 + H0; th arbitrary
12073 IF(PYR(0).GT.0.5D0) JS=2
12074 MINT(20+JS)=KFPR(ISUB,1)
12075 MINT(23-JS)=KFPR(ISUB,2)
12076 ELSEIF(ISUB.EQ.301) THEN
12077C...f + fbar -> H+ H-
12078 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12079 MINT(22)=-MINT(21)
12080 ENDIF
12081CMRENNA--
12082
12083 ELSEIF(ISUB.LE.360) THEN
12084
12085 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12086C...l + l -> H_L++/--, H_R++/--
12087 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12088 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12089 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12090
12091 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12092C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12093 IF(MINT(15).EQ.22) JS=2
12094 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12095 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12096 KCC=22
12097
12098 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12099C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12100 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12101 MINT(22)=-MINT(21)
12102
12103 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12104C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12105C...as inner process).
12106 DO 450 JT=1,2
12107 I=MINT(14+JT)
12108 IA=IABS(I)
12109 IF(IA.LE.10) THEN
12110 RVCKM=VINT(180+I)*PYR(0)
12111 DO 440 J=1,MSTP(1)
12112 IB=2*J-1+MOD(IA,2)
12113 IPM=(5-ISIGN(1,I))/2
12114 IDC=J+MDCY(IA,2)+2
12115 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12116 MINT(20+JT)=ISIGN(IB,I)
12117 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12118 IF(RVCKM.LE.0D0) GOTO 450
12119 440 CONTINUE
12120 ELSE
12121 IB=2*((IA+1)/2)-1+MOD(IA,2)
12122 MINT(20+JT)=ISIGN(IB,I)
12123 ENDIF
12124 450 CONTINUE
12125 KCC=22
12126 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12127 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12128
12129 ELSEIF(ISUB.EQ.353) THEN
12130C...f + fbar -> Z_R0
12131 KFRES=KFPR(ISUB,1)
12132
12133 ELSEIF(ISUB.EQ.354) THEN
12134C...f + fbar' -> W+/-
12135 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12136 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12137 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12138
12139 ENDIF
12140
12141 ELSEIF(ISUB.LE.380) THEN
12142
12143 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12144C...f + fbar -> charged+ charged- technicolor
12145 KSW=(-1)**INT(1.5D0+PYR(0))
12146 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12147 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12148
12149 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12150C...f + fbar -> neutral neutral technicolor
12151 MINT(21)=KFPR(ISUB,1)
12152 MINT(22)=KFPR(ISUB,2)
12153
12154 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12155C...f + fbar' -> neutral charged technicolor
12156 IN=1
12157 IC=2
12158 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12159 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12160 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12161 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12162 MINT(20+JS)=KFPR(ISUB,IN)
12163
12164 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12165C...f + fbar' -> charged neutral technicolor
12166 IN=2
12167 IC=1
12168 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12169 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12170 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12171 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12172 MINT(23-JS)=KFPR(ISUB,IN)
12173 ENDIF
12174
12175 ELSEIF(ISUB.LE.400) THEN
12176 IF(ISUB.EQ.381) THEN
12177C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12178 KCC=MINT(2)
12179 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12180
12181 ELSEIF(ISUB.EQ.382) THEN
12182C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12183 MINT(21)=ISIGN(KFLF,MINT(15))
12184 MINT(22)=-MINT(21)
12185 KCC=4
12186
12187 ELSEIF(ISUB.EQ.383) THEN
12188C...f + fbar -> g + g; th arbitrary, TC extensions
12189 MINT(21)=21
12190 MINT(22)=21
12191 KCC=MINT(2)+4
12192
12193 ELSEIF(ISUB.EQ.384) THEN
12194C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12195 IF(MINT(15).EQ.21) JS=2
12196 KCC=MINT(2)+6
12197 IF(MINT(15).EQ.21) KCC=KCC+2
12198 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12199 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12200
12201 ELSEIF(ISUB.EQ.385) THEN
12202C...g + g -> f + fbar; th arbitrary, TC extensions
12203 KCS=(-1)**INT(1.5D0+PYR(0))
12204 MINT(21)=ISIGN(KFLF,KCS)
12205 MINT(22)=-MINT(21)
12206 KCC=MINT(2)+10
12207
12208 ELSEIF(ISUB.EQ.386) THEN
12209C...g + g -> g + g; th arbitrary, TC extensions
12210 KCC=MINT(2)+12
12211 KCS=(-1)**INT(1.5D0+PYR(0))
12212
12213 ELSEIF(ISUB.EQ.387) THEN
12214C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12215 MINT(21)=ISIGN(MINT(55),MINT(15))
12216 MINT(22)=-MINT(21)
12217 KCC=4
12218
12219 ELSEIF(ISUB.EQ.388) THEN
12220C...g + g -> Q + Qbar; th arbitrary, TC extensions
12221 KCS=(-1)**INT(1.5D0+PYR(0))
12222 MINT(21)=ISIGN(MINT(55),KCS)
12223 MINT(22)=-MINT(21)
12224 KCC=MINT(2)+10
12225
12226 ELSEIF(ISUB.EQ.391) THEN
12227C...f + fbar -> G*.
12228 KFRES=KFPR(ISUB,1)
12229
12230 ELSEIF(ISUB.EQ.392) THEN
12231C...g + g -> G*.
12232 KCC=21
12233 KFRES=KFPR(ISUB,1)
12234
12235 ELSEIF(ISUB.EQ.393) THEN
12236C...q + qbar -> g + G*; th arbitrary.
12237 IF(PYR(0).GT.0.5D0) JS=2
12238 MINT(20+JS)=KFPR(ISUB,1)
12239 MINT(23-JS)=KFPR(ISUB,2)
12240 KCC=17+JS
12241
12242 ELSEIF(ISUB.EQ.394) THEN
12243C...q + g -> q + G*; th = (p(f) - p(f))**2
12244 IF(MINT(15).EQ.21) JS=2
12245 MINT(23-JS)=KFPR(ISUB,2)
12246 KCC=15+JS
12247 KCS=ISIGN(1,MINT(14+JS))
12248
12249 ELSEIF(ISUB.EQ.395) THEN
12250C...g + g -> G* + g; th arbitrary.
12251 IF(PYR(0).GT.0.5D0) JS=2
12252 MINT(23-JS)=KFPR(ISUB,2)
12253 KCC=22+JS
12254 ENDIF
12255
12256 ELSEIF(ISUB.LE.420) THEN
12257 IF(ISUB.EQ.401) THEN
12258C...g + g -> t + b + H+/-
12259 KCS=(-1)**INT(1.5D0+PYR(0))
12260 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12261 MINT(22)=ISIGN(5,-KCS)
12262 KCC=11+INT(0.5D0+PYR(0))
12263 KFRES=ISIGN(KFHIGG,-KCS)
12264
12265 ELSEIF(ISUB.EQ.402) THEN
12266C...q + qbar -> t + b + H+/-
12267 KFL=(-1)**INT(1.5D0+PYR(0))
12268 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12269 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12270 KCC=4
12271 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12272 ENDIF
12273
12274C...QUARKONIA+++
12275C...Additional code by Stefan Wolf
12276 ELSEIF(ISUB.LE.430) THEN
12277 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12278C...g + g -> QQ~[n] + g
12279C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12280C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12281C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12282C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12283C...or from ISUB.EQ.68 (for ISUB.NE.421)
12284C...[g + g -> g + g; th arbitrary]
12285 MINT(21)=KFPR(ISUBSV,1)
12286 MINT(22)=KFPR(ISUBSV,2)
12287 IF(ISUB.EQ.421) THEN
12288 KCC=24
12289 KCS=(-1)**INT(1.5D0+PYR(0))
12290 ELSE
12291 KCC=MINT(2)+12
12292 KCS=(-1)**INT(1.5D0+PYR(0))
12293 ENDIF
12294
12295 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12296C...q + g -> q + QQ~[n]
12297C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12298C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12299C...KCC copied from ISUB.EQ.28
12300C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12301 IF(MINT(15).EQ.21) JS=2
12302 MINT(23-JS)=KFPR(ISUBSV,2)
12303 KCC=MINT(2)+6
12304 IF(MINT(15).EQ.21) KCC=KCC+2
12305 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12306 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12307
12308 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12309C...q + q~ -> g + QQ~[n]
12310C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12311C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12312C...KCC copied from ISUB.EQ.13
12313C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12314 IF(PYR(0).GT.0.5) JS=2
12315 MINT(20+JS)=21
12316 MINT(23-JS)=KFPR(ISUBSV,2)
12317 KCC=MINT(2)+4
12318 ENDIF
12319
12320 ELSEIF(ISUB.LE.440) THEN
12321 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12322C...g + g -> QQ~[n] + g
12323C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12324C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12325C...KCC and KCS copied from ISUB.EQ.86-89
12326C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12327 MINT(21)=KFPR(ISUBSV,1)
12328 MINT(22)=KFPR(ISUBSV,2)
12329 KCC=24
12330 KCS=(-1)**INT(1.5D0+PYR(0))
12331
12332 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12333C...q + g -> q + QQ~[n]
12334C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12335C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12336C...KCC and KCS copied from ISUB.EQ.112
12337C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12338 IF(MINT(15).EQ.21) JS=2
12339 MINT(23-JS)=KFPR(ISUBSV,2)
12340 KCC=15+JS
12341 KCS=ISIGN(1,MINT(14+JS))
12342
12343 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12344C...q + q~ -> g + QQ~[n]
12345C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12346C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12347C...KCC copied from ISUB.EQ.111
12348C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12349 IF(PYR(0).GT.0.5) JS=2
12350 MINT(20+JS)=21
12351 MINT(23-JS)=KFPR(ISUBSV,2)
12352 KCC=17+JS
12353 ENDIF
12354C...QUARKONIA---
12355
12356 ENDIF
12357
12358 IF(ISET(ISUB).EQ.11) THEN
12359C...Store documentation for user-defined processes
12360 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12361 KUPPO(1)=MINT(83)+5
12362 KUPPO(2)=MINT(83)+6
12363 I=MINT(83)+6
12364 DO 470 IUP=3,NUP
12365 KUPPO(IUP)=0
12366 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12367 IDOC=IDOC-1
12368 MINT(4)=MINT(4)-1
12369 GOTO 470
12370 ENDIF
12371 I=I+1
12372 KUPPO(IUP)=I
12373 K(I,1)=21
12374 K(I,2)=IDUP(IUP)
12375 IF(IDUP(IUP).EQ.0) K(I,2)=90
12376 K(I,3)=0
12377 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12378 K(I,4)=0
12379 K(I,5)=0
12380 DO 460 J=1,5
12381 P(I,J)=PUP(J,IUP)
12382 460 CONTINUE
12383 V(I,5)=VTIMUP(IUP)
12384 470 CONTINUE
12385 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12386 & -BEZUP)
12387
12388C...Store final state partons for user-defined processes
12389 N=IPU2
12390 DO 490 IUP=3,NUP
12391 N=N+1
12392 K(N,1)=1
12393 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12394 K(N,2)=IDUP(IUP)
12395 IF(IDUP(IUP).EQ.0) K(N,2)=90
12396 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12397 K(N,3)=KUPPO(IUP)
12398 ELSE
12399 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12400 ENDIF
12401 K(N,4)=0
12402 K(N,5)=0
12403C...Search for daughters of intermediate colourless particles.
12404 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12405 DO 475 IUPDAU=IUP+1,NUP
12406 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12407 & N+IUPDAU-IUP
12408 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12409 475 CONTINUE
12410 ENDIF
12411 DO 480 J=1,5
12412 P(N,J)=PUP(J,IUP)
12413 480 CONTINUE
12414 V(N,5)=VTIMUP(IUP)
12415 490 CONTINUE
12416 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12417
12418C...Arrange colour flow for user-defined processes
12419 NLBL=0
12420 DO 540 IUP1=1,NUP
12421 I1=MINT(84)+IUP1
12422 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12423 IF(K(I1,1).EQ.1) K(I1,1)=3
12424 IF(K(I1,1).EQ.11) K(I1,1)=14
12425C...Find a not yet considered colour/anticolour line.
12426 DO 530 ISDE1=1,2
12427 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12428 NMAT=0
12429 DO 500 ILBL=1,NLBL
12430 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12431 500 CONTINUE
12432 IF(NMAT.EQ.0) THEN
12433 NLBL=NLBL+1
12434 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12435C...Find all others belonging to same line.
12436 I3=I1
12437 I4=0
12438 DO 520 IUP2=IUP1+1,NUP
12439 I2=MINT(84)+IUP2
12440 DO 510 ISDE2=1,2
12441 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12442 IF(ISDE2.EQ.ISDE1) THEN
12443 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12444 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12445 I3=I2
12446 ELSEIF(I4.NE.0) THEN
12447 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12448 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12449 I4=I2
12450 ELSEIF(IUP2.LE.2) THEN
12451 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12452 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12453 I4=I2
12454 ELSE
12455 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12456 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12457 I4=I2
12458 ENDIF
12459 ENDIF
12460 510 CONTINUE
12461 520 CONTINUE
12462 ENDIF
12463 530 CONTINUE
12464 540 CONTINUE
12465
12466 ELSEIF(IDOC.EQ.7) THEN
12467C...Resonance not decaying; store kinematics
12468 I=MINT(83)+7
12469 K(IPU3,1)=1
12470 K(IPU3,2)=KFRES
12471 K(IPU3,3)=I
12472 P(IPU3,4)=SHUSER
12473 P(IPU3,5)=SHUSER
12474 K(I,1)=21
12475 K(I,2)=KFRES
12476 P(I,4)=SHUSER
12477 P(I,5)=SHUSER
12478 N=IPU3
12479 MINT(21)=KFRES
12480 MINT(22)=0
12481
12482C...Special cases: colour flow in coloured resonances
12483 KCRES=PYCOMP(KFRES)
12484 IF(KCHG(KCRES,2).NE.0) THEN
12485 K(IPU3,1)=3
12486 DO 550 J=1,2
12487 JC=J
12488 IF(KCS.EQ.-1) JC=3-J
12489 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12490 & MINT(84)+ICOL(KCC,1,JC)
12491 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12492 & MINT(84)+ICOL(KCC,2,JC)
12493 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12494 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12495 550 CONTINUE
12496 ELSE
12497 K(IPU1,4)=IPU2
12498 K(IPU1,5)=IPU2
12499 K(IPU2,4)=IPU1
12500 K(IPU2,5)=IPU1
12501 ENDIF
12502
12503 ELSEIF(IDOC.EQ.8) THEN
12504C...2 -> 2 processes: store outgoing partons in their CM-frame
12505 DO 560 JT=1,2
12506 I=MINT(84)+2+JT
12507 KCA=PYCOMP(MINT(20+JT))
12508 K(I,1)=1
12509 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12510 K(I,2)=MINT(20+JT)
12511 K(I,3)=MINT(83)+IDOC+JT-2
12512 KFAA=IABS(K(I,2))
12513 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12514 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12515 ELSE
12516 P(I,5)=PYMASS(K(I,2))
12517 ENDIF
12518 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12519 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12520 560 CONTINUE
12521 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12522 KFA1=IABS(MINT(21))
12523 KFA2=IABS(MINT(22))
12524 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12525 & THEN
12526 MINT(51)=1
12527 RETURN
12528 ENDIF
12529 P(IPU3,5)=0D0
12530 P(IPU4,5)=0D0
12531 ENDIF
12532 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12533 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12534 P(IPU4,4)=SHR-P(IPU3,4)
12535 P(IPU4,3)=-P(IPU3,3)
12536 N=IPU4
12537 MINT(7)=MINT(83)+7
12538 MINT(8)=MINT(83)+8
12539
12540C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12541 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12542
12543 ELSEIF(IDOC.EQ.9) THEN
12544C...2 -> 3 processes: store outgoing partons in their CM frame
12545 DO 570 JT=1,2
12546 I=MINT(84)+2+JT
12547 KCA=PYCOMP(MINT(20+JT))
12548 K(I,1)=1
12549 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12550 K(I,2)=MINT(20+JT)
12551 K(I,3)=MINT(83)+IDOC+JT-3
12552 JTA=JT
12553C...t and b in opposide order in event list as compared to
12554C...matrix element?
12555 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12556 IF(IABS(K(I,2)).LE.22) THEN
12557 P(I,5)=PYMASS(K(I,2))
12558 ELSE
12559 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12560 ENDIF
12561 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12562 P(I,1)=PT*COS(VINT(198+5*JTA))
12563 P(I,2)=PT*SIN(VINT(198+5*JTA))
12564 570 CONTINUE
12565 K(IPU5,1)=1
12566 K(IPU5,2)=KFRES
12567 K(IPU5,3)=MINT(83)+IDOC
12568 P(IPU5,5)=SHR
12569 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12570 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12571 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12572 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12573 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12574 PMT3=SQRT(PMS3)
12575 P(IPU5,3)=PMT3*SINH(VINT(211))
12576 P(IPU5,4)=PMT3*COSH(VINT(211))
12577 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12578 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12579 IF(SQL12.LE.0D0) THEN
12580 MINT(51)=1
12581 RETURN
12582 ENDIF
12583 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12584 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12585 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12586 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12587C...t and b in opposide order in event list as compared to
12588C...matrix element
12589 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12590 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12591 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12592 END IF
12593 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12594 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12595 MINT(23)=KFRES
12596 N=IPU5
12597 MINT(7)=MINT(83)+7
12598 MINT(8)=MINT(83)+8
12599
12600 ELSEIF(IDOC.EQ.11) THEN
12601C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12602 PHI(1)=PARU(2)*PYR(0)
12603 PHI(2)=PHI(1)-PHIR
12604 DO 580 JT=1,2
12605 I=MINT(84)+2+JT
12606 K(I,1)=1
12607 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12608 K(I,2)=MINT(20+JT)
12609 K(I,3)=MINT(83)+IDOC+JT-2
12610 P(I,5)=PYMASS(K(I,2))
12611 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12612 MINT(51)=1
12613 RETURN
12614 ENDIF
12615 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12616 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12617 P(I,1)=PTABS*COS(PHI(JT))
12618 P(I,2)=PTABS*SIN(PHI(JT))
12619 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12620 P(I,4)=0.5D0*SHPR*Z(JT)
12621 IZW=MINT(83)+6+JT
12622 K(IZW,1)=21
12623 K(IZW,2)=23
12624 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12625 K(IZW,3)=IZW-2
12626 P(IZW,1)=-P(I,1)
12627 P(IZW,2)=-P(I,2)
12628 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12629 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12630 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12631 580 CONTINUE
12632 I=MINT(83)+9
12633 K(IPU5,1)=1
12634 K(IPU5,2)=KFRES
12635 K(IPU5,3)=I
12636 P(IPU5,5)=SHR
12637 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12638 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12639 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12640 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12641 K(I,1)=21
12642 K(I,2)=KFRES
12643 DO 590 J=1,5
12644 P(I,J)=P(IPU5,J)
12645 590 CONTINUE
12646 N=IPU5
12647 MINT(23)=KFRES
12648
12649 ELSEIF(IDOC.EQ.12) THEN
12650C...Z0 and W+/- scattering: store bosons and outgoing partons
12651 PHI(1)=PARU(2)*PYR(0)
12652 PHI(2)=PHI(1)-PHIR
12653 JTRAN=INT(1.5D0+PYR(0))
12654 DO 600 JT=1,2
12655 I=MINT(84)+2+JT
12656 K(I,1)=1
12657 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12658 K(I,2)=MINT(20+JT)
12659 K(I,3)=MINT(83)+IDOC+JT-2
12660 P(I,5)=PYMASS(K(I,2))
12661 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12662 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12663 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12664 P(I,1)=PTABS*COS(PHI(JT))
12665 P(I,2)=PTABS*SIN(PHI(JT))
12666 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12667 P(I,4)=0.5D0*SHPR*Z(JT)
12668 IZW=MINT(83)+6+JT
12669 K(IZW,1)=21
12670 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12671 K(IZW,2)=23
12672 ELSE
12673 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12674 ENDIF
12675 K(IZW,3)=IZW-2
12676 P(IZW,1)=-P(I,1)
12677 P(IZW,2)=-P(I,2)
12678 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12679 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12680 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12681 IPU=MINT(84)+4+JT
12682 K(IPU,1)=3
12683 K(IPU,2)=KFPR(ISUB,JT)
12684 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12685 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12686 K(IPU,3)=MINT(83)+8+JT
12687 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12688 P(IPU,5)=PYMASS(K(IPU,2))
12689 ELSE
12690 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12691 ENDIF
12692 MINT(22+JT)=K(IPU,2)
12693 600 CONTINUE
12694C...Find rotation and boost for hard scattering subsystem
12695 I1=MINT(83)+7
12696 I2=MINT(83)+8
12697 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12698 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12699 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12700 GAMCM=(P(I1,4)+P(I2,4))/SHR
12701 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12702 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12703 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12704 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12705 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12706 PHICM=PYANGL(PX,PY)
12707C...Store hard scattering subsystem. Rotate and boost it
12708 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12709 & P(IPU6,5)**2
12710 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12711 CTHWZ=VINT(23)
12712 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12713 PHIWZ=VINT(24)-PHICM
12714 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12715 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12716 P(IPU5,3)=PABS*CTHWZ
12717 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12718 P(IPU6,1)=-P(IPU5,1)
12719 P(IPU6,2)=-P(IPU5,2)
12720 P(IPU6,3)=-P(IPU5,3)
12721 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12722 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12723 DO 620 JT=1,2
12724 I1=MINT(83)+8+JT
12725 I2=MINT(84)+4+JT
12726 K(I1,1)=21
12727 K(I1,2)=K(I2,2)
12728 DO 610 J=1,5
12729 P(I1,J)=P(I2,J)
12730 610 CONTINUE
12731 620 CONTINUE
12732 N=IPU6
12733 MINT(7)=MINT(83)+9
12734 MINT(8)=MINT(83)+10
12735 ENDIF
12736
12737 IF(ISET(ISUB).EQ.11) THEN
12738 ELSEIF(IDOC.GE.8) THEN
12739C...Store colour connection indices
12740 DO 630 J=1,2
12741 JC=J
12742 IF(KCS.EQ.-1) JC=3-J
12743 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12744 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12745 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12746 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12747 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12748 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12749 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12750 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12751 630 CONTINUE
12752
12753C...Copy outgoing partons to documentation lines
12754 IMAX=2
12755 IF(IDOC.EQ.9) IMAX=3
12756 DO 650 I=1,IMAX
12757 I1=MINT(83)+IDOC-IMAX+I
12758 I2=MINT(84)+2+I
12759 K(I1,1)=21
12760 K(I1,2)=K(I2,2)
12761 IF(IDOC.LE.9) K(I1,3)=0
12762 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12763 DO 640 J=1,5
12764 P(I1,J)=P(I2,J)
12765 640 CONTINUE
12766 650 CONTINUE
12767
12768 ELSEIF(IDOC.EQ.9) THEN
12769C...Store colour connection indices
12770 DO 660 J=1,2
12771 JC=J
12772 IF(KCS.EQ.-1) JC=3-J
12773 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12774 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12775 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12776 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12777 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12778 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12779 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12780 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12781 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12782 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12783 660 CONTINUE
12784
12785C...Copy outgoing partons to documentation lines
12786 DO 680 I=1,3
12787 I1=MINT(83)+IDOC-3+I
12788 I2=MINT(84)+2+I
12789 K(I1,1)=21
12790 K(I1,2)=K(I2,2)
12791 K(I1,3)=0
12792 DO 670 J=1,5
12793 P(I1,J)=P(I2,J)
12794 670 CONTINUE
12795 680 CONTINUE
12796 ENDIF
12797
12798C...Copy outgoing partons to list of allowed radiators.
12799 NPART=0
12800 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12801 DO 690 I=MINT(84)+3,N
12802 NPART=NPART+1
12803 IPART(NPART)=I
12804 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12805 690 CONTINUE
12806 ENDIF
12807
12808C...Low-pT events: remove gluons used for string drawing purposes
12809 IF(ISUB.EQ.95) THEN
12810 IF(MINT(35).LE.1) THEN
12811 K(IPU3,1)=K(IPU3,1)+10
12812 K(IPU4,1)=K(IPU4,1)+10
12813 ENDIF
12814 DO 700 J=41,66
12815 VINTSV(J)=VINT(J)
12816 VINT(J)=0D0
12817 700 CONTINUE
12818 DO 720 I=MINT(83)+5,MINT(83)+8
12819 DO 710 J=1,5
12820 P(I,J)=0D0
12821 710 CONTINUE
12822 720 CONTINUE
12823 ENDIF
12824
12825 RETURN
12826 END
12827
12828C***********************************************************************
12829
12830C...PYEVOL
12831C...Handles intertwined pT-ordered spacelike initial-state parton
12832C...and multiple interactions.
12833
12834 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12835C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12836C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12837C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12838
12839C...Double precision and integer declarations.
12840 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12841 IMPLICIT INTEGER(I-N)
12842 INTEGER PYK,PYCHGE,PYCOMP
12843C...External
12844 EXTERNAL PYALPS
12845 DOUBLE PRECISION PYALPS
12846C...Parameter statement for maximum size of showers.
12847 PARAMETER (MAXNUR=1000)
12848C...Commonblocks.
12849 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12850 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12852 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12853 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12854 COMMON/PYINT1/MINT(400),VINT(400)
12855 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12856 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12857 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12858 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12859 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12860 COMMON/PYCTAG/NCT,MCT(4000,2)
12861 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12862 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12863 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12864C...Local arrays and saved variables.
12865 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12866 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12867 & ,PSAV,KSAV,VSAV
12868
12869 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12870 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12871
12872C----------------------------------------------------------------------
12873C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12874C...done only once per event, while MODE=0 is repeated each time the
12875C...evolution needs to be restarted.
12876 IF (MODE.EQ.-1) THEN
12877 ISUBHD=MINT(1)
12878 NSAV=N
12879 NPARTS=NPART
12880C...Store hard scattering variables
12881 M15SV=MINT(15)
12882 M16SV=MINT(16)
12883 M21SV=MINT(21)
12884 M22SV=MINT(22)
12885 DO 100 J=11,80
12886 VINTSV(J)=VINT(J)
12887 100 CONTINUE
12888 DO 120 J=1,5
12889 DO 110 IS=1,4
12890 I=IS+MINT(84)
12891 PSAV(IS,J)=P(I,J)
12892 KSAV(IS,J)=K(I,J)
12893 VSAV(IS,J)=V(I,J)
12894 110 CONTINUE
12895 120 CONTINUE
12896
12897C...Set shat for hardest scattering
12898 SHAT(1)=VINT(44)
12899 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12900 & *VINT(2)
12901
12902C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12903 RMC=PMAS(4,1)
12904 RMB=PMAS(5,1)
12905 ALAM4=PARP(61)
12906 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12907 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12908 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12909
12910C----------------------------------------------------------------------
12911C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12912C...interaction initiators, with no previous evolution. Check the input
12913C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12914C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12915C...smaller than the CM energy / 2.)
12916 ELSEIF (MODE.EQ.0) THEN
12917C...Reset counters and switches
12918 N=NSAV
12919 NPART=NPARTS
12920 MINT(30)=0
12921 MINT(31)=1
12922 MINT(36)=1
12923C...Reset hard scattering variables
12924 MINT(1)=ISUBHD
12925 DO 130 J=11,80
12926 VINT(J)=VINTSV(J)
12927 130 CONTINUE
12928 DO 150 J=1,5
12929 DO 140 IS=1,4
12930 I=IS+MINT(84)
12931 P(I,J)=PSAV(IS,J)
12932 K(I,J)=KSAV(IS,J)
12933 V(I,J)=VSAV(IS,J)
12934 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12935 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12936 140 CONTINUE
12937 150 CONTINUE
12938C...Reset statistics on activity in event.
12939 DO 160 J=351,359
12940 MINT(J)=0
12941 VINT(J)=0D0
12942 160 CONTINUE
12943C...Reset extra companion reweighting factor
12944 VINT(140)=1D0
12945
12946C...We do not generate MI for soft process (ISUB=95), but the
12947C...initialization must be done regardless, for later purposes.
12948 MINT(36)=1
12949
12950C...Initialize multiple interactions.
12951 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12952 IF(MINT(51).NE.0) RETURN
12953
12954C...Decide whether quarks in hard scattering were valence or sea
12955 PT2HD=VINT(54)
12956 DO 170 JS=1,2
12957 MINT(30)=JS
12958 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12959 IF(MINT(51).NE.0) RETURN
12960 170 CONTINUE
12961
12962C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12963 VINT(18)=0D0
12964 IF(MSTP(70).EQ.0) THEN
12965 PT20=PARP(62)**2
12966 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12967 ELSEIF(MSTP(70).EQ.1) THEN
12968 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12969 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12970 ELSE
12971 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12972 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12973 ENDIF
12974C...Also store PT2MIN in VINT(17).
12975 180 VINT(17)=PT2MIN
12976
12977C...Set FS masses zero now.
12978 VINT(63)=0D0
12979 VINT(64)=0D0
12980
12981C...Initialize IS showers with VINT(56) as max scale.
12982 PT2ISR=VINT(56)
12983 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12984 IF(MINT(51).NE.0) RETURN
12985
12986 RETURN
12987
12988C----------------------------------------------------------------------
12989C...MODE= 1: Evolve event from PTMAX to PTMIN.
12990 ELSEIF (MODE.EQ.1) THEN
12991
12992C...Skip if no phase space.
12993 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12994
12995C...Starting pT2 max scale (to be udpated successively).
12996 PT2CMX=PT2MAX
12997
12998C...Evolve two sides of the event to find which branches at highest pT.
12999 200 JSMX=-1
13000 MIMX=0
13001 PT2MX=0D0
13002
13003C...Loop over current shower initiators.
13004 IF (MSTP(61).GE.1) THEN
13005 DO 230 MI=1,MINT(31)
13006 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13007 ISUB=96
13008 IF (MI.EQ.1) ISUB=ISUBHD
13009 MINT(1)=ISUB
13010 MINT(36)=MI
13011C...Set up shat, initiator x values, and x remaining in BR.
13012 VINT(44)=SHAT(MI)
13013 VINT(141)=XMI(1,MI)
13014 VINT(142)=XMI(2,MI)
13015 VINT(143)=1D0
13016 VINT(144)=1D0
13017 DO 210 JI=1,MINT(31)
13018 IF (JI.EQ.MINT(36)) GOTO 210
13019 VINT(143)=VINT(143)-XMI(1,JI)
13020 VINT(144)=VINT(144)-XMI(2,JI)
13021 210 CONTINUE
13022C...Loop over sides.
13023C...Generate trial branchings for this interaction. The hardest
13024C...branching so far is automatically updated if necessary in /PYISMX/.
13025 DO 220 JS=1,2
13026 MINT(30)=JS
13027 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13028 IF (MINT(51).NE.0) RETURN
13029 220 CONTINUE
13030 230 CONTINUE
13031 ENDIF
13032
13033C...Generate trial additional interaction.
13034 MINT(36)=MINT(31)+1
13035 240 IF (MOD(MSTP(81),10).GE.1) THEN
13036 MINT(1)=96
13037C...Set up X remaining in BR.
13038 VINT(143)=1D0
13039 VINT(144)=1D0
13040 DO 250 JI=1,MINT(31)
13041 VINT(143)=VINT(143)-XMI(1,JI)
13042 VINT(144)=VINT(144)-XMI(2,JI)
13043 250 CONTINUE
13044C...Generate trial interaction
13045 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13046 IF (MINT(51).EQ.1) RETURN
13047 ENDIF
13048
13049C...And the winner is:
13050 IF (PT2MX.LT.PT2MIN) THEN
13051 GOTO 330
13052 ELSEIF (JSMX.EQ.0) THEN
13053C...Accept additional interaction (may still fail).
13054 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13055 IF(MINT(51).NE.0) RETURN
13056 IF (IFAIL.EQ.0) THEN
13057 SHAT(MINT(36))=VINT(44)
13058C...Decide on flavours (valence/sea/companion).
13059 DO 270 JS=1,2
13060 MINT(30)=JS
13061 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13062 IF(MINT(51).NE.0) RETURN
13063 270 CONTINUE
13064 ENDIF
13065 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13066C...Reconstruct kinematics of acceptable ISR branching.
13067C...Set up shat, initiator x values, and x remaining in BR.
13068 MINT(30)=JSMX
13069 MINT(36)=MIMX
13070 VINT(44)=SHAT(MINT(36))
13071 VINT(141)=XMI(1,MINT(36))
13072 VINT(142)=XMI(2,MINT(36))
13073 VINT(143)=1D0
13074 VINT(144)=1D0
13075 DO 280 JI=1,MINT(31)
13076 IF (JI.EQ.MINT(36)) GOTO 280
13077 VINT(143)=VINT(143)-XMI(1,JI)
13078 VINT(144)=VINT(144)-XMI(2,JI)
13079 280 CONTINUE
13080 PT2NEW=PT2MX
13081 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13082 IF (MINT(51).EQ.1) RETURN
13083 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13084C...Bookeep joining. Cannot (yet) be constructed kinematically.
13085 MINT(354)=MINT(354)+1
13086 VINT(354)=VINT(354)+SQRT(PT2MX)
13087 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13088 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13089 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13090 ENDIF
13091
13092C...Update PT2 iteration scale.
13093 PT2CMX=PT2MX
13094
13095C...Loop back to continue evolution.
13096 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13097 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13098 ELSE
13099 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13100 ENDIF
13101
13102C----------------------------------------------------------------------
13103C...MODE= 2: (Re-)store user information on hardest interaction etc.
13104 ELSEIF (MODE.EQ.2) THEN
13105
13106C...Revert to "ordinary" meanings of some parameters.
13107 290 DO 310 JS=1,2
13108 MINT(12+JS)=K(IMI(JS,1,1),2)
13109 VINT(140+JS)=XMI(JS,1)
13110 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13111 VINT(142+JS)=1D0
13112 DO 300 MI=1,MINT(31)
13113 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13114 300 CONTINUE
13115 310 CONTINUE
13116
13117C...Restore saved quantities for hardest interaction.
13118 MINT(1)=ISUBHD
13119 MINT(15)=M15SV
13120 MINT(16)=M16SV
13121 MINT(21)=M21SV
13122 MINT(22)=M22SV
13123 DO 320 J=11,80
13124 VINT(J)=VINTSV(J)
13125 320 CONTINUE
13126
13127 ENDIF
13128
13129 330 RETURN
13130 END
13131
13132C*********************************************************************
13133
13134C...PYSSPA
13135C...Generates spacelike parton showers.
13136
13137 SUBROUTINE PYSSPA(IPU1,IPU2)
13138
13139C...Double precision and integer declarations.
13140 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13141 IMPLICIT INTEGER(I-N)
13142 INTEGER PYK,PYCHGE,PYCOMP
13143C...Commonblocks.
13144 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13145 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13146 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13147 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13149 COMMON/PYINT1/MINT(400),VINT(400)
13150 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13151 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13152 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13153 &/PYINT2/,/PYINT3/
13154C...Local arrays and data.
13155 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13156 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13157 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13158 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13159 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13160 DATA IS/2*0/
13161
13162C...Read out basic information; set global Q^2 scale.
13163 IPUS1=IPU1
13164 IPUS2=IPU2
13165 ISUB=MINT(1)
13166 Q2MX=VINT(56)
13167 VINT2R=VINT(2)*VINT(143)*VINT(144)
13168 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13169 &MIN(VINT2R,PARP(67)*VINT(56))
13170 FCQ2MX=1D0
13171
13172C...Define which processes ME corrections have been implemented for.
13173 MECOR=0
13174 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13175 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13176 & ISUB.EQ.144) MECOR=1
13177 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13178 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13179 ENDIF
13180
13181C...Initialize QCD evolution and check phase space.
13182 Q2MNC=PARP(62)**2
13183 Q2MNCS(1)=Q2MNC
13184 Q2MNCS(2)=Q2MNC
13185 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13186 Q0S=PARP(15)**2
13187 PS=VINT(3)**2
13188 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13189 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13190 Q2INT=SQRT(Q0S*Q2EFF)
13191 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13192 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13193 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13194 ENDIF
13195 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13196 Q0S=PARP(15)**2
13197 PS=VINT(4)**2
13198 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13199 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13200 Q2INT=SQRT(Q0S*Q2EFF)
13201 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13202 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13203 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13204 ENDIF
13205 MCEV=0
13206 ALAMS=PARU(112)
13207 PARU(112)=PARP(61)
13208 FQ2C=1D0
13209 TCMX=0D0
13210 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13211 MCEV=1
13212 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13213 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13214 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13215 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13216 & MCEV=0
13217 ENDIF
13218
13219C...Initialize QED evolution and check phase space.
13220 MEEV=0
13221 XEE=1D-10
13222 SPME=PMAS(11,1)**2
13223 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13224 &SPME=PMAS(13,1)**2
13225 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13226 &SPME=PMAS(15,1)**2
13227 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13228 TEMX=0D0
13229 FWTE=10D0
13230 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13231 MEEV=1
13232 TEMX=LOG(Q2MX/SPME)
13233 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13234 ENDIF
13235 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13236 MEEV=2
13237 TEMX=TCMX
13238 FWTE=1D0
13239 ENDIF
13240 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13241
13242C...Loopback point in case of failure to reconstruct kinematics.
13243 NS=N
13244 LOOP=0
13245 MNT352=MINT(352)
13246 MNT353=MINT(353)
13247 VNT352=VINT(352)
13248 VNT353=VINT(353)
13249 100 LOOP=LOOP+1
13250 IF(LOOP.GT.100) THEN
13251 MINT(51)=1
13252 RETURN
13253 ENDIF
13254 N=NS
13255 MINT(352)=MNT352
13256 MINT(353)=MNT353
13257 VINT(352)=VNT352
13258 VINT(353)=VNT353
13259
13260C...Initial values: flavours, momenta, virtualities.
13261 DO 120 JT=1,2
13262 MORE(JT)=1
13263 KFBEAM(JT)=MINT(10+JT)
13264 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13265 KFLS(JT)=MINT(14+JT)
13266 KFLS(JT+2)=KFLS(JT)
13267 XS(JT)=VINT(40+JT)
13268 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13269 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13270 ZS(JT)=1D0
13271 Q2S(JT)=FCQ2MX*Q2MX
13272 DQ2(JT)=0D0
13273 TEVCSV(JT)=TCMX
13274 ALAM(JT)=PARP(61)
13275 THE2(JT)=1D0
13276 TEVESV(JT)=TEMX
13277 MCESV(JT)=0
13278C...Calculate initial parton distribution weights.
13279 MINT(105)=MINT(102+JT)
13280 MINT(109)=MINT(106+JT)
13281 VINT(120)=VINT(2+JT)
13282C.... ALICE
13283C.... Store side in MINT(124)
13284 MINT(124) = JT
13285C....
13286 IF(XS(JT).LT.1D0-XEE) THEN
13287 IF(MINT(31).GE.2) MINT(30)=JT
13288 IF(MSTP(57).LE.1) THEN
13289 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13290 ELSE
13291 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13292 ENDIF
13293 ENDIF
13294 DO 110 KFL=-25,25
13295 XFS(JT,KFL)=XFB(KFL)
13296 110 CONTINUE
13297C...Special kinematics check for c/b quarks (that g -> c cbar or
13298C...b bbar kinematically possible).
13299 KFLCB=IABS(KFLS(JT))
13300 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13301 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13302 MINT(51)=1
13303 RETURN
13304 ENDIF
13305 ENDIF
13306 120 CONTINUE
13307 DSH=VINT(44)
13308 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13309
13310C...Find if interference with final state partons.
13311 MFIS=0
13312 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13313 IF(MFIS.NE.0) THEN
13314 DO 140 I=1,2
13315 KCFI(I)=0
13316 KCA=PYCOMP(IABS(KFLS(I)))
13317 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13318 NFIS(I)=0
13319 IF(KCFI(I).NE.0) THEN
13320 IF(I.EQ.1) IPFS=IPUS1
13321 IF(I.EQ.2) IPFS=IPUS2
13322 DO 130 J=1,2
13323 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13324 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13325 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13326 NFIS(I)=NFIS(I)+1
13327 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13328 & P(ICSI,2)**2))
13329 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13330 ENDIF
13331 130 CONTINUE
13332 ENDIF
13333 140 CONTINUE
13334 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13335 ENDIF
13336
13337C...Pick up leg with highest virtuality.
13338 JTOLD=1
13339 150 N=N+1
13340 JT=1
13341 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13342 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13343 IF(MORE(JT).EQ.0) JT=3-JT
13344 JTOLD=JT
13345 KFLB=KFLS(JT)
13346 XB=XS(JT)
13347 DO 160 KFL=-25,25
13348 XFB(KFL)=XFS(JT,KFL)
13349 160 CONTINUE
13350 DSHR=2D0*SQRT(DSH)
13351 DSHZ=DSH/ZS(JT)
13352
13353C...Check if allowed to branch.
13354 MCEV=0
13355 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13356 MCEV=1
13357 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13358 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13359 ENDIF
13360 MEEV=0
13361 IF(MINT(44+JT).EQ.3) THEN
13362 MEEV=1
13363 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13364 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13365 & MEEV=0
13366C***Currently kill QED shower for resolved photoproduction.
13367 IF(MINT(18+JT).EQ.1) MEEV=0
13368C***Currently kill shower for W inside electron.
13369 IF(IABS(KFLB).EQ.24) THEN
13370 MCEV=0
13371 MEEV=0
13372 ENDIF
13373 ENDIF
13374 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13375 &MEEV=2
13376 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13377 Q2B=0D0
13378 GOTO 260
13379 ENDIF
13380
13381C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13382 Q2B=Q2S(JT)
13383 TEVCB=TEVCSV(JT)
13384 TEVEB=TEVESV(JT)
13385 IF(MSTP(62).LE.1) THEN
13386 IF(ZS(JT).GT.0.99999D0) THEN
13387 Q2B=Q2S(JT)
13388 ELSE
13389 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13390 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13391 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13392 ENDIF
13393 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13394 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13395 ENDIF
13396 IF(MCEV.EQ.1) THEN
13397 ALSDUM=PYALPS(FQ2C*Q2B)
13398 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13399 ALAM(JT)=PARU(117)
13400 B0=(33D0-2D0*MSTU(118))/6D0
13401 ENDIF
13402 IF(MEEV.EQ.2) TEVEB=TEVCB
13403 TEVCBS=TEVCB
13404 TEVEBS=TEVEB
13405
13406C...Select side for interference with final state partons.
13407 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13408 IFI=N-NS
13409 ISFI(IFI)=0
13410 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13411 ISFI(IFI)=1
13412 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13413 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13414 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13415 ISFI(IFI)=1
13416 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13417 ENDIF
13418 ENDIF
13419
13420C...Calculate preweighting factor for ME-corrected processes.
13421 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13422
13423C...Calculate Altarelli-Parisi weights.
13424 DO 170 KFL=-25,25
13425 WTAPC(KFL)=0D0
13426 WTAPE(KFL)=0D0
13427 WTSF(KFL)=0D0
13428 170 CONTINUE
13429C...q -> q (g or gamma emission), g -> q.
13430 IF(IABS(KFLB).LE.10) THEN
13431 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13432 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13433 EQ2=1D0/9D0
13434 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13435 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13436 & (XEC*(1D0-XEC)))
13437 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13438 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13439 WTAPC(21)=WTGF*WTAPC(21)
13440 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13441 ENDIF
13442C...f -> f, gamma -> f.
13443 ELSEIF(IABS(KFLB).LE.20) THEN
13444 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13445 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13446 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13447 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13448 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13449 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13450 WTAPE(22)=WTGF*WTAPE(22)
13451 ENDIF
13452C...f -> g, g -> g.
13453 ELSEIF(KFLB.EQ.21) THEN
13454 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13455 DO 180 KFL=1,MSTP(58)
13456 WTAPC(KFL)=WTAPQ
13457 WTAPC(-KFL)=WTAPQ
13458 180 CONTINUE
13459 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13460 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13461 DO 190 KFL=1,MSTP(58)
13462 WTAPC(KFL)=WTFG*WTAPC(KFL)
13463 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13464 190 CONTINUE
13465 WTAPC(21)=WTGG*WTAPC(21)
13466 ENDIF
13467C...f -> gamma, W+, W-.
13468 ELSEIF(KFLB.EQ.22) THEN
13469 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13470 WTAPE(11)=WTAPF
13471 WTAPE(-11)=WTAPF
13472 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13473 WTAPE(11)=WTFG*WTAPE(11)
13474 WTAPE(-11)=WTFG*WTAPE(-11)
13475 ENDIF
13476 ELSEIF(KFLB.EQ.24) THEN
13477 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13478 & (XEE*(XB+XEE)))/XB
13479 ELSEIF(KFLB.EQ.-24) THEN
13480 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13481 & (XEE*(XB+XEE)))/XB
13482 ENDIF
13483
13484C...Calculate parton distribution weights and sum.
13485 NTRY=0
13486 200 NTRY=NTRY+1
13487 IF(NTRY.GT.500) THEN
13488 MINT(51)=1
13489 RETURN
13490 ENDIF
13491 WTSUMC=0D0
13492 WTSUME=0D0
13493 XFBO=MAX(1D-10,XFB(KFLB))
13494 DO 210 KFL=-25,25
13495 WTSF(KFL)=XFB(KFL)/XFBO
13496 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13497 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13498 210 CONTINUE
13499 WTSUMC=MAX(0.0001D0,WTSUMC)
13500 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13501
13502C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13503 NTRY2=0
13504 220 NTRY2=NTRY2+1
13505 IF(NTRY2.GT.500) THEN
13506 MINT(51)=1
13507 RETURN
13508 ENDIF
13509 IF(MCEV.EQ.1) THEN
13510 IF(MSTP(64).LE.0) THEN
13511 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13512 ELSEIF(MSTP(64).EQ.1) THEN
13513 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13514 ELSE
13515 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13516 ENDIF
13517 ENDIF
13518 IF(MEEV.EQ.1) THEN
13519 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13520 & (PARU(101)*FWTE*WTSUME*TEMX)))
13521 ELSEIF(MEEV.EQ.2) THEN
13522 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13523 ENDIF
13524
13525C...Translate t into Q2 scale; choose between QCD and QED evolution.
13526 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13527 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13528 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13529C...Ensure that Q2 is above threshold for charm/bottom.
13530 KFLCB=IABS(KFLB)
13531 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13532 &MCEV.EQ.1) THEN
13533 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13534 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13535 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13536 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13537 ENDIF
13538 ENDIF
13539 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13540 &MEEV.EQ.2) THEN
13541 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13542 ENDIF
13543 MCE=0
13544 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13545 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13546 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13547 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13548 IF(Q2EB.GT.Q2MNE) MCE=2
13549 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13550 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13551 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13552 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13553 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13554 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13555 MCE=1
13556 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13557 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13558 ELSE
13559 MCE=2
13560 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13561 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13562 ENDIF
13563
13564C...Evolution possibly ended. Update t values.
13565 IF(MCE.EQ.0) THEN
13566 Q2B=0D0
13567 GOTO 260
13568 ELSEIF(MCE.EQ.1) THEN
13569 Q2B=Q2CB
13570 Q2REF=FQ2C*Q2B
13571 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13572 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13573 ELSE
13574 Q2B=Q2EB
13575 Q2REF=Q2B
13576 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13577 ENDIF
13578
13579C...Select flavour for branching parton.
13580 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13581 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13582 KFLA=-25
13583 240 KFLA=KFLA+1
13584 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13585 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13586 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13587 IF(KFLA.EQ.25) THEN
13588 Q2B=0D0
13589 GOTO 260
13590 ENDIF
13591
13592C...Choose z value and corrective weight.
13593 WTZ=0D0
13594C...q -> q + g or q -> q + gamma.
13595 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13596 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13597 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13598 WTZ=0.5D0*(1D0+Z**2)
13599C...q -> g + q.
13600 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13601 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13602 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13603C...f -> f + gamma.
13604 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13605 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13606 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13607 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13608 ELSE
13609 Z=XB+XB*(XEE/(1D0-XEE))*
13610 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13611 ENDIF
13612 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13613C...f -> gamma + f.
13614 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
13615 Z=XB+XB*(XEE/(1D0-XEE))*
13616 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13617 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
13618C...f -> W+- + f.
13619 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13620 Z=XB+XB*(XEE/(1D0-XEE))*
13621 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13622 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13623 & (Q2B/(Q2B+PMAS(24,1)**2))
13624C...g -> q + qbar.
13625 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13626 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13627 WTZ=1D0-2D0*Z*(1D0-Z)
13628C...g -> g + g.
13629 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13630 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13631 WTZ=(1D0-Z*(1D0-Z))**2
13632C...gamma -> f + fbar.
13633 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13634 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13635 WTZ=1D0-2D0*Z*(1D0-Z)
13636 ENDIF
13637 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13638
13639C...Option with resummation of soft gluon emission as effective z shift.
13640 IF(MCE.EQ.1) THEN
13641 IF(MSTP(65).GE.1) THEN
13642 RSOFT=6D0
13643 IF(KFLB.NE.21) RSOFT=8D0/3D0
13644 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13645 IF(Z.LE.XB) GOTO 220
13646 ENDIF
13647
13648C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13649 IF(MSTP(64).GE.2) THEN
13650 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13651 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13652 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13653 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13654 ENDIF
13655 ENDIF
13656
13657C...Remove kinematically impossible branchings.
13658 UHAT=Q2B-DSH*(1D0-Z)/Z
13659 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13660
13661C...Select phi angle of branching at random.
13662 PHIBR=PARU(2)*PYR(0)
13663
13664C...Matrix-element corrections for some processes.
13665 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13666 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13667 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13668 WTZ=WTZ*WTME/WTFF
13669 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13670 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13671 WTZ=WTZ*WTME/WTGF
13672 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13673 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13674 WTZ=WTZ*WTME/WTFG
13675 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13676 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13677 WTZ=WTZ*WTME/WTGG
13678 ENDIF
13679 ENDIF
13680
13681C...Impose angular constraint in first branching from interference
13682C...with final state partons.
13683 IF(MCE.EQ.1) THEN
13684 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13685 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13686 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13687 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13688 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13689 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13690 ENDIF
13691 ENDIF
13692
13693C...Option with angular ordering requirement.
13694 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13695 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13696 IF(THE2T.GT.THE2(JT)) GOTO 220
13697 ENDIF
13698 ENDIF
13699
13700C...Weighting with new parton distributions.
13701 MINT(105)=MINT(102+JT)
13702 MINT(109)=MINT(106+JT)
13703 VINT(120)=VINT(2+JT)
13704C.... ALICE
13705C.... Store side in MINT(124)
13706 MINT(124)=JT
13707C....
13708 IF(MINT(31).GE.2) MINT(30)=JT
13709 IF(MSTP(57).LE.1) THEN
13710 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13711 ELSE
13712 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13713 ENDIF
13714 XFBN=XFN(KFLB)
13715 IF(XFBN.LT.1D-20) THEN
13716 IF(KFLA.EQ.KFLB) THEN
13717 TEVCB=TEVCBS
13718 TEVEB=TEVEBS
13719 WTAPC(KFLB)=0D0
13720 WTAPE(KFLB)=0D0
13721 GOTO 200
13722 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13723 TEVCB=0.5D0*(TEVCBS+TEVCB)
13724 GOTO 230
13725 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13726 TEVEB=0.5D0*(TEVEBS+TEVEB)
13727 GOTO 230
13728 ELSE
13729 XFBN=1D-10
13730 XFN(KFLB)=XFBN
13731 ENDIF
13732 ENDIF
13733 DO 250 KFL=-25,25
13734 XFB(KFL)=XFN(KFL)
13735 250 CONTINUE
13736 XA=XB/Z
13737C.... ALICE
13738C.... Store side in MINT(124)
13739 MINT(124) = JT
13740C....
13741 IF(MINT(31).GE.2) MINT(30)=JT
13742 IF(MSTP(57).LE.1) THEN
13743 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13744 ELSE
13745 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13746 ENDIF
13747 XFAN=XFA(KFLA)
13748 IF(XFAN.LT.1D-20) GOTO 200
13749 WTSFA=WTSF(KFLA)
13750 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13751
13752C...Define two hard scatterers in their CM-frame.
13753 260 IF(N.EQ.NS+2) THEN
13754 DQ2(JT)=Q2B
13755 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13756 DO 280 JR=1,2
13757 I=NS+JR
13758 IF(JR.EQ.1) IPO=IPUS1
13759 IF(JR.EQ.2) IPO=IPUS2
13760 DO 270 J=1,5
13761 K(I,J)=0
13762 P(I,J)=0D0
13763 V(I,J)=0D0
13764 270 CONTINUE
13765 K(I,1)=14
13766 K(I,2)=KFLS(JR+2)
13767 K(I,4)=IPO
13768 K(I,5)=IPO
13769 P(I,3)=DPLCM*(-1)**(JR+1)
13770 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13771 P(I,5)=-SQRT(DQ2(JR))
13772 K(IPO,1)=14
13773 K(IPO,3)=I
13774 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13775 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13776 280 CONTINUE
13777
13778C...Find maximum allowed mass of timelike parton.
13779 ELSEIF(N.GT.NS+2) THEN
13780 JR=3-JT
13781 DQ2(3)=Q2B
13782 DPC(1)=P(IS(1),4)
13783 DPC(2)=P(IS(2),4)
13784 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13785 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13786 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13787 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13788 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13789 IKIN=0
13790 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13791 & 1D-10*DPD(1)) IKIN=1
13792 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13793 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13794 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13795 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13796
13797C...Generate timelike parton shower (if required).
13798 IT=N
13799 DO 290 J=1,5
13800 K(IT,J)=0
13801 P(IT,J)=0D0
13802 V(IT,J)=0D0
13803 290 CONTINUE
13804C...f -> f + g (gamma).
13805 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13806 K(IT,2)=21
13807 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13808C...f -> g (gamma, W+-) + f.
13809 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13810 K(IT,2)=KFLB
13811 IF(KFLS(JT+2).EQ.24) THEN
13812 K(IT,2)=-12
13813 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13814 K(IT,2)=12
13815 ENDIF
13816C...g (gamma) -> f + fbar, g + g.
13817 ELSE
13818 K(IT,2)=-KFLS(JT+2)
13819 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13820 ENDIF
13821 K(IT,1)=3
13822 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13823 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13824 P(IT,5)=PYMASS(K(IT,2))
13825 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13826 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13827 MSTJ48=MSTJ(48)
13828 PARJ85=PARJ(85)
13829 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13830 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13831 IF(MSTP(63).EQ.1) THEN
13832 Q2TIM=DMSMA
13833 ELSEIF(MSTP(63).EQ.2) THEN
13834 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13835 ELSE
13836 Q2TIM=DMSMA
13837 MSTJ(48)=1
13838 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13839 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13840 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13841 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13842 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13843 ENDIF
13844 if(parj(200).ne.1.) CALL PYSHOW(IT,0,SQRT(Q2TIM))
13845 if(parj(200).eq.1.) CALL PYSHOWQ(IT,0,SQRT(Q2TIM))
13846 MSTJ(48)=MSTJ48
13847 PARJ(85)=PARJ85
13848 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13849 ENDIF
13850
13851C...Reconstruct kinematics of branching: timelike parton shower.
13852 DMS=P(IT,5)**2
13853 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13854 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13855 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13856 & (4D0*DSH*DPC(3)**2)
13857 IF(DPT2.LT.0D0) GOTO 100
13858 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13859 & DSHR)/DPC(3)-DPC(3)
13860 P(IT,1)=SQRT(DPT2)
13861 P(IT,3)=DPB(1)*(-1)**(JT+1)
13862 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13863 IF(N.GE.IT+1) THEN
13864 DPB(1)=SQRT(DPB(1)**2+DPT2)
13865 DPB(2)=SQRT(DPB(1)**2+DMS)
13866 DPB(3)=P(IT+1,3)
13867 DPB(4)=SQRT(DPB(3)**2+DMS)
13868 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13869 & DPB(1))
13870 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13871 THE=PYANGL(P(IT,3),P(IT,1))
13872 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13873 ENDIF
13874
13875C...Reconstruct kinematics of branching: spacelike parton.
13876 DO 300 J=1,5
13877 K(N+1,J)=0
13878 P(N+1,J)=0D0
13879 V(N+1,J)=0D0
13880 300 CONTINUE
13881 K(N+1,1)=14
13882 K(N+1,2)=KFLB
13883 P(N+1,1)=P(IT,1)
13884 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13885 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13886 P(N+1,5)=-SQRT(DQ2(3))
13887
13888C...Define colour flow of branching.
13889 K(IS(JT),3)=N+1
13890 K(IT,3)=N+1
13891 IM1=N+1
13892 IM2=N+1
13893C...f -> f + gamma (Z, W).
13894 IF(IABS(K(IT,2)).GE.22) THEN
13895 K(IT,1)=1
13896 ID1=IS(JT)
13897 ID2=IS(JT)
13898C...f -> gamma (Z, W) + f.
13899 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13900 ID1=IT
13901 ID2=IT
13902C...gamma -> q + qbar, g + g.
13903 ELSEIF(K(N+1,2).EQ.22) THEN
13904 ID1=IS(JT)
13905 ID2=IT
13906 IM1=ID2
13907 IM2=ID1
13908C...q -> q + g.
13909 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13910 ID1=IT
13911 ID2=IS(JT)
13912C...q -> g + q.
13913 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13914 ID1=IS(JT)
13915 ID2=IT
13916C...qbar -> qbar + g.
13917 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13918 ID1=IS(JT)
13919 ID2=IT
13920C...qbar -> g + qbar.
13921 ELSEIF(K(N+1,2).LT.0) THEN
13922 ID1=IT
13923 ID2=IS(JT)
13924C...g -> g + g; g -> q + qbar.
13925 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13926 ID1=IS(JT)
13927 ID2=IT
13928 ELSE
13929 ID1=IT
13930 ID2=IS(JT)
13931 ENDIF
13932 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13933 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13934 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13935 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13936 IF(ID1.NE.ID2) THEN
13937 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13938 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13939 ENDIF
13940 N=N+1
13941 IF(K(IT,1).EQ.1) THEN
13942 K(IT,4)=0
13943 K(IT,5)=0
13944 ENDIF
13945
13946C...Boost to new CM-frame.
13947 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13948 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13949 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13950 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13951 IR=N+(JT-1)*(IS(1)-N)
13952 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13953 & 0D0,0D0,0D0)
13954
13955C...Global statistics.
13956 MINT(352)=MINT(352)+1
13957 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13958 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13959 ENDIF
13960
13961C...Update kinematics variables.
13962 IS(JT)=N
13963 DQ2(JT)=Q2B
13964 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
13965 DSH=DSHZ
13966
13967C...Save quantities; loop back.
13968 Q2S(JT)=Q2B
13969 DPHI(JT)=PHIBR
13970 MCESV(JT)=MCE
13971 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13972 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13973 KFLS(JT+2)=KFLS(JT)
13974 KFLS(JT)=KFLA
13975 XS(JT)=XA
13976 ZS(JT)=Z
13977 DO 310 KFL=-25,25
13978 XFS(JT,KFL)=XFA(KFL)
13979 310 CONTINUE
13980 TEVCSV(JT)=TEVCB
13981 TEVESV(JT)=TEVEB
13982 ELSE
13983 MORE(JT)=0
13984 IF(JT.EQ.1) IPU1=N
13985 IF(JT.EQ.2) IPU2=N
13986 ENDIF
13987 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13988 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13989 IF(MSTU(21).GE.1) N=NS
13990 IF(MSTU(21).GE.1) RETURN
13991 ENDIF
13992 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13993
13994C...Boost hard scattering partons to frame of shower initiators.
13995 DO 320 J=1,3
13996 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13997 320 CONTINUE
13998 K(N+2,1)=1
13999 DO 330 J=1,5
14000 P(N+2,J)=P(NS+1,J)
14001 330 CONTINUE
14002 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14003 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14004 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14005 IMIN=MINT(83)+5
14006 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14007 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14008 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14009
14010C...Store user information. Reset Lambda value.
14011 IF(MINT(31).LE.1) THEN
14012 K(IPU1,3)=MINT(83)+3
14013 K(IPU2,3)=MINT(83)+4
14014 ELSE
14015 K(IPU1,3)=MINT(83)+1
14016 K(IPU2,3)=MINT(83)+2
14017 ENDIF
14018 DO 340 JT=1,2
14019 MINT(12+JT)=KFLS(JT)
14020 VINT(140+JT)=XS(JT)
14021 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14022 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14023 340 CONTINUE
14024 PARU(112)=ALAMS
14025
14026 RETURN
14027 END
14028C*********************************************************************
14029
14030C...PYPTIS
14031C...Generates pT-ordered spacelike initial-state parton showers and
14032C...trial joinings.
14033C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14034C... interaction initiators at PT2NOW.
14035C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14036C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14037C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14038C... is below PT2CUT.
14039C... (Also generate test joinings if MSTP(96)=1.)
14040C...MODE= 1: Accept stored shower branching. Update event record etc.
14041C...PT2NOW : Starting (max) PT2 scale for evolution.
14042C...PT2CUT : Lower limit for evolution.
14043C...PT2 : Result of evolution. Generated PT2 for trial emission.
14044C...IFAIL : Status return code. IFAIL=0 when all is well.
14045
14046 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
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...Parameter statement for maximum size of showers.
14053 PARAMETER (MAXNUR=1000)
14054C...Commonblocks.
14055 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14056 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14057 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14058 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14059 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14060 COMMON/PYINT1/MINT(400),VINT(400)
14061 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14062 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14063 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14064 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14065 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14066 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14067 COMMON/PYCTAG/NCT,MCT(4000,2)
14068 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14069 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14070 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14071C...Local variables
14072 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14073 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14074 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14075 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14076 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14077 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14078C...For check on excessive weights.
14079 CHARACTER CHWT*12
14080
14081C...Only give errors for very large weights, otherwise just warnings
14082 DATA WTEMAX /1.5D0/
14083C...Only give errors for large pT, otherwise just warnings
14084 DATA PTEMAX /5D0/
14085
14086 IFAIL=-1
14087
14088C----------------------------------------------------------------------
14089C...MODE=-1: Initialize initial state showers from scratch, i.e.
14090C...starting from the hardest interaction initiators.
14091 IF (MODE.EQ.-1) THEN
14092C...Set hard scattering SHAT.
14093 SHTNOW(1)=VINT(44)
14094C...Mass thresholds and Lambda for QCD evolution.
14095 AEM2PI=PARU(101)/PARU(2)
14096 RMB=PMAS(5,1)
14097 RMC=PMAS(4,1)
14098 ALAM4=PARP(61)
14099 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14100 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14101 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14102 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14103 RMB2=RMB**2
14104 RMC2=RMC**2
14105C...Massive quark forced creation threshold (in M**2).
14106 TMIN=1.01D0
14107C...Set upper limit for X (ensures some X left for beam remnant).
14108 XMXC=1D0-2D0*PARP(111)/VINT(1)
14109
14110 IF (MSTP(61).GE.1) THEN
14111C...Initial values: flavours, momenta, virtualities.
14112 DO 100 JS=1,2
14113 NISGEN(JS,1)=0
14114
14115C...Special kinematics check for c/b quarks (that g -> c cbar or
14116C...b bbar kinematically possible).
14117 KFLB=K(IMI(JS,1,1),2)
14118 KFLCB=IABS(KFLB)
14119 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14120C...Check PT2MAX > mQ^2
14121 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14122 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14123 & 'No Q creation possible.')
14124 MINT(51)=1
14125 RETURN
14126 ELSE
14127C...Check for physical z values (m == MQ / sqrt(s))
14128C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14129 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14130 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14131 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14132 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14133 & 'Q creation.')
14134 MINT(51)=1
14135 RETURN
14136 ENDIF
14137 ENDIF
14138 ENDIF
14139 100 CONTINUE
14140 ENDIF
14141
14142 MINT(354)=0
14143C...Zero joining array
14144 DO 110 MJ=1,240
14145 MJOIND(1,MJ)=0
14146 MJOIND(2,MJ)=0
14147 110 CONTINUE
14148
14149C----------------------------------------------------------------------
14150C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14151C...MINT(30). Store if emission PT2 scale is largest so far.
14152C...Also generate test joinings if MSTP(96)=1.
14153 ELSEIF(MODE.EQ.0) THEN
14154 IFAIL=-1
14155 MECOR=0
14156 ISUB=MINT(1)
14157 JS=MINT(30)
14158C...No shower for structureless beam
14159 IF (MINT(44+JS).EQ.1) RETURN
14160 MI=MINT(36)
14161 SHAT=VINT(44)
14162C...Absolute shower max scale = VINT(56)
14163 PT2=MIN(PT2NOW,VINT(56))
14164 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14165C...Define for which processes ME corrections have been implemented.
14166 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14167 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14168 & .142.OR.ISUB.EQ.144) MECOR=1
14169 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14170 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14171C...Calculate preweighting factor for ME-corrected processes.
14172 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14173 ENDIF
14174C...Basic info on daughter for which to find mother.
14175 KFLB=K(IMI(JS,MI,1),2)
14176 KFLBA=IABS(KFLB)
14177C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14178C...second companion.
14179 KSVCB=MAX(-1,IMI(JS,MI,2))
14180C...Treat "first" companion of a pair like an ordinary sea quark
14181C...(except that creation diagram is not allowed)
14182 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14183C...X (rescaled to [0,1])
14184 XB=XMI(JS,MI)/VINT(142+JS)
14185C...Massive quarks (use physical masses.)
14186 RMQ2=0D0
14187 MQMASS=0
14188 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14189 RMQ2=RMC2
14190 IF (KFLBA.EQ.5) RMQ2=RMB2
14191C...Special threshold treatment for non-photon beams
14192 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14193 ENDIF
14194
14195C...Flags for parton distribution calls.
14196 MINT(105)=MINT(102+JS)
14197 MINT(109)=MINT(106+JS)
14198 VINT(120)=VINT(2+JS)
14199
14200C...Calculate initial parton distribution weights.
14201 IF(XB.GE.XMXC) THEN
14202 RETURN
14203 ELSEIF(MQMASS.EQ.0) THEN
14204 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14205 ELSE
14206C...Initialize massive quark PT2 dependent pdf underestimate.
14207 PT20=PT2
14208 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14209C.!.Tentative treatment of massive valence quarks.
14210 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14211 XG0=XFB(21)
14212 TPM0=LOG(PT20/RMQ2)
14213 WPDF0=TPM0*XG0/XQ0
14214 ENDIF
14215 IF (KFLBA.LE.6) THEN
14216C...For quarks, only include respective sea, val, or cmp part.
14217 IF (KSVCB.LE.0) THEN
14218 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14219 ELSE
14220C...Find companion's companion
14221 MISEA=0
14222 120 MISEA=MISEA+1
14223 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14224 XS=XMI(JS,MISEA)
14225 XREM=VINT(142+JS)
14226 YS=XS/(XREM+XS)
14227C...Momentum fraction of the companion quark.
14228C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14229 YB=XB*(1D0-YS)
14230 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14231 ENDIF
14232 ENDIF
14233
14234C...Determine overestimated z range: switch at c and b masses.
14235 130 IF (PT2.GT.TMIN*RMB2) THEN
14236 IZRG=3
14237 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14238 B0=23D0/6D0
14239 ALAM2=ALAM5**2
14240 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14241 IZRG=2
14242 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14243 B0=25D0/6D0
14244 ALAM2=ALAM4**2
14245 ELSE
14246 IZRG=1
14247 PT2MNE=PT2CUT
14248 B0=27D0/6D0
14249 ALAM2=ALAM3**2
14250 ENDIF
14251C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14252 ALAM2=ALAM2/PARP(64)
14253C...Overestimated ZMAX:
14254 IF (MQMASS.EQ.0) THEN
14255C...Massless
14256 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14257 & /PT2MNE)-1D0)
14258 ELSE
14259C...Massive (limit for bremsstrahlung diagram > creation)
14260 FMQ=SQRT(RMQ2/SHTNOW(MI))
14261 ZMAX=1D0/(1D0+FMQ)
14262 ENDIF
14263 ZMIN=XB/XMXC
14264
14265C...If kinematically impossible then do not evolve.
14266 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14267
14268C...Reset Altarelli-Parisi and PDF weights.
14269 DO 140 KFL=-5,5
14270 WTAP(KFL)=0D0
14271 WTPDF(KFL)=0D0
14272 140 CONTINUE
14273 WTAP(21)=0D0
14274 WTPDF(21)=0D0
14275C...Zero joining weights and compute X(partner) and X(mother) values.
14276 IF (MSTP(96).NE.0) THEN
14277 NJN=0
14278 DO 150 MJ=1,MINT(31)
14279 WTAPJ(MJ)=0D0
14280 WTPDFJ(MJ)=0D0
14281 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14282 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14283 & +XMI(JS,MI))
14284 150 CONTINUE
14285 ENDIF
14286
14287C...Approximate Altarelli-Parisi weights (integrated AP dz).
14288C...q -> q, g -> q or q -> q + gamma (already set which).
14289 IF(KFLBA.LE.5) THEN
14290C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14291 IF (KSVCB.LT.0) THEN
14292 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14293 ELSE
14294 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14295 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14296 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14297 ENDIF
14298 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14299 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14300 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14301 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14302 WTAP(KFLB)=WTFF*WTAP(KFLB)
14303 WTAP(21)=WTGF*WTAP(21)
14304 WTAPE=WTFF*WTAPE
14305 ENDIF
14306 IF (KSVCB.GE.1) THEN
14307C...Kill normal creation but add joining diagrams for cmp quark.
14308 WTAP(21)=0D0
14309 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14310 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14311 & " quark here. Not handled yet, giving up!")
14312 PT2=0D0
14313 MINT(51)=1
14314 RETURN
14315 ENDIF
14316C...Check for possible joinings
14317 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14318C...Find companion's companion.
14319 MJ=0
14320 160 MJ=MJ+1
14321 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14322 IF (MJOIND(JS,MJ).EQ.0) THEN
14323 Y(MI)=YB+YS
14324 Z=YB/Y(MI)
14325 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14326 IF (WTAPJ(MJ).GT.1D-6) THEN
14327 NJN=1
14328 ELSE
14329 WTAPJ(MJ)=0D0
14330 ENDIF
14331 ENDIF
14332C...Add trial gluon joinings.
14333 DO 170 MJ=1,MINT(31)
14334 KFLC=K(IMI(JS,MJ,1),2)
14335 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14336 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14337 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14338 IF (WTAPJ(MJ).GT.1D-6) THEN
14339 NJN=NJN+1
14340 ELSE
14341 WTAPJ(MJ)=0D0
14342 ENDIF
14343 170 CONTINUE
14344 ENDIF
14345 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14346C...Kill creation diagram for val quarks and sea quarks with companions.
14347 WTAP(21)=0D0
14348 ELSEIF (MQMASS.EQ.0) THEN
14349C...Extra safety factor for massless sea quark creation.
14350 WTAP(21)=WTAP(21)*1.25D0
14351 ENDIF
14352
14353C... q -> g, g -> g.
14354 ELSEIF(KFLB.EQ.21) THEN
14355C...Here we decide later whether a quark picked up is valence or
14356C...sea, so we maintain the extra factor sqrt(z) since we deal
14357C...with the *sum* of sea and valence in this context.
14358 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14359C...new: do not allow backwards evol to pick up heavy flavour.
14360 DO 180 KFL=1,MIN(3,MSTP(58))
14361 WTAP(KFL)=WTAPQ
14362 WTAP(-KFL)=WTAPQ
14363 180 CONTINUE
14364 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14365 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14366 WTAPQ=WTFG*WTAPQ
14367 WTAP(21)=WTGG*WTAP(21)
14368 ENDIF
14369C...Check for possible joinings (companions handled separately above)
14370 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14371 & THEN
14372 DO 190 MJ=1,MINT(31)
14373 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14374 KSVCC=IMI(JS,MJ,2)
14375 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14376 IF (KSVCC.GE.1) GOTO 190
14377 KFLC=K(IMI(JS,MJ,1),2)
14378C...Only try g -> g + g once.
14379 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14380 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14381 IF (KFLC.EQ.21) THEN
14382 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14383 ELSE
14384 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14385 ENDIF
14386 IF (WTAPJ(MJ).GT.1D-6) THEN
14387 NJN=NJN+1
14388 ELSE
14389 WTAPJ(MJ)=0D0
14390 ENDIF
14391 190 CONTINUE
14392 ENDIF
14393 ENDIF
14394
14395C...Initialize massive quark evolution
14396 IF (MQMASS.NE.0) THEN
14397 RML=(RMQ2+VINT(18))/ALAM2
14398 TML=LOG(RML)
14399 TPL=LOG((PT2+VINT(18))/ALAM2)
14400 TPM=LOG((PT2+VINT(18))/RMQ2)
14401 WN=WTAP(21)*WPDF0/B0
14402 ENDIF
14403
14404
14405C...Loopback point for iteration
14406 NTRY=0
14407 NTHRES=0
14408 200 NTRY=NTRY+1
14409 IF(NTRY.GT.500) THEN
14410 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14411 MINT(51)=1
14412 RETURN
14413 ENDIF
14414
14415C... Calculate PDF weights and sum for evolution rate.
14416 WTSUM=0D0
14417 XFBO=MAX(1D-10,XFB(KFLB))
14418 DO 210 KFL=-5,5
14419 WTPDF(KFL)=XFB(KFL)/XFBO
14420 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14421 210 CONTINUE
14422C...Only add gluon mother diagram for massless KFLB.
14423 IF(MQMASS.EQ.0) THEN
14424 WTPDF(21)=XFB(21)/XFBO
14425 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14426 ENDIF
14427 WTSUM=MAX(0.0001D0,WTSUM)
14428 WTSUMS=WTSUM
14429C...Add joining diagrams where applicable.
14430 WTJOIN=0D0
14431 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14432 DO 220 MJ=1,MINT(31)
14433 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14434 WTPDFJ(MJ)=1D0/XFBO
14435C...x and x*pdf (+ sea/val) for parton C.
14436 KFLC=K(IMI(JS,MJ,1),2)
14437 KFLCA=IABS(KFLC)
14438 KSVCC=MAX(-1,IMI(JS,MJ,2))
14439 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14440 MINT(30)=JS
14441 MINT(36)=MJ
14442 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14443 MINT(36)=MI
14444 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14445 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14446 ELSEIF (KSVCC.GE.1) THEN
14447 print*, 'error! parton C is companion!'
14448 ENDIF
14449 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14450C...x and x*pdf (+ sea/val) for parton A.
14451 KFLA=21
14452 KSVCA=0
14453 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14454 KFLA=KFLB
14455 KSVCA=KSVCB
14456 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14457 KFLA=KFLC
14458 KSVCA=KSVCC
14459 ENDIF
14460 MINT(30)=JS
14461 IF (KSVCA.LE.0) THEN
14462C...Consider C the "evolved" parton if B is gluon. Val/sea
14463C...counting will then be done correctly in PYPDFU.
14464 IF (KFLBA.EQ.21) MINT(36)=MJ
14465 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14466 MINT(36)=MI
14467 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14468 ELSE
14469C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14470 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14471 ENDIF
14472 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14473 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14474 220 CONTINUE
14475 ENDIF
14476
14477C...Pick normal pT2 (in overestimated z range).
14478 230 PT2OLD=PT2
14479 WTSUM=WTSUMS
14480 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14481 KFLC=21
14482
14483C...Evolve q -> q gamma separately, pick it if larger pT.
14484 IF(KFLBA.LE.5) THEN
14485 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14486 IF(PT2QED.GT.PT2) THEN
14487 PT2=PT2QED
14488 KFLC=22
14489 KFLA=KFLB
14490 ENDIF
14491 ENDIF
14492
14493C... Evolve massive quark creation separately.
14494 MCRQQ=0
14495 IF (MQMASS.NE.0) THEN
14496 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14497 & -VINT(18)
14498C... Ensure mininimum PT2CR and force creation near threshold.
14499 IF (PT2CR.LT.TMIN*RMQ2) THEN
14500 NTHRES=NTHRES+1
14501 IF (NTHRES.GT.50) THEN
14502 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14503 & 'massive quark creation. Gave up trying.')
14504 MINT(51)=1
14505 RETURN
14506 ENDIF
14507 PT2=0D0
14508 PT2CR=TMIN*RMQ2
14509 MCRQQ=2
14510 ENDIF
14511C... Select largest PT2 (brems or creation):
14512 IF (PT2CR.GT.PT2) THEN
14513 MCRQQ=MAX(MCRQQ,1)
14514 WTSUM=0D0
14515 PT2=PT2CR
14516 KFLA=21
14517 ELSE
14518 MCRQQ=0
14519 KFLA=KFLB
14520 ENDIF
14521C... Compute logarithms for this PT2
14522 TPL=LOG((PT2+VINT(18))/ALAM2)
14523 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14524 WTCRQQ=TPM/LOG(PT2/RMQ2)
14525 ENDIF
14526
14527C...Evolve joining separately
14528 MJOIN=0
14529 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14530 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14531 & -VINT(18)
14532 IF (PT2JN.GE.PT2) THEN
14533 MJOIN=1
14534 PT2=PT2JN
14535 ENDIF
14536 ENDIF
14537
14538C...Loopback if crossed c/b mass thresholds.
14539 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14540 PT2=RMB2
14541 GOTO 130
14542 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14543 PT2=RMC2
14544 GOTO 130
14545 ENDIF
14546
14547C...Speed up shower. Skip if higher-PT acceptable branching
14548C...already found somewhere else.
14549C...Also finish if below lower cutoff.
14550
14551 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14552
14553C...Select parton A flavour (massive Q handled above.)
14554 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14555 WTRAN=PYR(0)*WTSUM
14556 KFLA=-6
14557 240 KFLA=KFLA+1
14558 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14559 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14560 IF(KFLA.EQ.6) KFLA=21
14561 ELSEIF (MJOIN.EQ.1) THEN
14562C...Tentative joining accept/reject.
14563 WTRAN=PYR(0)*WTJOIN
14564 MJ=0
14565 250 MJ=MJ+1
14566 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14567 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14568 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14569 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14570 & ' Rejected.')
14571 GOTO 230
14572 ENDIF
14573C...x*pdf (+ sea/val) at new pT2 for parton B.
14574 IF (KSVCB.LE.0) THEN
14575 MINT(30)=JS
14576 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14577 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14578 ELSE
14579C...Companion distributions do not evolve.
14580 XFB(KFLB)=XFBO
14581 ENDIF
14582 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14583 KFLC=K(IMI(JS,MJ,1),2)
14584 KFLCA=IABS(KFLC)
14585 KSVCC=MAX(-1,IMI(JS,MJ,2))
14586 IF (KSVCB.GE.1) KSVCC=-1
14587C...x*pdf (+ sea/val) at new pT2 for parton C.
14588 MINT(30)=JS
14589 MINT(36)=MJ
14590 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14591 MINT(36)=MI
14592 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14593 WTVETO=WTVETO/XFJ(KFLC)
14594C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14595 KFLA=21
14596 KSVCA=0
14597 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14598 KFLA=KFLB
14599 KSVCA=KSVCB
14600 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14601 KFLA=KFLC
14602 KSVCA=KSVCC
14603 ENDIF
14604 IF (KSVCA.LE.0) THEN
14605 MINT(30)=JS
14606 IF (KFLB.EQ.21) MINT(36)=MJ
14607 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14608 MINT(36)=MI
14609 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14610 ELSE
14611 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14612 ENDIF
14613 WTVETO=WTVETO*XFJ(KFLA)
14614C...Monte Carlo veto.
14615 IF (WTVETO.LT.PYR(0)) GOTO 200
14616C...If accept, save PT2 of this joining.
14617 IF (PT2.GT.PT2MX) THEN
14618 PT2MX=PT2
14619 JSMX=2+JS
14620 MJN1MX=MJ
14621 MJN2MX=MI
14622 WTAPJ(MJ)=0D0
14623 NJN=0
14624 ENDIF
14625C...Exit and continue evolution.
14626 GOTO 380
14627 ENDIF
14628 KFLAA=IABS(KFLA)
14629
14630C...Choose z value (still in overestimated range) and corrective weight.
14631C...Unphysical z will be rejected below when Q2 has is computed.
14632 WTZ=0D0
14633
14634C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14635C...q -> q + g or q -> q + gamma (already set which).
14636 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14637 IF (KSVCB.LT.0) THEN
14638 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14639 ELSE
14640 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14641 Z=((1-ZFAC)/(1+ZFAC))**2
14642 ENDIF
14643 WTZ=0.5D0*(1D0+Z**2)
14644C...Massive weight correction.
14645 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14646C...Valence quark weight correction (extra sqrt)
14647 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14648
14649C...q -> g + q.
14650C...NB: MQ>0 not yet implemented. Forced absent above.
14651 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14652 KFLC=KFLA
14653 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14654 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14655
14656C...g -> q + qbar.
14657 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14658 KFLC=-KFLB
14659 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14660 WTZ=Z**2+(1D0-Z)**2
14661C...Massive correction
14662 IF (MQMASS.NE.0) THEN
14663 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14664C...Extra safety margin for light sea quark creation
14665 ELSEIF (KSVCB.LT.0) THEN
14666 WTZ=WTZ/1.25D0
14667 ENDIF
14668
14669C...g -> g + g.
14670 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14671 KFLC=21
14672 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14673 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14674 WTZ=(1D0-Z*(1D0-Z))**2
14675 ENDIF
14676
14677C...Derive Q2 from pT2.
14678 Q2B=PT2/(1D0-Z)
14679 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14680
14681C...Loopback if outside allowed z range for given pT2.
14682 RM2C=PYMASS(KFLC)**2
14683 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14684 IF (PT2ADJ.LT.1D-6) GOTO 230
14685
14686C...Loopback if nonordered in angle/rapidity.
14687 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14688 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14689 & GOTO 230
14690 ENDIF
14691
14692C...Select phi angle of branching at random.
14693 PHI=PARU(2)*PYR(0)
14694
14695C...Matrix-element corrections for some processes.
14696 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14697 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14698 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14699 WTZ=WTZ*WTME/WTFF
14700 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14701 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14702 WTZ=WTZ*WTME/WTGF
14703 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14704 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14705 WTZ=WTZ*WTME/WTFG
14706 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14707 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14708 WTZ=WTZ*WTME/WTGG
14709 ENDIF
14710 ENDIF
14711
14712C...Parton distributions at new pT2 but old x.
14713 MINT(30)=JS
14714 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14715C...Treat val and cmp separately
14716 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14717 IF (KSVCB.GE.1)
14718 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14719 XFBN=XFN(KFLB)
14720 IF(XFBN.LT.1D-20) THEN
14721 IF(KFLA.EQ.KFLB) THEN
14722 WTAP(KFLB)=0D0
14723 GOTO 200
14724 ELSE
14725 XFBN=1D-10
14726 XFN(KFLB)=XFBN
14727 ENDIF
14728 ENDIF
14729 DO 260 KFL=-5,5
14730 XFB(KFL)=XFN(KFL)
14731 260 CONTINUE
14732 XFB(21)=XFN(21)
14733
14734C...Parton distributions at new pT2 and new x.
14735 XA=XB/Z
14736 MINT(30)=JS
14737 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14738 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14739C...q -> q + g: only consider respective sea, val, or cmp content.
14740 IF (KSVCB.LE.0) THEN
14741 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14742 ELSE
14743 YA=XA*(1D0-YS)
14744 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14745 ENDIF
14746 ENDIF
14747 XFAN=XFA(KFLA)
14748 IF(XFAN.LT.1D-20) THEN
14749 GOTO 200
14750 ENDIF
14751
14752C...If weighting fails continue evolution.
14753 WTTOT=0D0
14754 IF (MCRQQ.EQ.0) THEN
14755 WTPDFA=1D0/WTPDF(KFLA)
14756 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14757 ELSEIF(MCRQQ.EQ.1) THEN
14758 WTPDFA=TPM/WPDF0
14759 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14760 XBEST=TPM/TPM0*XQ0
14761 ELSEIF(MCRQQ.EQ.2) THEN
14762C...Force massive quark creation.
14763 WTTOT=1D0
14764 ENDIF
14765
14766C...Loop back if trial emission fails.
14767 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14768 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14769 IF(WTTOT.LT.0D0) THEN
14770 WRITE(CHWT,'(1P,E12.4)') WTTOT
14771 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14772 ELSEIF(WTTOT.GT.WTACC) THEN
14773 WRITE(CHWT,'(1P,E12.4)') WTTOT
14774 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14775C...Too high weight: write out as error, but do not update error counter.
14776 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14777 CALL PYERRM(19,
14778 & '(PYPTIS:) Weight '//CHWT//' above unity')
14779 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14780 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14781 ELSE
14782 CALL PYERRM(9,
14783 & '(PYPTIS:) Weight '//CHWT//' above unity')
14784 ENDIF
14785C...Useful for debugging but commented out for distribution:
14786C print*, 'JS, MI',JS, MI
14787C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14788C print*, 'A -> B C',KFLA, KFLB, KFLC
14789C XFAO=XFBO/WTPDFA
14790C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14791 ENDIF
14792
14793C...Save acceptable branching.
14794 IF(PT2.GT.PT2MX) THEN
14795 MIMX=MINT(36)
14796 JSMX=JS
14797 PT2MX=PT2
14798 KFLAMX=KFLA
14799 KFLCMX=KFLC
14800 RM2CMX=RM2C
14801 Q2BMX=Q2B
14802 ZMX=Z
14803 PT2AMX=PT2ADJ
14804 PHIMX=PHI
14805 ENDIF
14806
14807C----------------------------------------------------------------------
14808C...MODE= 1: Accept stored shower branching. Update event record etc.
14809 ELSEIF (MODE.EQ.1) THEN
14810 MI=MIMX
14811 JS=JSMX
14812 SHAT=SHTNOW(MI)
14813 SIDE=3D0-2D0*JS
14814C...Shift down rest of event record to make room for insertion.
14815 IT=IMISEP(MI)+1
14816 IM=IT+1
14817 IS=IMI(JS,MI,1)
14818 DO 280 I=N,IT,-1
14819 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14820 KT1=K(I,4)/MSTU(5)**2
14821 KT2=K(I,5)/MSTU(5)**2
14822 ID1=MOD(K(I,4),MSTU(5))
14823 ID2=MOD(K(I,5),MSTU(5))
14824 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14825 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14826 IF (ID1.GE.IT) ID1=ID1+2
14827 IF (ID2.GE.IT) ID2=ID2+2
14828 IF (IM1.GE.IT) IM1=IM1+2
14829 IF (IM2.GE.IT) IM2=IM2+2
14830 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14831 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14832 DO 270 IX=1,5
14833 K(I+2,IX)=K(I,IX)
14834 P(I+2,IX)=P(I,IX)
14835 V(I+2,IX)=V(I,IX)
14836 270 CONTINUE
14837 MCT(I+2,1)=MCT(I,1)
14838 MCT(I+2,2)=MCT(I,2)
14839 280 CONTINUE
14840 N=N+2
14841C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14842 DO 290 JI=1,MINT(31)
14843 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14844 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14845 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14846 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14847 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14848C...Also update companion pointers to the present mother.
14849 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14850 290 CONTINUE
14851 DO 300 IFS=1,NPART
14852 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14853 300 CONTINUE
14854C...Zero entries dedicated for new timelike and mother partons.
14855 DO 320 I=IT,IT+1
14856 DO 310 J=1,5
14857 K(I,J)=0
14858 P(I,J)=0D0
14859 V(I,J)=0D0
14860 310 CONTINUE
14861 MCT(I,1)=0
14862 MCT(I,2)=0
14863 320 CONTINUE
14864
14865C...Define timelike and new mother partons. History.
14866 K(IT,1)=3
14867 K(IT,2)=KFLCMX
14868 K(IM,1)=14
14869 K(IM,2)=KFLAMX
14870 K(IS,3)=IM
14871 K(IT,3)=IM
14872C...Set mother origin = side.
14873 K(IM,3)=MINT(83)+JS+2
14874 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14875
14876C...Define colour flow of branching.
14877 IM1=IM
14878 IM2=IM
14879C...q -> q + gamma.
14880 IF(K(IT,2).EQ.22) THEN
14881 K(IT,1)=1
14882 ID1=IS
14883 ID2=IS
14884C...q -> q + g.
14885 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14886 ID1=IT
14887 ID2=IS
14888C...q -> g + q.
14889 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14890 ID1=IS
14891 ID2=IT
14892C...qbar -> qbar + g.
14893 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14894 ID1=IS
14895 ID2=IT
14896C...qbar -> g + qbar.
14897 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14898 ID1=IT
14899 ID2=IS
14900C...g -> g + g; g -> q + qbar..
14901 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14902 ID1=IS
14903 ID2=IT
14904 ELSE
14905 ID1=IT
14906 ID2=IS
14907 ENDIF
14908 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14909 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14910 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14911 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14912 IF(ID1.NE.ID2) THEN
14913 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14914 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14915 ENDIF
14916 IF(K(IT,1).EQ.1) THEN
14917 K(IT,4)=0
14918 K(IT,5)=0
14919 ENDIF
14920C...Update IMI and colour tag arrays.
14921 IMI(JS,MI,1)=IM
14922 DO 330 MC=1,2
14923 MCT(IT,MC)=0
14924 MCT(IM,MC)=0
14925 330 CONTINUE
14926 DO 340 JCS=4,5
14927 KCS=JCS
14928C...If mother flag not yet set for spacelike parton, trace it.
14929 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14930 IF(MINT(51).NE.0) RETURN
14931 340 CONTINUE
14932 DO 350 JCS=4,5
14933 KCS=JCS
14934C...If mother flag not yet set for timelike parton, trace it.
14935 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14936 IF(MINT(51).NE.0) RETURN
14937 350 CONTINUE
14938
14939C...Boost recoiling parton to compensate for Q2 scale.
14940 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14941 & (1D0+(1D0+Q2BMX/SHAT)**2)
14942 IR=IMI(3-JS,MI,1)
14943 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14944
14945C...Define system to be rotated and boosted
14946C...(not including the 2 just added partons)
14947C...(but including the docu lines for first interaction)
14948 IMIN=IMISEP(MI-1)+1
14949 IF (MI.EQ.1) IMIN=MINT(83)+5
14950 IMAX=IMISEP(MI)-2
14951
14952C...Rotate back system in phi to compensate for subsequent rotation.
14953 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14954
14955C...Define kinematics of new partons in old frame.
14956 IMAX=IMISEP(MI)
14957 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14958 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14959 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14960 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14961 P(IT,1)=P(IM,1)
14962 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14963 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14964 P(IT,5)=SQRT(RM2CMX)
14965
14966C...Update internal line, now spacelike
14967 P(IS,1)=P(IM,1)-P(IT,1)
14968 P(IS,2)=P(IM,2)-P(IT,2)
14969 P(IS,3)=P(IM,3)-P(IT,3)
14970 P(IS,4)=P(IM,4)-P(IT,4)
14971 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
14972C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
14973 IF (P(IS,5).LT.0D0) THEN
14974 P(IS,5)=-SQRT(ABS(P(IS,5)))
14975 ELSE
14976 P(IS,5)=SQRT(P(IS,5))
14977 ENDIF
14978
14979C...Boost entire system and rotate to new frame.
14980C...(including docu lines)
14981 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14982 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14983 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14984 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14985 MINT(51)=1
14986 IFAIL=-1
14987 RETURN
14988 ENDIF
14989 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14990 I1=IMI(1,MI,1)
14991 THETA=PYANGL(P(I1,3),P(I1,1))
14992 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14993
14994C...Global statistics.
14995 MINT(352)=MINT(352)+1
14996 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14997 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14998
14999C...Add parton with relevant pT scale for timelike shower.
15000 IF (K(IT,2).NE.22) THEN
15001 NPART=NPART+1
15002 IPART(NPART)=IT
15003 PTPART(NPART)=SQRT(PT2AMX)
15004 ENDIF
15005
15006C...Update saved variables.
15007 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15008 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15009 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15010 PT2SAV(JSMX,MIMX)=PT2MX
15011 ZSAV(JS,MIMX)=ZMX
15012
15013 KSA=IABS(K(IS,2))
15014 KMA=IABS(K(IM,2))
15015 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15016C...Gluon reconstructs to quark.
15017C...Decide whether newly created quark is valence or sea:
15018 MINT(30)=JS
15019 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15020 IF(MINT(51).NE.0) RETURN
15021 ENDIF
15022 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15023C...Quark reconstructs to gluon.
15024C...Now some guy may have lost his companion. Check.
15025 ICMP=IMI(JS,MI,2)
15026 IF (ICMP.GT.0) THEN
15027 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15028 & //' away. Cannot handle that yet. Giving up.')
15029 MINT(51)=1
15030 RETURN
15031 ELSEIF(ICMP.LT.0) THEN
15032C...A sea quark with companion still in BR was reconstructed to a gluon.
15033C...Companion should now be removed from the beam remnant.
15034C...(Momentum integral is automatically updated in next call to PYPDFU.)
15035 ICMP=-ICMP
15036 IFL=-K(IS,2)
15037 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
15038 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15039 DO 360 JI=1,MINT(31)
15040 KMI=-IMI(JS,JI,2)
15041 JFL=-K(IMI(JS,JI,1),2)
15042 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15043 & ,2)+1
15044 360 CONTINUE
15045 370 CONTINUE
15046 NVC(JS,IFL)=NVC(JS,IFL)-1
15047 ENDIF
15048C...Set gluon IMI(JS,MI,2) = 0.
15049 IMI(JS,MI,2)=0
15050 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15051C...Quark reconstructing to quark. If sea with companion still in BR
15052C...then update associated x value.
15053C...(Momentum integral is automatically updated in next call to PYPDFU.)
15054 IF (IMI(JS,MI,2).LT.0) THEN
15055 ICMP=-IMI(JS,MI,2)
15056 IFL=-K(IS,2)
15057 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15058 ENDIF
15059 ENDIF
15060
15061 ENDIF
15062
15063C...If reached this point, normal exit.
15064 380 IFAIL=0
15065
15066 RETURN
15067 END
15068
15069C*********************************************************************
15070
15071C...PYMEMX
15072C...Generates maximum ME weight in some initial-state showers.
15073C...Inparameter MECOR: kind of hard scattering process
15074C...Outparameter WTFF: maximum weight for fermion -> fermion
15075C... WTGF: maximum weight for gluon/photon -> fermion
15076C... WTFG: maximum weight for fermion -> gluon/photon
15077C... WTGG: maximum weight for gluon -> gluon
15078
15079 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15080
15081C...Double precision and integer declarations.
15082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15083 IMPLICIT INTEGER(I-N)
15084 INTEGER PYK,PYCHGE,PYCOMP
15085C...Commonblocks.
15086 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15089 COMMON/PYINT1/MINT(400),VINT(400)
15090 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15091 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15092
15093C...Default maximum weight.
15094 WTFF=1D0
15095 WTGF=1D0
15096 WTFG=1D0
15097 WTGG=1D0
15098
15099C...Select maximum weight by process.
15100 IF(MECOR.EQ.1) THEN
15101 WTFF=1D0
15102 WTGF=3D0
15103 ELSEIF(MECOR.EQ.2) THEN
15104 WTFG=1D0
15105 WTGG=1D0
15106 ENDIF
15107
15108 RETURN
15109 END
15110
15111C*********************************************************************
15112
15113C...PYMEWT
15114C...Calculates actual ME weight in some initial-state showers.
15115C...Inparameter MECOR: kind of hard scattering process
15116C... IFLCB: flavour combination of branching,
15117C... 1 for fermion -> fermion,
15118C... 2 for gluon/photon -> fermion
15119C... 3 for fermion -> gluon/photon,
15120C... 4 for gluon -> gluon
15121C... Q2: Q2 value of shower branching
15122C... Z: Z value of branching
15123C...In+outparameter PHIBR: azimuthal angle of branching
15124C...Outparameter WTME: actual ME weight
15125
15126 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15127
15128C...Double precision and integer declarations.
15129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15130 IMPLICIT INTEGER(I-N)
15131 INTEGER PYK,PYCHGE,PYCOMP
15132C...Commonblocks.
15133 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15134 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15135 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15136 COMMON/PYINT1/MINT(400),VINT(400)
15137 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15138 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15139
15140C...Default output.
15141 WTME=1D0
15142
15143C...Define kinematics of shower branching in Mandelstam variables.
15144 SQM=VINT(44)
15145 SH=SQM/Z
15146 TH=-Q2
15147 UH=Q2-SQM*(1D0-Z)/Z
15148
15149C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15150 IF(MECOR.EQ.1) THEN
15151 IF(IFLCB.EQ.1) THEN
15152 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15153 ELSEIF(IFLCB.EQ.2) THEN
15154 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15155 ENDIF
15156
15157C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15158 ELSEIF(MECOR.EQ.2) THEN
15159 IF(IFLCB.EQ.3) THEN
15160 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15161 ELSEIF(IFLCB.EQ.4) THEN
15162 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15163 ENDIF
15164
15165C...Matrix-element corrections for q + qbar -> Higgs (h0)
15166 ELSEIF(MECOR.EQ.3) THEN
15167 IF(IFLCB.EQ.2) THEN
15168 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15169 1 (SH**2+2D0*SQM*(SQM-SH))
15170 ENDIF
15171 ENDIF
15172
15173 RETURN
15174 END
15175
15176C*********************************************************************
15177
15178C...PYPTMI
15179C...Handles the generation of additional interactions in the new
15180C...multiple interactions framework.
15181C...MODE=-1 : Initalize MI from scratch.
15182C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15183C... Sudakov for PT2, abort if below PT2CUT.
15184C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15185C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15186C...PT2NOW : Starting (max) PT2 scale for evolution.
15187C...PT2CUT : Lower limit for evolution.
15188C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15189C...IFAIL : Status return code.
15190C... = 0: All is well.
15191C... < 0: Phase space exhausted, generation to be terminated.
15192C... > 0: Additional interaction vetoed, but continue evolution.
15193
15194 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15195C...Double precision and integer declarations.
15196 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15197 IMPLICIT INTEGER(I-N)
15198 INTEGER PYK,PYCHGE,PYCOMP
15199C...Parameter statement for maximum size of showers.
15200 PARAMETER (MAXNUR=1000)
15201C...Commonblocks.
15202 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15203 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15204 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15205 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15206 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15207 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15208 COMMON/PYINT1/MINT(400),VINT(400)
15209 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15210 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15211 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15212 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15213 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15214 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15215 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15216 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15217 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15218 COMMON/PYCTAG/NCT,MCT(4000,2)
15219C...Local arrays and saved variables.
15220 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15221
15222 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15223 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15224 & /PYISMX/,/PYCTAG/
15225 SAVE XT2FAC,SIGS
15226
15227 IFAIL=0
15228C...Set MI subprocess = QCD 2 -> 2.
15229 ISUB=96
15230
15231C----------------------------------------------------------------------
15232C...MODE=-1: Initialize from scratch
15233 IF (MODE.EQ.-1) THEN
15234C...Initialize PT2 array.
15235 PT2MI(1)=VINT(54)
15236C...Initialize list of incoming beams and partons from two sides.
15237 DO 110 JS=1,2
15238 DO 100 MI=1,240
15239 IMI(JS,MI,1)=0
15240 IMI(JS,MI,2)=0
15241 100 CONTINUE
15242 NMI(JS)=1
15243 IMI(JS,1,1)=MINT(84)+JS
15244 IMI(JS,1,2)=0
15245 XMI(JS,1)=VINT(40+JS)
15246C...Rescale x values to fractions of photon energy.
15247 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15248C...Hard reset: hard interaction initiators motherless by definition.
15249 K(MINT(84)+JS,3)=2+JS
15250 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15251 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15252 110 CONTINUE
15253 IMISEP(0)=MINT(84)
15254 IMISEP(1)=N
15255 IF (MOD(MSTP(81),10).GE.1) THEN
15256 IF(MSTP(82).LE.1) THEN
15257 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15258 & ,5))
15259 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15260 & VINT(317)/(VINT(318)*VINT(320))
15261 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15262 ELSE
15263 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15264 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15265 ENDIF
15266 ENDIF
15267C...Zero entries relating to scatterings beyond the first.
15268 DO 120 MI=2,240
15269 IMI(1,MI,1)=0
15270 IMI(2,MI,1)=0
15271 IMI(1,MI,2)=0
15272 IMI(2,MI,2)=0
15273 IMISEP(MI)=IMISEP(1)
15274 PT2MI(MI)=0D0
15275 XMI(1,MI)=0D0
15276 XMI(2,MI)=0D0
15277 120 CONTINUE
15278C...Initialize factors for PDF reshaping.
15279 DO 140 JS=1,2
15280 KFBEAM(JS)=MINT(10+JS)
15281 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15282 KFABM=IABS(KFBEAM(JS))
15283 KFSBM=ISIGN(1,KFBEAM(JS))
15284
15285C...Zero flavour content of incoming beam particle.
15286 KFIVAL(JS,1)=0
15287 KFIVAL(JS,2)=0
15288 KFIVAL(JS,3)=0
15289C... Flavour content of baryon.
15290 IF(KFABM.GT.1000) THEN
15291 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15292 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15293 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15294C... Flavour content of pi+-, K+-.
15295 ELSEIF(KFABM.EQ.211) THEN
15296 KFIVAL(JS,1)=KFSBM*2
15297 KFIVAL(JS,2)=-KFSBM
15298 ELSEIF(KFABM.EQ.321) THEN
15299 KFIVAL(JS,1)=-KFSBM*3
15300 KFIVAL(JS,2)=KFSBM*2
15301C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15302 ENDIF
15303
15304C...Zero initial valence and companion content.
15305 DO 130 IFL=-6,6
15306 NVC(JS,IFL)=0
15307 130 CONTINUE
15308 140 CONTINUE
15309C...Set up colour line tags starting from hard interaction initiators.
15310 NCT=0
15311C...Reset colour tag array and colour processing flags.
15312 DO 150 I=IMISEP(0)+1,N
15313 MCT(I,1)=0
15314 MCT(I,2)=0
15315 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15316 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15317 150 CONTINUE
15318C... Consider each side in turn.
15319 DO 170 JS=1,2
15320 I1=IMI(JS,1,1)
15321 I2=IMI(3-JS,1,1)
15322 DO 160 JCS=4,5
15323 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15324 & GOTO 160
15325 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15326 KCS=JCS
15327 CALL PYCTTR(I1,KCS,I2)
15328 IF(MINT(51).NE.0) RETURN
15329 160 CONTINUE
15330 170 CONTINUE
15331
15332C...Range checking for companion quark pdf large-x param.
15333 IF (MSTP(87).LT.0) THEN
15334 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15335 & ' MSTP(87)=0')
15336 MSTP(87)=0
15337 ELSEIF (MSTP(87).GT.4) THEN
15338 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15339 & ' MSTP(87)=4')
15340 MSTP(87)=4
15341 ENDIF
15342
15343C----------------------------------------------------------------------
15344C...MODE=0: Generate trial interaction. Return codes:
15345C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15346C...IFAIL = 0: Additional interaction generated at PT2.
15347C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15348 ELSEIF (MODE.EQ.0) THEN
15349C...Abolute MI max scale = VINT(62)
15350 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15351 180 IF(MSTP(82).LE.1) THEN
15352 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15353 IF(XT2.LT.VINT(149)) IFAIL=-2
15354 ELSE
15355 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15356 IFAIL=-3
15357 ELSE
15358 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15359 & LOG(PYR(0)))-VINT(149)
15360 ENDIF
15361 ENDIF
15362C...Also exit if below lower limit or if higher trial branching
15363C...already found.
15364 PT2=0.25D0*VINT(2)*XT2
15365 IF (PT2.LE.PT2CUT) IFAIL=-4
15366 IF (PT2.LE.PT2MX) IFAIL=-5
15367 IF (IFAIL.NE.0) THEN
15368 PT2=0D0
15369 RETURN
15370 ENDIF
15371 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15372 VINT(25)=4D0*PT2/VINT(2)
15373 XT2=VINT(25)
15374
15375C...Choose tau and y*. Calculate cos(theta-hat).
15376 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15377 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15378 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15379 ELSE
15380 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15381 ENDIF
15382 VINT(21)=TAU
15383C...New: require shat > 1.
15384 IF(TAU*VINT(2).LT.1D0) GOTO 180
15385 CALL PYKLIM(2)
15386 RYST=PYR(0)
15387 MYST=1
15388 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15389 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15390 CALL PYKMAP(2,MYST,PYR(0))
15391 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15392
15393C...Check that x not used up. Accept or reject kinematical variables.
15394 X1M=SQRT(TAU)*EXP(VINT(22))
15395 X2M=SQRT(TAU)*EXP(-VINT(22))
15396 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15397 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15398 CALL PYSIGH(NCHN,SIGS)
15399 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15400 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15401 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
15402
15403C...Save if highest PT so far.
15404 IF (PT2.GT.PT2MX) THEN
15405 JSMX=0
15406 MIMX=MINT(31)+1
15407 PT2MX=PT2
15408 ENDIF
15409
15410C----------------------------------------------------------------------
15411C...MODE=1: Generate and save accepted scattering.
15412 ELSEIF (MODE.EQ.1) THEN
15413 PT2=PT2NOW
15414C...Reset K, P, V, and MCT vectors.
15415 DO 200 I=N+1,N+4
15416 DO 190 J=1,5
15417 K(I,J)=0
15418 P(I,J)=0D0
15419 V(I,J)=0D0
15420 190 CONTINUE
15421 MCT(I,1)=0
15422 MCT(I,2)=0
15423 200 CONTINUE
15424
15425 NTRY=0
15426C...Choose flavour of reacting partons (and subprocess).
15427 210 NTRY=NTRY+1
15428 IF (NTRY.GT.50) THEN
15429 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15430 & //'interaction. Giving up!')
15431 MINT(51)=1
15432 RETURN
15433 ENDIF
15434 RSIGS=SIGS*PYR(0)
15435 DO 220 ICHN=1,NCHN
15436 KFL1=ISIG(ICHN,1)
15437 KFL2=ISIG(ICHN,2)
15438 ICONMI=ISIG(ICHN,3)
15439 RSIGS=RSIGS-SIGH(ICHN)
15440 IF(RSIGS.LE.0D0) GOTO 230
15441 220 CONTINUE
15442
15443C...Reassign to appropriate process codes.
15444 230 ISUBMI=ICONMI/10
15445 ICONMI=MOD(ICONMI,10)
15446
15447C...Choose new quark flavour for annihilation graphs
15448 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15449 SH=VINT(21)*VINT(2)
15450 CALL PYWIDT(21,SH,WDTP,WDTE)
15451 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15452 DO 250 I=1,MDCY(21,3)
15453 KFLF=KFDP(I+MDCY(21,2)-1,1)
15454 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15455 IF(RKFL.LE.0D0) GOTO 260
15456 250 CONTINUE
15457 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15458 IF(KFLF.GE.4) GOTO 240
15459 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15460 KFLF=4
15461 ICONMI=ICONMI-2
15462 ELSEIF(ISUBMI.EQ.53) THEN
15463 KFLF=5
15464 ICONMI=ICONMI-4
15465 ENDIF
15466 ENDIF
15467
15468C...Final state flavours and colour flow: default values
15469 JS=1
15470 KFL3=KFL1
15471 KFL4=KFL2
15472 KCC=20
15473 KCS=ISIGN(1,KFL1)
15474
15475 IF(ISUBMI.EQ.11) THEN
15476C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15477 KCC=ICONMI
15478 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15479
15480 ELSEIF(ISUBMI.EQ.12) THEN
15481C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15482 KFL3=ISIGN(KFLF,KFL1)
15483 KFL4=-KFL3
15484 KCC=4
15485
15486 ELSEIF(ISUBMI.EQ.13) THEN
15487C...f + fbar -> g + g; th arbitrary
15488 KFL3=21
15489 KFL4=21
15490 KCC=ICONMI+4
15491
15492 ELSEIF(ISUBMI.EQ.28) THEN
15493C...f + g -> f + g; th = (p(f)-p(f))**2
15494 IF(KFL1.EQ.21) JS=2
15495 KCC=ICONMI+6
15496 IF(KFL1.EQ.21) KCC=KCC+2
15497 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15498 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15499
15500 ELSEIF(ISUBMI.EQ.53) THEN
15501C...g + g -> f + fbar; th arbitrary
15502 KCS=(-1)**INT(1.5D0+PYR(0))
15503 KFL3=ISIGN(KFLF,KCS)
15504 KFL4=-KFL3
15505 KCC=ICONMI+10
15506
15507 ELSEIF(ISUBMI.EQ.68) THEN
15508C...g + g -> g + g; th arbitrary
15509 KCC=ICONMI+12
15510 KCS=(-1)**INT(1.5D0+PYR(0))
15511 ENDIF
15512
15513C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15514 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15515 & .OR.IABS(KFL4).EQ.5) THEN
15516 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15517 IF (PT2.LE.1.05*RMMAX2) THEN
15518 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15519 & //' created below threshold. Rejected.')
15520 GOTO 210
15521 ENDIF
15522 ENDIF
15523
15524C...Store flavours of scattering.
15525 MINT(13)=KFL1
15526 MINT(14)=KFL2
15527 MINT(15)=KFL1
15528 MINT(16)=KFL2
15529 MINT(21)=KFL3
15530 MINT(22)=KFL4
15531
15532C...Set flavours and mothers of scattering partons.
15533 K(N+1,1)=14
15534 K(N+2,1)=14
15535 K(N+3,1)=3
15536 K(N+4,1)=3
15537 K(N+1,2)=KFL1
15538 K(N+2,2)=KFL2
15539 K(N+3,2)=KFL3
15540 K(N+4,2)=KFL4
15541 K(N+1,3)=MINT(83)+1
15542 K(N+2,3)=MINT(83)+2
15543 K(N+3,3)=N+1
15544 K(N+4,3)=N+2
15545
15546C...Store colour connection indices.
15547 DO 270 J=1,2
15548 JC=J
15549 IF(KCS.EQ.-1) JC=3-J
15550 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15551 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15552 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15553 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15554 270 CONTINUE
15555
15556C...Store incoming and outgoing partons in their CM-frame.
15557 SHR=SQRT(VINT(21))*VINT(1)
15558 P(N+1,3)=0.5D0*SHR
15559 P(N+1,4)=0.5D0*SHR
15560 P(N+2,3)=-0.5D0*SHR
15561 P(N+2,4)=0.5D0*SHR
15562 P(N+3,5)=PYMASS(K(N+3,2))
15563 P(N+4,5)=PYMASS(K(N+4,2))
15564 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15565 IFAIL=1
15566 RETURN
15567 ENDIF
15568 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15569 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15570 P(N+4,4)=SHR-P(N+3,4)
15571 P(N+4,3)=-P(N+3,3)
15572
15573C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15574 PHI=PARU(2)*PYR(0)
15575 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15576
15577C...Global statistics.
15578 MINT(351)=MINT(351)+1
15579 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15580 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15581
15582C...Keep track of loose colour ends and information on scattering.
15583 MINT(31)=MINT(31)+1
15584 MINT(36)=MINT(31)
15585 PT2MI(MINT(36))=PT2
15586 IMISEP(MINT(31))=N+4
15587 DO 280 JS=1,2
15588 IMI(JS,MINT(31),1)=N+JS
15589 IMI(JS,MINT(31),2)=0
15590 XMI(JS,MINT(31))=VINT(40+JS)
15591 NMI(JS)=NMI(JS)+1
15592C...Update cumulative counters
15593 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15594 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15595 280 CONTINUE
15596
15597C...Add to list of final state partons
15598 IPART(NPART+1)=N+3
15599 IPART(NPART+2)=N+4
15600 PTPART(NPART+1)=SQRT(PT2)
15601 PTPART(NPART+2)=SQRT(PT2)
15602 NPART=NPART+2
15603
15604C...Initialize ISR
15605 NISGEN(1,MINT(31))=0
15606 NISGEN(2,MINT(31))=0
15607
15608C...Update ER
15609 N=N+4
15610 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15611 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15612 MINT(51)=1
15613 RETURN
15614 ENDIF
15615
15616C...Finally, assign colour tags to new partons
15617 DO 300 JS=1,2
15618 I1=IMI(JS,MINT(31),1)
15619 I2=IMI(3-JS,MINT(31),1)
15620 DO 290 JCS=4,5
15621 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15622 & GOTO 290
15623 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15624 KCS=JCS
15625 CALL PYCTTR(I1,KCS,I2)
15626 IF(MINT(51).NE.0) RETURN
15627 290 CONTINUE
15628 300 CONTINUE
15629
15630C----------------------------------------------------------------------
15631C...MODE=2: Decide whether quarks in last scattering were valence,
15632C...companion, or sea.
15633 ELSEIF (MODE.EQ.2) THEN
15634 JS=MINT(30)
15635 MI=MINT(36)
15636 PT2=PT2NOW
15637 KFSBM=ISIGN(1,MINT(10+JS))
15638 IFL=K(IMI(JS,MI,1),2)
15639 IMI(JS,MI,2)=0
15640 IF (IABS(IFL).GE.6) THEN
15641 IF (IABS(IFL).EQ.6) THEN
15642 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15643 ENDIF
15644 RETURN
15645 ENDIF
15646C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15647C...(Do not include the parton itself in the X rescaling.)
15648 X=XMI(JS,MI)
15649 XRSC=X/(VINT(142+JS)+X)
15650C...Note: XPSVC = x*pdf.
15651 MINT(30)=JS
15652 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15653 SEA=XPSVC(IFL,-1)
15654 VAL=XPSVC(IFL,0)
15655 CMP=0D0
15656 DO 310 IVC=1,NVC(JS,IFL)
15657 CMP=CMP+XPSVC(IFL,IVC)
15658 310 CONTINUE
15659
15660C...Decide (Extra factor x cancels in the dvision).
15661 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15662 IVNOW=1
15663 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15664C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15665 IVNOW=0
15666 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15667 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15668 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15669 IF(KFIVAL(JS,1).EQ.0) THEN
15670 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15671 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15672 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15673 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15674 ELSE
15675C...Count down valence remaining. Do not count current scattering.
15676 DO 340 I1=1,NMI(JS)
15677 IF (I1.EQ.MINT(36)) GOTO 340
15678 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15679 & IVNOW=IVNOW-1
15680 340 CONTINUE
15681 ENDIF
15682 IF(IVNOW.EQ.0) GOTO 330
15683C...Mark valence.
15684 IMI(JS,MI,2)=0
15685C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15686 IF(KFIVAL(JS,1).EQ.0) THEN
15687 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15688 KFIVAL(JS,1)=IFL
15689 KFIVAL(JS,2)=-IFL
15690 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15691 KFIVAL(JS,1)=IFL
15692 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15693 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15694 ENDIF
15695 ENDIF
15696
15697 ELSEIF (RVCS.LE.VAL+SEA) THEN
15698C...If sea, add opposite sign companion parton. Store X and I.
15699 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15700 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15701C...Set pointer to companion
15702 IMI(JS,MI,2)=-NVC(JS,-IFL)
15703
15704 ELSE
15705C...If companion, decide which one.
15706 IF (NVC(JS,IFL).EQ.0) THEN
15707 CMP=0D0
15708 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15709 GOTO 320
15710 ENDIF
15711 CMPSUM=VAL+SEA
15712 ISEL=0
15713 350 ISEL=ISEL+1
15714 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15715 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15716C...Find original sea (anti-)quark. Do not consider current scattering.
15717 IASSOC=0
15718 DO 360 I1=1,NMI(JS)
15719 IF (I1.EQ.MINT(36)) GOTO 360
15720 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15721 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15722 IMI(JS,MI,2)=IMI(JS,I1,1)
15723 IMI(JS,I1,2)=IMI(JS,MI,1)
15724 ENDIF
15725 360 CONTINUE
15726C...Mark companion "out-kicked".
15727 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15728 ENDIF
15729
15730 ENDIF
15731 RETURN
15732 END
15733
15734C*********************************************************************
15735
15736C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15737C...Giving the x*f pdf of a companion quark, with its partner at XS,
15738C...using an approximate gluon density like (1-X)^NPOW/X. The value
15739C...corresponds to an unrescaled range between 0 and 1-X.
15740
15741 FUNCTION PYFCMP(XC,XS,NPOW)
15742 IMPLICIT NONE
15743 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15744 INTEGER NPOW
15745
15746 PYFCMP=0D0
15747C...Parent gluon momentum fraction
15748 Y=XC+XS
15749 IF (Y.GE.1D0) RETURN
15750C...Common factor (includes factor XC, since PYFCMP=x*f)
15751 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15752C...Store normalized companion x*f distribution.
15753 IF (NPOW.LE.0) THEN
15754 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15755 ELSEIF (NPOW.EQ.1) THEN
15756 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15757 ELSEIF (NPOW.EQ.2) THEN
15758 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15759 & +3D0*XS*(1D0+XS)*LOG(XS)))
15760 ELSEIF (NPOW.EQ.3) THEN
15761 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15762 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15763 ELSEIF (NPOW.GE.4) THEN
15764 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15765 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15766 ENDIF
15767 RETURN
15768 END
15769
15770C*********************************************************************
15771
15772C...PYPCMP: Auxiliary to PYPDFU.
15773C...Giving the momentum integral of a companion quark, with its
15774C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15775C...The value corresponds to an unrescaled range between 0 and 1-XS.
15776
15777 FUNCTION PYPCMP(XS,NPOW)
15778 IMPLICIT NONE
15779 DOUBLE PRECISION XS, PYPCMP
15780 INTEGER NPOW
15781 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15782 PYPCMP=0D0
15783 ELSEIF (NPOW.LE.0) THEN
15784 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15785 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15786 ELSEIF (NPOW.EQ.1) THEN
15787 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15788 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15789 ELSEIF (NPOW.EQ.2) THEN
15790 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15791 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15792 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15793 & -3D0*XS*LOG(XS)*(1+XS)))
15794 ELSEIF (NPOW.EQ.3) THEN
15795 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15796 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15797 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15798 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15799 ELSE
15800 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15801 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15802 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15803 & -6D0*XS*LOG(XS)*(1D0+XS)))
15804 ENDIF
15805 RETURN
15806 END
15807
15808C*********************************************************************
15809
15810C...PYUPRE
15811C...Rearranges contents of the HEPEUP commonblock so that
15812C...mothers precede daughters and daughters of a decay are
15813C...listed consecutively.
15814
15815 SUBROUTINE PYUPRE
15816
15817C...Double precision and integer declarations.
15818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15819 IMPLICIT INTEGER(I-N)
15820
15821C...User process event common block.
15822 INTEGER MAXNUP
15823 PARAMETER (MAXNUP=500)
15824 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15825 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15826 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15827 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15828 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15829 SAVE /HEPEUP/
15830
15831C...Local arrays.
15832 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15833 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15834 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15835
15836C...Check whether a rearrangement is required.
15837 NEED=0
15838 DO 100 IUP=1,NUP
15839 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15840 100 CONTINUE
15841 DO 110 IUP=2,NUP
15842 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15843 110 CONTINUE
15844
15845 IF(NEED.NE.0) THEN
15846C...Find the new order that particles should have.
15847 NEWPOS(0)=0
15848 NNEW=0
15849 INEW=-1
15850 120 INEW=INEW+1
15851 DO 130 IUP=1,NUP
15852 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15853 NNEW=NNEW+1
15854 NEWPOS(NNEW)=IUP
15855 ENDIF
15856 130 CONTINUE
15857 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15858 IF(NNEW.NE.NUP) THEN
15859 CALL PYERRM(2,
15860 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15861 RETURN
15862 ENDIF
15863
15864C...Copy old info into temporary storage.
15865 DO 150 I=1,NUP
15866 IDUPT(I)=IDUP(I)
15867 ISTUPT(I)=ISTUP(I)
15868 MOTUPT(1,I)=MOTHUP(1,I)
15869 MOTUPT(2,I)=MOTHUP(2,I)
15870 ICOUPT(1,I)=ICOLUP(1,I)
15871 ICOUPT(2,I)=ICOLUP(2,I)
15872 DO 140 J=1,5
15873 PUPT(J,I)=PUP(J,I)
15874 140 CONTINUE
15875 VTIUPT(I)=VTIMUP(I)
15876 SPIUPT(I)=SPINUP(I)
15877 150 CONTINUE
15878
15879C...Copy info back into HEPEUP in right order.
15880 DO 180 I=1,NUP
15881 IOLD=NEWPOS(I)
15882 IDUP(I)=IDUPT(IOLD)
15883 ISTUP(I)=ISTUPT(IOLD)
15884 MOTHUP(1,I)=0
15885 MOTHUP(2,I)=0
15886 DO 160 IMOT=1,I-1
15887 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15888 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15889 160 CONTINUE
15890 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15891 MOTHSW=MOTHUP(1,I)
15892 MOTHUP(1,I)=MOTHUP(2,I)
15893 MOTHUP(2,I)=MOTHSW
15894 ENDIF
15895 ICOLUP(1,I)=ICOUPT(1,IOLD)
15896 ICOLUP(2,I)=ICOUPT(2,IOLD)
15897 DO 170 J=1,5
15898 PUP(J,I)=PUPT(J,IOLD)
15899 170 CONTINUE
15900 VTIMUP(I)=VTIUPT(IOLD)
15901 SPINUP(I)=SPIUPT(IOLD)
15902 180 CONTINUE
15903 ENDIF
15904
15905c...If incoming particles are massive recalculate to put them massless.
15906 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15907 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15908 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15909 PUP(4,1)=0.5D0*PPLUS
15910 PUP(3,1)=PUP(4,1)
15911 PUP(5,1)=0D0
15912 PUP(4,2)=0.5D0*PMINUS
15913 PUP(3,2)=-PUP(4,2)
15914 PUP(5,2)=0D0
15915 ENDIF
15916
15917 RETURN
15918 END
15919
15920C*********************************************************************
15921
15922C...PYADSH
15923C...Administers the generation of successive final-state showers
15924C...in external processes.
15925
15926 SUBROUTINE PYADSH(NFIN)
15927
15928C...Double precision and integer declarations.
15929 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15930 IMPLICIT INTEGER(I-N)
15931 INTEGER PYK,PYCHGE,PYCOMP
15932C...Parameter statement for maximum size of showers.
15933 PARAMETER (MAXNUR=1000)
15934C...Commonblocks.
15935 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15936 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15937 COMMON/PYCTAG/NCT,MCT(4000,2)
15938 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15939 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15940 COMMON/PYINT1/MINT(400),VINT(400)
15941 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15942C...Local array.
15943 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15944
15945C...Set primary vertex.
15946 DO 100 J=1,5
15947 V(MINT(83)+5,J)=0D0
15948 V(MINT(83)+6,J)=0D0
15949 V(MINT(84)+1,J)=0D0
15950 V(MINT(84)+2,J)=0D0
15951 100 CONTINUE
15952
15953C...Isolate systems of particles with the same mother.
15954 NSYS=0
15955 IMS=-1
15956 DO 140 I=MINT(84)+3,NFIN
15957 IM=K(I,3)
15958 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15959 IF(IM.NE.IMS) THEN
15960 NSYS=NSYS+1
15961 IBEG(NSYS)=I
15962 IMS=IM
15963 ENDIF
15964
15965C...Set production vertices.
15966 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15967 & THEN
15968 DO 110 J=1,4
15969 V(I,J)=0D0
15970 110 CONTINUE
15971 ELSE
15972 DO 120 J=1,4
15973 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15974 120 CONTINUE
15975 ENDIF
15976 IF(MSTP(125).GE.1) THEN
15977 IDOC=I-MSTP(126)+4
15978 DO 130 J=1,5
15979 V(IDOC,J)=V(I,J)
15980 130 CONTINUE
15981 ENDIF
15982 140 CONTINUE
15983
15984C...End loop over systems. Return if no showers to be performed.
15985 IBEG(NSYS+1)=NFIN+1
15986 IF(MSTP(71).LE.0) RETURN
15987
15988C...Loop through systems of particles; check that sensible size.
15989 DO 270 ISYS=1,NSYS
15990 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15991 IF(MINT(35).LE.1) THEN
15992 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15993 GOTO 270
15994 ELSEIF(NSIZ.LE.1) THEN
15995 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15996 GOTO 270
15997 ELSEIF(NSIZ.GT.80) THEN
15998 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
15999 GOTO 270
16000 ENDIF
16001 ENDIF
16002
16003C...Save status codes and daughters of showering particles; reset them.
16004 DO 150 J=1,4
16005 PSUM(J)=0D0
16006 150 CONTINUE
16007 DO 170 II=1,NSIZ
16008 I=IBEG(ISYS)-1+II
16009 KSAV(II,1)=K(I,1)
16010 IF(K(I,1).GT.10) THEN
16011 K(I,1)=1
16012 IF(KSAV(II,1).EQ.14) K(I,1)=3
16013 ENDIF
16014 IF(KSAV(II,1).LE.10) THEN
16015 ELSEIF(K(I,1).EQ.1) THEN
16016 KSAV(II,4)=K(I,4)
16017 KSAV(II,5)=K(I,5)
16018 K(I,4)=0
16019 K(I,5)=0
16020 ELSE
16021 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16022 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16023 K(I,4)=K(I,4)-KSAV(II,4)
16024 K(I,5)=K(I,5)-KSAV(II,5)
16025 ENDIF
16026 DO 160 J=1,4
16027 PSUM(J)=PSUM(J)+P(I,J)
16028 160 CONTINUE
16029 170 CONTINUE
16030
16031C...Perform shower.
16032 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16033 & PSUM(3)**2))
16034 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16035 NSAV=N
16036 IF(MINT(35).LE.1) THEN
16037 IF(NSIZ.EQ.2) THEN
16038 if(parj(200).eq.1.) CALL PYSHOWQ(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16039 if(parj(200).ne.1.) CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16040 ELSE
16041 if(parj(200).ne.1.) CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16042 if(parj(200).eq.1.) CALL PYSHOWQ(IBEG(ISYS),-NSIZ,QMAX)
16043 ENDIF
16044
16045C...For external processes, first call, also ISR partons radiate.
16046C...Can use existing PYPART list, removing partons that radiate later.
16047 ELSEIF(ISYS.EQ.1) THEN
16048 NPARTN=0
16049 DO 175 II=1,NPART
16050 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16051 NPARTN=NPARTN+1
16052 IPART(NPARTN)=IPART(II)
16053 PTPART(NPARTN)=PTPART(II)
16054 ENDIF
16055 175 CONTINUE
16056 NPART=NPARTN
16057 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16058 ELSE
16059C...For subsequent calls use the systems excluded above.
16060 NPART=NSIZ
16061 NPARTD=0
16062 DO 180 II=1,NSIZ
16063 I=IBEG(ISYS)-1+II
16064 IPART(II)=I
16065 PTPART(II)=0.5D0*QMAX
16066 180 CONTINUE
16067 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16068 ENDIF
16069
16070C...Look up showered copies of original showering particles.
16071 DO 260 II=1,NSIZ
16072 I=IBEG(ISYS)-1+II
16073 IMV=I
16074C...Particles without daughters need not be studied.
16075 IF(KSAV(II,1).LE.10) GOTO 260
16076 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16077 ELSEIF(K(I,1).EQ.11) THEN
16078 190 IMV=MOD(K(IMV,4),MSTU(5))
16079 IF(K(IMV,1).EQ.11) GOTO 190
16080 ELSE
16081 KDA1=MOD(K(I,4),MSTU(5))
16082 IF(KDA1.GT.0) THEN
16083 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16084 ENDIF
16085 KDA2=MOD(K(I,5),MSTU(5))
16086 IF(KDA2.GT.0) THEN
16087 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16088 ENDIF
16089 DO 200 I3=I+1,N
16090 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16091 & THEN
16092 IMV=I3
16093 KDA1=MOD(K(I3,4),MSTU(5))
16094 IF(KDA1.GT.0) THEN
16095 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16096 ENDIF
16097 KDA2=MOD(K(I3,5),MSTU(5))
16098 IF(KDA2.GT.0) THEN
16099 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16100 ENDIF
16101 ENDIF
16102 200 CONTINUE
16103 ENDIF
16104
16105C...Restore daughter info of original partons to showered copies.
16106 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16107 IF(KSAV(II,1).LE.10) THEN
16108 ELSEIF(K(I,1).EQ.1) THEN
16109 K(IMV,4)=KSAV(II,4)
16110 K(IMV,5)=KSAV(II,5)
16111 ELSE
16112 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16113 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16114 ENDIF
16115
16116C...Reset mother info of existing daughters to showered copies.
16117 DO 210 I3=IBEG(ISYS+1),NFIN
16118 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16119 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16120 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16121 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16122 ENDIF
16123 210 CONTINUE
16124
16125C...Boost all original daughters to new frame of showered copy.
16126C...Also update their colour tags.
16127 IF(IMV.NE.I) THEN
16128 DO 220 J=1,3
16129 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16130 220 CONTINUE
16131 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16132 DO 230 J=1,3
16133 BETA(J)=FAC*BETA(J)
16134 230 CONTINUE
16135 DO 250 I3=IBEG(ISYS+1),NFIN
16136 IMO=I3
16137 240 IMO=K(IMO,3)
16138 IF(MSTP(128).LE.0) THEN
16139 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16140 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16141 & THEN
16142 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16143 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16144 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16145 ENDIF
16146 ELSE
16147 IF(IMO.EQ.IMV) THEN
16148 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16149 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16150 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16151 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16152 GOTO 240
16153 ENDIF
16154 ENDIF
16155 250 CONTINUE
16156 ENDIF
16157 260 CONTINUE
16158
16159C...End of loop over showering systems
16160 270 CONTINUE
16161
16162 RETURN
16163 END
16164
16165C*********************************************************************
16166
16167C...PYVETO
16168C...Interface to UPVETO, which allows user to veto event generation
16169C...on the parton level, after parton showers but before multiple
16170C...interactions, beam remnants and hadronization is added.
16171
16172 SUBROUTINE PYVETO(IVETO)
16173
16174C...All real arithmetic in double precision.
16175 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16176C...Three Pythia functions return integers, so need declaring.
16177 INTEGER PYK,PYCHGE,PYCOMP
16178
16179C...PYTHIA commonblocks.
16180 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16181 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16183 COMMON/PYINT1/MINT(400),VINT(400)
16184 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16185C...HEPEVT commonblock.
16186 PARAMETER (NMXHEP=4000)
16187 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16188 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16189 DOUBLE PRECISION PHEP,VHEP
16190 SAVE /HEPEVT/
16191C...Local array.
16192 DIMENSION IRESO(100)
16193
16194C...Define longitudinal boost from initiator rest frame to cm frame.
16195 IF(MINT(35).EQ.3) THEN
16196C...The last frame is different depending upon old and new shower
16197 GAMMA=1D0
16198 GABEZ=0D0
16199 ELSE
16200 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16201 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16202 ENDIF
16203
16204C... Reset counters.
16205 NEVHEP=0
16206 NHEP=0
16207 NRESO=0
16208
16209C...Oth pass: identify beam and incoming partons
16210 DO 140 I=MINT(83)+1,MINT(83)+6
16211 ISTORE=0
16212C IF(K(I,2).EQ.94.OR.K(I,2).EQ.0) THEN
16213 IF(K(I,2).EQ.94) THEN
16214
16215 ELSE
16216 ISTORE=1
16217 NHEP=NHEP+1
16218 II=NHEP
16219 NRESO=NRESO+1
16220 IRESO(NRESO)=I
16221 IMOTH=K(I,3)
16222 ENDIF
16223 IF(ISTORE.EQ.1) THEN
16224C...Copy parton info, boosting momenta along z axis to cm frame.
16225 ISTHEP(II)=2
16226 IDHEP(II)=K(I,2)
16227 PHEP(1,II)=P(I,1)
16228 PHEP(2,II)=P(I,2)
16229 IF(II.GT.2) THEN
16230 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16231 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16232 ELSE
16233 PHEP(3,II)=P(I,3)
16234 PHEP(4,II)=P(I,4)
16235 ENDIF
16236 PHEP(5,II)=P(I,5)
16237C...Store one mother. Rest of history and vertex info zeroed.
16238 JMOHEP(1,II)=IMOTH
16239 JMOHEP(2,II)=0
16240 JDAHEP(1,II)=0
16241 JDAHEP(2,II)=0
16242 VHEP(1,II)=0D0
16243 VHEP(2,II)=0D0
16244 VHEP(3,II)=0D0
16245 VHEP(4,II)=0D0
16246 ENDIF
16247 140 CONTINUE
16248
16249C...First pass: identify final locations of resonances
16250C...and of their daughters before showering.
16251 DO 150 I=MINT(84)+3,N
16252 ISTORE=0
16253 IMOTH=0
16254
16255C...Skip shower CM frame documentation lines.
16256 IF(K(I,2).EQ.94) THEN
16257
16258C... Store a new intermediate product, when mother in documentation.
16259 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16260 & K(I,3).LE.MINT(84)) THEN
16261 ISTORE=1
16262 NHEP=NHEP+1
16263 II=NHEP
16264 NRESO=NRESO+1
16265 IRESO(NRESO)=I
16266 IMOTH=K(K(I,3),3)
16267
16268C... Store a new intermediate product, when mother in main section.
16269 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16270 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16271 ISTORE=1
16272 NHEP=NHEP+1
16273 II=NHEP
16274 NRESO=NRESO+1
16275 IRESO(NRESO)=I
16276 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3))
16277 ENDIF
16278
16279 IF(ISTORE.EQ.1) THEN
16280C...Copy parton info, boosting momenta along z axis to cm frame.
16281 ISTHEP(II)=2
16282 IDHEP(II)=K(I,2)
16283 PHEP(1,II)=P(I,1)
16284 PHEP(2,II)=P(I,2)
16285 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16286 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16287 PHEP(5,II)=P(I,5)
16288C...Store one mother. Rest of history and vertex info zeroed.
16289 JMOHEP(1,II)=IMOTH
16290 JMOHEP(2,II)=0
16291 JDAHEP(1,II)=I
16292 JDAHEP(2,II)=0
16293 VHEP(1,II)=0D0
16294 VHEP(2,II)=0D0
16295 VHEP(3,II)=0D0
16296 VHEP(4,II)=0D0
16297 ENDIF
16298 150 CONTINUE
16299
16300C...Second pass: identify current set of "final" partons.
16301 DO 200 I=MINT(84)+3,N
16302 ISTORE=0
16303 IMOTH=0
16304
16305C...Store a final parton.
16306 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16307 ISTORE=1
16308 NHEP=NHEP+1
16309 II=NHEP
16310C..Trace it back through shower, to check if from documented particle.
16311 IHIST=I
16312 ISAVE=IHIST
16313 160 CONTINUE
16314 IF(IHIST.GT.MINT(84)) THEN
16315 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16316 DO 170 IRI=1,NRESO
16317 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16318 170 CONTINUE
16319 ISAVE=IHIST
16320 IHIST=K(IHIST,3)
16321 IF(IMOTH.EQ.0) GOTO 160
16322 ELSEIF(IHIST.LE.4) THEN
16323 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16324 ISTORE=0
16325 NHEP=NHEP-1
16326 ELSE
16327 IMOTH=IHIST
16328 ENDIF
16329 ENDIF
16330 ENDIF
16331
16332 IF(ISTORE.EQ.1) THEN
16333C...Copy parton info, boosting momenta along z axis to cm frame.
16334 ISTHEP(II)=1
16335 IDHEP(II)=K(I,2)
16336 PHEP(1,II)=P(I,1)
16337 PHEP(2,II)=P(I,2)
16338 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16339 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16340 PHEP(5,II)=P(I,5)
16341C...Store one mother. Rest of history and vertex info zeroed.
16342 JMOHEP(1,II)=IMOTH
16343 JMOHEP(2,II)=0
16344 JDAHEP(1,II)=0
16345 JDAHEP(2,II)=0
16346 VHEP(1,II)=0D0
16347 VHEP(2,II)=0D0
16348 VHEP(3,II)=0D0
16349 VHEP(4,II)=0D0
16350 ENDIF
16351 200 CONTINUE
16352
16353C...Call user-written routine to decide whether to keep events.
16354 CALL UPVETO(IVETO)
16355
16356 RETURN
16357 END
16358C*********************************************************************
16359
16360C...PYRESD
16361C...Allows resonances to decay (including parton showers for hadronic
16362C...channels).
16363
16364 SUBROUTINE PYRESD(IRES)
16365
16366C...Double precision and integer declarations.
16367 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16368 IMPLICIT INTEGER(I-N)
16369 INTEGER PYK,PYCHGE,PYCOMP
16370C...Parameter statement to help give large particle numbers.
16371 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16372 &KEXCIT=4000000,KDIMEN=5000000)
16373C...Parameter statement for maximum size of showers.
16374 PARAMETER (MAXNUR=1000)
16375C...Commonblocks.
16376 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16377 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16378 COMMON/PYCTAG/NCT,MCT(4000,2)
16379 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16380 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16381 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16382 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16383 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16384 COMMON/PYINT1/MINT(400),VINT(400)
16385 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16386 COMMON/PYINT4/MWID(500),WIDS(500,5)
16387 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16388 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
16389C...Local arrays and complex and character variables.
16390 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16391 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16392 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16393 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16394 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16395 COMPLEX FGK,HA(6,6),HC(6,6)
16396 REAL TIR,UIR
16397 CHARACTER CODE*9,MASS*9
16398
16399C...The F, Xi and Xj functions of Gunion and Kunszt
16400C...(Phys. Rev. D33, 665, plus errata from the authors).
16401 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16402 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16403 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16404 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16405 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16406 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16407 &2D0*(D34/D56+D56/D34))
16408
16409C...Some general constants.
16410 XW=PARU(102)
16411 XWV=XW
16412 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16413 XW1=1D0-XW
16414 SQMZ=PMAS(23,1)**2
16415
16416 GMMZ=PMAS(23,1)*PMAS(23,2)
16417 SQMW=PMAS(24,1)**2
16418 GMMW=PMAS(24,1)*PMAS(24,2)
16419 SH=VINT(44)
16420
16421C...Boost and rotate to rest frame of incoming partons,
16422C...to get proper amount of smearing of decay angles.
16423 IBST=0
16424 IF(IRES.EQ.0) THEN
16425 IBST=1
16426 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
16427 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
16428 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
16429 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
16430 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
16431 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
16432 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
16433 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
16434 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
16435 ENDIF
16436
16437C...Reset original resonance configuration.
16438 DO 100 JT=1,8
16439 IREF(1,JT)=0
16440 100 CONTINUE
16441
16442C...Define initial one, two or three objects for subprocess.
16443 IHDEC=0
16444 IF(IRES.EQ.0) THEN
16445 ISUB=MINT(1)
16446 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
16447 IREF(1,1)=MINT(84)+2+ISET(ISUB)
16448 IREF(1,4)=MINT(83)+6+ISET(ISUB)
16449 JTMAX=1
16450 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16451 IREF(1,1)=MINT(84)+1+ISET(ISUB)
16452 IREF(1,2)=MINT(84)+2+ISET(ISUB)
16453 IREF(1,4)=MINT(83)+5+ISET(ISUB)
16454 IREF(1,5)=MINT(83)+6+ISET(ISUB)
16455 JTMAX=2
16456 ELSEIF(ISET(ISUB).EQ.5) THEN
16457 IREF(1,1)=MINT(84)+3
16458 IREF(1,2)=MINT(84)+4
16459 IREF(1,3)=MINT(84)+5
16460 IREF(1,4)=MINT(83)+7
16461 IREF(1,5)=MINT(83)+8
16462 IREF(1,6)=MINT(83)+9
16463 JTMAX=3
16464 ENDIF
16465
16466C...Define original resonance for odd cases.
16467 ELSE
16468 ISUB=0
16469 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16470 & IHDEC=1
16471 IF(IHDEC.EQ.1) ISUB=3
16472 IREF(1,1)=IRES
16473 IREF(1,4)=K(IRES,3)
16474 IRESTM=IRES
16475 IF(IREF(1,4).GT.MINT(84)) THEN
16476 110 ITMPMO=IREF(1,4)
16477 IF(K(ITMPMO,2).EQ.94) THEN
16478 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16479 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16480 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16481 IRESTM=ITMPMO
16482C...Explicitly check that reference particle exists, otherwise stop recursion
16483 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
16484 IREF(1,4)=K(ITMPMO,3)
16485 GOTO 110
16486 ENDIF
16487 ENDIF
16488 ENDIF
16489 IF(IREF(1,4).GT.MINT(84)) THEN
16490 EMATCH=1D10
16491 IREF14=IREF(1,4)
16492 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16493 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16494 & EMATCH) THEN
16495 IREF(1,4)=II
16496 EMATCH=ABS(P(II,4)-P(IREF14,4))
16497 ENDIF
16498 120 CONTINUE
16499 ENDIF
16500 JTMAX=1
16501 ENDIF
16502
16503C...Check if initial resonance has been moved (in resonance + jet).
16504 DO 140 JT=1,3
16505 IF(IREF(1,JT).GT.0) THEN
16506 IF(K(IREF(1,JT),1).GT.10) THEN
16507 KFA=IABS(K(IREF(1,JT),2))
16508 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16509 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16510 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16511 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16512 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16513 ENDIF
16514 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16515 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16516 ENDIF
16517 DO 130 I=IREF(1,JT)+1,N
16518 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16519 & I.EQ.KDA2)) THEN
16520 IREF(1,JT)=I
16521 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16522 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16523 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16524 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16525 ENDIF
16526 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16527 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16528 ENDIF
16529 ENDIF
16530 130 CONTINUE
16531 ELSE
16532 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16533 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16534 ENDIF
16535 ENDIF
16536 ENDIF
16537 140 CONTINUE
16538
16539C...Set decay vertex for initial resonances
16540 DO 160 JT=1,JTMAX
16541 DO 150 I=1,4
16542 V(IREF(1,JT),I)=0D0
16543 150 CONTINUE
16544 160 CONTINUE
16545
16546C...Loop over decay history.
16547 NP=1
16548 IP=0
16549 170 IP=IP+1
16550 NINH=0
16551 JTMAX=2
16552 IF(IREF(IP,2).EQ.0) JTMAX=1
16553 IF(IREF(IP,3).NE.0) JTMAX=3
16554 IT4=0
16555 NSAV=N
16556
16557C...Check for Higgs which appears as decay product of user-process.
16558 IF(ISUB.EQ.0) THEN
16559 IHDEC=0
16560 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16561 & .EQ.36) IHDEC=1
16562 IF(IHDEC.EQ.1) ISUB=3
16563 ENDIF
16564
16565C...Start treatment of one, two or three resonances in parallel.
16566 180 N=NSAV
16567 DO 340 JT=1,JTMAX
16568 ID=IREF(IP,JT)
16569 KDCY(JT)=0
16570 KFL1(JT)=0
16571 KFL2(JT)=0
16572 KFL3(JT)=0
16573 KEQL(JT)=0
16574 NSD(JT)=ID
16575 ITJUNC(JT)=0
16576
16577C...Check whether particle can/is allowed to decay.
16578 IF(ID.EQ.0) GOTO 330
16579 KFA=IABS(K(ID,2))
16580 KCA=PYCOMP(KFA)
16581 IF(MWID(KCA).EQ.0) GOTO 330
16582 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16583 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16584 & KFA.EQ.18) IT4=IT4+1
16585 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16586 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16587
16588C...Choose lifetime and determine decay vertex.
16589 IF(K(ID,1).EQ.5) THEN
16590 V(ID,5)=0D0
16591 ELSEIF(K(ID,1).NE.4) THEN
16592 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16593 ENDIF
16594 DO 190 J=1,4
16595 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16596 190 CONTINUE
16597
16598C...Determine whether decay allowed or not.
16599 MOUT=0
16600 IF(MSTJ(22).EQ.2) THEN
16601 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16602 ELSEIF(MSTJ(22).EQ.3) THEN
16603 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16604 ELSEIF(MSTJ(22).EQ.4) THEN
16605 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16606 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16607 ENDIF
16608 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16609 K(ID,1)=4
16610 GOTO 330
16611 ENDIF
16612
16613C...Info for selection of decay channel: sign, pairings.
16614 IF(KCHG(KCA,3).EQ.0) THEN
16615 IPM=2
16616 ELSE
16617 IPM=(5-ISIGN(1,K(ID,2)))/2
16618 ENDIF
16619 KFB=0
16620 IF(JTMAX.EQ.2) THEN
16621 KFB=IABS(K(IREF(IP,3-JT),2))
16622 ELSEIF(JTMAX.EQ.3) THEN
16623 JT2=JT+1-3*(JT/3)
16624 KFB=IABS(K(IREF(IP,JT2),2))
16625 IF(KFB.NE.KFA) THEN
16626 JT2=JT+2-3*((JT+1)/3)
16627 KFB=IABS(K(IREF(IP,JT2),2))
16628 ENDIF
16629 ENDIF
16630
16631C...Select decay channel.
16632 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16633 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16634 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16635 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16636 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16637 IF(WDTE0S.LE.0D0) GOTO 330
16638 RKFL=WDTE0S*PYR(0)
16639 IDL=0
16640 200 IDL=IDL+1
16641 IDC=IDL+MDCY(KCA,2)-1
16642 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16643 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16644 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16645
16646C...Read out flavours and colour charges of decay channel chosen.
16647 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16648 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16649 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16650 KFC1A=PYCOMP(IABS(KFL1(JT)))
16651 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16652 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16653 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16654 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16655 KFC2A=PYCOMP(IABS(KFL2(JT)))
16656 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16657 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16658 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16659 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16660 KCQ3(JT)=0
16661 IF(KFL3(JT).NE.0) THEN
16662 KFC3A=PYCOMP(IABS(KFL3(JT)))
16663 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16664 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16665 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16666 ENDIF
16667
16668C...Set/save further info on channel.
16669 KDCY(JT)=1
16670 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16671 NSD(JT)=N
16672 HGZ(JT,1)=VINT(111)
16673 HGZ(JT,2)=VINT(112)
16674 HGZ(JT,3)=VINT(114)
16675 JTZ=JT
16676
16677C...Select masses; to begin with assume resonances narrow.
16678 DO 220 I=1,3
16679 P(N+I,5)=0D0
16680 PMMN(I)=0D0
16681 IF(I.EQ.1) THEN
16682 KFLW=IABS(KFL1(JT))
16683 KCW=KFC1A
16684 ELSEIF(I.EQ.2) THEN
16685 KFLW=IABS(KFL2(JT))
16686 KCW=KFC2A
16687 ELSEIF(I.EQ.3) THEN
16688 IF(KFL3(JT).EQ.0) GOTO 220
16689 KFLW=IABS(KFL3(JT))
16690 KCW=KFC3A
16691 ENDIF
16692 P(N+I,5)=PMAS(KCW,1)
16693CMRENNA++
16694C...This prevents SUSY/t particles from becoming too light.
16695 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16696 PMMN(I)=PMAS(KCW,1)
16697 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16698 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16699 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16700 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16701 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16702 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16703 PMMN(I)=MIN(PMMN(I),PMSUM)
16704 ENDIF
16705 210 CONTINUE
16706CMRENNA--
16707 ELSEIF(KFLW.EQ.6) THEN
16708 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16709 ENDIF
16710 220 CONTINUE
16711
16712C...Check which two out of three are widest.
16713 IWID1=1
16714 IWID2=2
16715 PWID1=PMAS(KFC1A,2)
16716 PWID2=PMAS(KFC2A,2)
16717 KFLW1=IABS(KFL1(JT))
16718 KFLW2=IABS(KFL2(JT))
16719 IF(KFL3(JT).NE.0) THEN
16720 PWID3=PMAS(KFC3A,2)
16721 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16722 IWID1=3
16723 PWID1=PWID3
16724 KFLW1=IABS(KFL3(JT))
16725 ELSEIF(PWID3.GT.PWID2) THEN
16726 IWID2=3
16727 PWID2=PWID3
16728 KFLW2=IABS(KFL3(JT))
16729 ENDIF
16730 ENDIF
16731
16732C...If all narrow then only check that masses consistent.
16733 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16734 & PWID2.LT.PARP(41))) THEN
16735CMRENNA++
16736C....Handle near degeneracy cases.
16737 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16738 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16739 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16740 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16741 ENDIF
16742 ENDIF
16743CMRENNA--
16744 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16745 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16746 MINT(51)=1
16747 GOTO 720
16748 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16749 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16750 MINT(51)=1
16751 GOTO 720
16752 ENDIF
16753
16754C...For three wide resonances select narrower of three
16755C...according to BW decoupled from rest.
16756 ELSE
16757 PMTOT=P(ID,5)
16758 IF(KFL3(JT).NE.0) THEN
16759 IWID3=6-IWID1-IWID2
16760 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16761 & KFLW1-KFLW2
16762 LOOP=0
16763 230 LOOP=LOOP+1
16764 P(N+IWID3,5)=PYMASS(KFLW3)
16765 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16766 PMTOT=PMTOT-P(N+IWID3,5)
16767 ENDIF
16768C...Select other two correlated within remaining phase space.
16769 IF(IP.EQ.1) THEN
16770 CKIN45=CKIN(45)
16771 CKIN47=CKIN(47)
16772 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16773 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16774 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16775 & P(N+IWID2,5))
16776 CKIN(45)=CKIN45
16777 CKIN(47)=CKIN47
16778 ELSE
16779 CKIN(49)=PMMN(IWID1)
16780 CKIN(50)=PMMN(IWID2)
16781 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16782 & P(N+IWID2,5))
16783 CKIN(49)=0D0
16784 CKIN(50)=0D0
16785 ENDIF
16786 IF(MINT(51).EQ.1) GOTO 720
16787 ENDIF
16788
16789C...Begin fill decay products, with colour flow for coloured objects.
16790 MSTU10=MSTU(10)
16791 MSTU(10)=1
16792 MSTU(19)=1
16793
16794C...Three-body decays
16795 IF(KFL3(JT).NE.0) THEN
16796 DO 250 I=N+1,N+3
16797 DO 240 J=1,5
16798 K(I,J)=0
16799 V(I,J)=0D0
16800 240 CONTINUE
16801 MCT(I,1)=0
16802 MCT(I,2)=0
16803 250 CONTINUE
16804 K(N+1,1)=1
16805 K(N+1,2)=KFL1(JT)
16806 K(N+2,1)=1
16807 K(N+2,2)=KFL2(JT)
16808 K(N+3,1)=1
16809 K(N+3,2)=KFL3(JT)
16810 IDIN=ID
16811
16812C...Generate kinematics (default is flat)
16813 CALL PYTBDY(IDIN)
16814
16815C...Set generic colour flows whenever unambiguous,
16816C...(independently of the order of the decay products)
16817C...Sum up total colour content
16818 NANT=0
16819 NTRI=0
16820 NOCT=0
16821 KCQ(0)=KCQM(JT)
16822 KCQ(1)=KCQ1(JT)
16823 KCQ(2)=KCQ2(JT)
16824 KCQ(3)=KCQ3(JT)
16825 DO 255 J=0,3
16826 IF (KCQ(J).EQ.-1) THEN
16827 NANT=NANT+1
16828 IANT(NANT)=N+J
16829 ELSEIF (KCQ(J).EQ.1) THEN
16830 NTRI=NTRI+1
16831 ITRI(NTRI)=N+J
16832 ELSEIF (KCQ(J).EQ.2) THEN
16833 NOCT=NOCT+1
16834 IOCT(NOCT)=N+J
16835 ENDIF
16836 255 CONTINUE
16837
16838C...Set color flow for generic 1 -> N processes (N arbitrary)
16839 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
16840C...All singlets: do nothing
16841
16842 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
16843C...Two octets, zero triplets, n singlets:
16844 IF (KCQ(0).EQ.2) THEN
16845C...8 -> 8 + n(1)
16846 K(ID,4)=K(ID,4)+IOCT(2)
16847 K(ID,5)=K(ID,5)+IOCT(2)
16848 K(IOCT(2),1)=3
16849 K(IOCT(2),4)=MSTU(5)*ID
16850 K(IOCT(2),5)=MSTU(5)*ID
16851 MCT(IOCT(2),1)=MCT(ID,1)
16852 MCT(IOCT(2),2)=MCT(ID,2)
16853 ELSE
16854C...1 -> 8 + 8 + n(1)
16855 K(IOCT(1),1)=3
16856 K(IOCT(1),4)=MSTU(5)*IOCT(2)
16857 K(IOCT(1),5)=MSTU(5)*IOCT(2)
16858 K(IOCT(2),1)=3
16859 K(IOCT(2),4)=MSTU(5)*IOCT(1)
16860 K(IOCT(2),5)=MSTU(5)*IOCT(1)
16861 NCT=NCT+1
16862 MCT(IOCT(1),1)=NCT
16863 MCT(IOCT(2),2)=NCT
16864 NCT=NCT+1
16865 MCT(IOCT(2),1)=NCT
16866 MCT(IOCT(1),2)=NCT
16867 ENDIF
16868
16869 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
16870C...Two triplets, zero octets, n singlets.
16871 IF (KCQ(0).EQ.1) THEN
16872C...3 -> 3 + n(1)
16873 K(ID,4)=K(ID,4)+ITRI(2)
16874 K(ITRI(2),1)=3
16875 K(ITRI(2),4)=MSTU(5)*ID
16876 MCT(ITRI(2),1)=MCT(ID,1)
16877 ELSEIF (KCQ(0).EQ.-1) THEN
16878C...3bar -> 3bar + n(1)
16879 K(ID,5)=K(ID,5)+IANT(2)
16880 K(IANT(2),1)=3
16881 K(IANT(2),5)=MSTU(5)*ID
16882 MCT(IANT(2),2)=MCT(ID,2)
16883 ELSE
16884C...1 -> 3 + 3bar + n(1)
16885 K(ITRI(1),1)=3
16886 K(ITRI(1),4)=MSTU(5)*IANT(1)
16887 K(IANT(1),1)=3
16888 K(IANT(1),5)=MSTU(5)*ITRI(1)
16889 NCT=NCT+1
16890 MCT(ITRI(1),1)=NCT
16891 MCT(IANT(1),2)=NCT
16892 ENDIF
16893
16894 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
16895C...Two triplets, one octet, n singlets.
16896 IF (KCQ(0).EQ.2) THEN
16897C...8 -> 3 + 3bar + n(1)
16898 K(ID,4)=K(ID,4)+ITRI(1)
16899 K(ID,5)=K(ID,5)+IANT(1)
16900 K(ITRI(1),1)=3
16901 K(ITRI(1),4)=MSTU(5)*ID
16902 K(IANT(1),1)=3
16903 K(IANT(1),5)=MSTU(5)*ID
16904 MCT(ITRI(1),1)=MCT(ID,1)
16905 MCT(IANT(1),2)=MCT(ID,2)
16906 ELSEIF (KCQ(0).EQ.1) THEN
16907C...3 -> 8 + 3 + n(1)
16908 K(ID,4)=K(ID,4)+IOCT(1)
16909 K(IOCT(1),1)=3
16910 K(IOCT(1),4)=MSTU(5)*ID
16911 K(IOCT(1),5)=MSTU(5)*ITRI(2)
16912 K(ITRI(2),1)=3
16913 K(ITRI(2),4)=MSTU(5)*IOCT(1)
16914 MCT(IOCT(1),1)=MCT(ID,1)
16915 NCT=NCT+1
16916 MCT(IOCT(1),2)=NCT
16917 MCT(ITRI(2),1)=NCT
16918 ELSEIF (KCQ(0).EQ.-1) THEN
16919C...3bar -> 8 + 3bar + n(1)
16920 K(ID,5)=K(ID,5)+IOCT(1)
16921 K(IOCT(1),1)=3
16922 K(IOCT(1),5)=MSTU(5)*ID
16923 K(IOCT(1),4)=MSTU(5)*IANT(2)
16924 K(IANT(2),1)=3
16925 K(IANT(2),5)=MSTU(5)*IOCT(1)
16926 MCT(IOCT(1),2)=MCT(ID,2)
16927 NCT=NCT+1
16928 MCT(IOCT(1),1)=NCT
16929 MCT(IANT(2),2)=NCT
16930 ELSE
16931C...1 -> 3 + 3bar + 8 + n(1)
16932 K(ITRI(1),1)=3
16933 K(ITRI(1),4)=MSTU(5)*IOCT(1)
16934 K(IOCT(1),1)=3
16935 K(IOCT(1),5)=MSTU(5)*ITRI(1)
16936 K(IOCT(1),4)=MSTU(5)*IANT(1)
16937 K(IANT(1),1)=3
16938 K(IANT(1),5)=MSTU(5)*IOCT(1)
16939 NCT=NCT+1
16940 MCT(ITRI(1),1)=NCT
16941 MCT(IOCT(1),2)=NCT
16942 NCT=NCT+1
16943 MCT(IOCT(1),1)=NCT
16944 MCT(IANT(1),2)=NCT
16945 ENDIF
16946CPS-- End of generic cases
16947C...(could three octets also be handled?)
16948C...(could (some of) the RPV cases be made generic as well?)
16949
16950C...Special cases (= old treatment)
16951C...Set colour flow for t -> W + b + Z.
16952 ELSEIF(KFA.EQ.6) THEN
16953 K(N+2,1)=3
16954 ISID=4
16955 IF(KCQM(JT).EQ.-1) ISID=5
16956 IDAU=N+2
16957 K(ID,ISID)=K(ID,ISID)+IDAU
16958 K(IDAU,ISID)=MSTU(5)*ID
16959
16960C...Set colour flow in three-body decays - programmed as special cases.
16961
16962 ELSEIF(KFC2A.LE.6) THEN
16963 K(N+2,1)=3
16964 K(N+3,1)=3
16965 ISID=4
16966 IF(KFL2(JT).LT.0) ISID=5
16967 K(N+2,ISID)=MSTU(5)*(N+3)
16968 K(N+3,9-ISID)=MSTU(5)*(N+2)
16969C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16970 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16971 & .AND.KFL3(JT).NE.0) THEN
16972 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16973C...3-body decays of squarks to colour singlets plus one quark
16974 IF (KQSUMA.EQ.1) THEN
16975C...Find quark
16976 IQ=0
16977 IF (KCQ1(JT).NE.0) IQ=1
16978 IF (KCQ2(JT).NE.0) IQ=2
16979 IF (KCQ3(JT).NE.0) IQ=3
16980 ISID=4
16981 IF (K(N+IQ,2).LT.0) ISID=5
16982 K(N+IQ,1)=3
16983 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16984 K(N+IQ,ISID)=MSTU(5)*ID
16985 ENDIF
16986C...PS--
16987 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
16988 K(N+1,1)=3
16989 K(N+2,1)=3
16990 K(N+3,1)=3
16991 ISID=4
16992 IF(KFL2(JT).LT.0) ISID=5
16993 K(N+1,ISID)=MSTU(5)*(N+2)
16994 K(N+1,9-ISID)=MSTU(5)*(N+3)
16995 K(N+2,ISID)=MSTU(5)*(N+1)
16996 K(N+3,9-ISID)=MSTU(5)*(N+1)
16997 ELSEIF(KFA.EQ.KSUSY1+21) THEN
16998 K(N+2,1)=3
16999 K(N+3,1)=3
17000 ISID=4
17001 IF(KFL2(JT).LT.0) ISID=5
17002 K(ID,ISID)=K(ID,ISID)+(N+2)
17003 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17004 K(N+2,ISID)=MSTU(5)*ID
17005 K(N+3,9-ISID)=MSTU(5)*ID
17006CMRENNA--
17007
17008 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17009 & IABS(KCQ2(JT)).EQ.1) THEN
17010 K(N+2,1)=3
17011 K(N+3,1)=3
17012 ISID=4
17013 IF(KFL2(JT).LT.0) ISID=5
17014 K(N+2,ISID)=MSTU(5)*(N+3)
17015 K(N+3,9-ISID)=MSTU(5)*(N+2)
17016 ENDIF
17017
17018 NSAV=N
17019
17020C...Set colour flow in three-body decays with baryon number violation.
17021C...Neutralino and chargino decays first.
17022 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17023 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17024 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17025 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17026C...Insert junction to keep track of colours.
17027 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17028 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17029 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17030C...Set special junction codes:
17031 K(N+4,1)=42
17032 K(N+4,2)=88
17033
17034C...Order decay products by invariant mass. (will be used in PYSTRF).
17035 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)-
17036 & P(N+1,3)*P(N+2,3)
17037 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)-
17038 & P(N+1,3)*P(N+3,3)
17039 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)-
17040 & P(N+2,3)*P(N+3,3)
17041 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17042 K(N+4,4)=N+3+K(N+4,4)
17043 K(N+4,5)=N+1+MSTU(5)*(N+2)
17044 ELSEIF(PM13.LT.PM23) THEN
17045 K(N+4,4)=N+2+K(N+4,4)
17046 K(N+4,5)=N+1+MSTU(5)*(N+3)
17047 ELSE
17048 K(N+4,4)=N+1+K(N+4,4)
17049 K(N+4,5)=N+2+MSTU(5)*(N+3)
17050 ENDIF
17051 DO 260 J=1,5
17052 P(N+4,J)=0D0
17053 V(N+4,J)=0D0
17054 260 CONTINUE
17055C...Connect daughters to junction.
17056 DO 270 II=N+1,N+3
17057 K(II,4)=0
17058 K(II,5)=0
17059 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17060 270 CONTINUE
17061C...Particle counter should be stepped up one extra for junction.
17062 N=N+1
17063
17064C...Gluino decays.
17065 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17066 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17067 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17068C...Insert junction to keep track of colours.
17069 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17070 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17071 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17072 K(N+4,1)=42
17073 K(N+4,2)=88
17074 DO 280 J=1,5
17075 P(N+4,J)=0D0
17076 V(N+4,J)=0D0
17077 280 CONTINUE
17078 CTMSUM=0D0
17079 DO 290 II=N+1,N+3
17080 K(II,4)=0
17081 K(II,5)=0
17082C...Start by connecting all daughters to junction.
17083 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17084C...Only consider colour topologies with off shell resonances.
17085 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17086 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17087 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17088 IF (RMGLU-RMQ1.LT.RMRES) THEN
17089C...Calculate propagators for each colour topology.
17090 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17091 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17092 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17093 ELSE
17094 CTM2(II-N)=0D0
17095 ENDIF
17096 CTMSUM=CTMSUM+CTM2(II-N)
17097 290 CONTINUE
17098 CTMSUM=PYR(0)*CTMSUM
17099C...Select colour topology J, with most off shell least likely.
17100 J=0
17101 300 J=J+1
17102 CTMSUM=CTMSUM-CTM2(J)
17103 IF (CTMSUM.GT.0D0) GOTO 300
17104C...The lucky winner gets its colour (anti-colour) directly from gluino.
17105 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17106 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17107C...The other gluino colour is connected to junction
17108 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17109 & MSTU(5)
17110 K(N+4,4)=K(N+4,4)+ID
17111C...Lastly, connect junction to remaining daughters.
17112 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17113C...Particle counter should be stepped up one extra for junction.
17114 N=N+1
17115 ENDIF
17116
17117C...Update particle counter.
17118 N=N+3
17119
17120C...2) Everything else two-body decay.
17121 ELSE
17122 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17123 MCT(N-1,1)=0
17124 MCT(N-1,2)=0
17125 MCT(N,1)=0
17126 MCT(N,2)=0
17127C...First set colour flow as if mother colour singlet.
17128 IF(KCQ1(JT).NE.0) THEN
17129 K(N-1,1)=3
17130 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17131 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17132 ENDIF
17133 IF(KCQ2(JT).NE.0) THEN
17134 K(N,1)=3
17135 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17136 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17137 ENDIF
17138C...Then redirect colour flow if mother (anti)triplet.
17139 IF(KCQM(JT).EQ.0) THEN
17140 ELSEIF(KCQM(JT).NE.2) THEN
17141 ISID=4
17142 IF(KCQM(JT).EQ.-1) ISID=5
17143 IDAU=N-1
17144 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17145 K(ID,ISID)=K(ID,ISID)+IDAU
17146 K(IDAU,ISID)=MSTU(5)*ID
17147C...Then redirect colour flow if mother octet.
17148 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17149 IDAU=N-1
17150 IF(KCQ1(JT).EQ.0) IDAU=N
17151 K(ID,4)=K(ID,4)+IDAU
17152 K(ID,5)=K(ID,5)+IDAU
17153 K(IDAU,4)=MSTU(5)*ID
17154 K(IDAU,5)=MSTU(5)*ID
17155 ELSE
17156 ISID=4
17157 IF(KCQ1(JT).EQ.-1) ISID=5
17158 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17159 K(ID,ISID)=K(ID,ISID)+(N-1)
17160 K(ID,9-ISID)=K(ID,9-ISID)+N
17161 K(N-1,ISID)=MSTU(5)*ID
17162 K(N,9-ISID)=MSTU(5)*ID
17163 ENDIF
17164
17165C...Insert junction
17166 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17167 N=N+1
17168C...~q* mother: type 3 junction. ~q mother: type 4.
17169 ITJUNC(JT)=(7+KCQM(JT))/2
17170C...Specify junction KF and set colour flow from junction
17171 K(N,1)=42
17172 K(N,2)=88
17173 K(N,3)=ID
17174C...Junction type encoded together with mother:
17175 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17176 K(N,5)=N-1+MSTU(5)*(N-2)
17177C...Zero P and V for junction (V filled later)
17178 DO 310 J=1,5
17179 P(N,J)=0D0
17180 V(N,J)=0D0
17181 310 CONTINUE
17182C...Set colour flow from mother to junction
17183 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17184C...Set colour flow from daughters to junction
17185 DO 320 II=N-2,N-1
17186 K(II,4) = 0
17187 K(II,5) = 0
17188C...(Anti-)colour mother is junction.
17189 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17190 320 CONTINUE
17191 ENDIF
17192 ENDIF
17193
17194C...End loop over resonances for daughter flavour and mass selection.
17195 MSTU(10)=MSTU10
17196 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17197 & NINH=NINH+1
17198 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17199 & KFL1(JT).EQ.0) THEN
17200 WRITE(CODE,'(I9)') K(ID,2)
17201 WRITE(MASS,'(F9.3)') P(ID,5)
17202 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17203 & CODE//' with mass'//MASS)
17204 MINT(51)=1
17205 GOTO 720
17206 ENDIF
17207 340 CONTINUE
17208
17209C...Check for allowed combinations. Skip if no decays.
17210 IF(JTMAX.EQ.1) THEN
17211 IF(KDCY(1).EQ.0) GOTO 710
17212 ELSEIF(JTMAX.EQ.2) THEN
17213 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17214 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17215 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17216 ELSEIF(JTMAX.EQ.3) THEN
17217 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17218 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17219 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17220 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17221 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17222 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17223 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17224 ENDIF
17225
17226C...Special case: matrix element option for Z0 decay to quarks.
17227 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17228 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17229
17230C...Check consistency of MSTJ options set.
17231 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17232 CALL PYERRM(6,
17233 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17234 MSTJ(110)=1
17235 ENDIF
17236 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17237 CALL PYERRM(6,
17238 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17239
17240 MSTJ(111)=0
17241 ENDIF
17242
17243C...Select alpha_strong behaviour.
17244 MST111=MSTU(111)
17245 PAR112=PARU(112)
17246 MSTU(111)=MSTJ(108)
17247 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17248 & MSTU(111)=1
17249 PARU(112)=PARJ(121)
17250 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17251
17252C...Find axial fraction in total cross section for scalar gluon model.
17253 PARJ(171)=0D0
17254 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17255 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17256 POLL=1D0-PARJ(131)*PARJ(132)
17257 SFF=1D0/(16D0*XW*XW1)
17258 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17259 & (PARJ(123)*PARJ(124))**2)
17260 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17261 VE=4D0*XW-1D0
17262 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17263 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17264 & (PARJ(132)-PARJ(131)))
17265 KFLC=IABS(KFL1(1))
17266 PMQ=PYMASS(KFLC)
17267 QF=KCHG(KFLC,1)/3D0
17268 VQ=1D0
17269 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17270 & 1D0-(2D0*PMQ/P(ID,5))**2))
17271 VF=SIGN(1D0,QF)-4D0*QF*XW
17272 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17273 & VF**2*HF1W)+VQ**3*HF1W
17274 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17275 ENDIF
17276
17277C...Choice of jet configuration.
17278 CALL PYXJET(P(ID,5),NJET,CUT)
17279 KFLC=IABS(KFL1(1))
17280 KFLN=21
17281 IF(NJET.EQ.4) THEN
17282 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17283 ELSEIF(NJET.EQ.3) THEN
17284 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17285 ELSE
17286 MSTJ(120)=1
17287 ENDIF
17288
17289C...Fill jet configuration; return if incorrect kinematics.
17290 NC=N-2
17291 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17292 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17293 ELSEIF(NJET.EQ.2) THEN
17294 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17295 ELSEIF(NJET.EQ.3) THEN
17296 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17297 ELSEIF(KFLN.EQ.21) THEN
17298 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17299 & X12,X14)
17300 ELSE
17301 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17302 & X12,X14)
17303 ENDIF
17304 IF(MSTU(24).NE.0) THEN
17305 MINT(51)=1
17306 MSTU(111)=MST111
17307 PARU(112)=PAR112
17308 GOTO 720
17309 ENDIF
17310
17311C...Angular orientation according to matrix element.
17312 IF(MSTJ(106).EQ.1) THEN
17313 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17314 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17315 CTHE(1)=COS(THEZ)
17316 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17317 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17318 ENDIF
17319
17320C...Boost partons to Z0 rest frame.
17321 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17322 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17323
17324C...Mark decayed resonance and add documentation lines,
17325 K(ID,1)=K(ID,1)+10
17326 IDOC=MINT(83)+MINT(4)
17327 DO 360 I=NC+1,N
17328 I1=MINT(83)+MINT(4)+1
17329 K(I,3)=I1
17330 IF(MSTP(128).GE.1) K(I,3)=ID
17331 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17332 MINT(4)=MINT(4)+1
17333 K(I1,1)=21
17334 K(I1,2)=K(I,2)
17335 K(I1,3)=IREF(IP,4)
17336 DO 350 J=1,5
17337 P(I1,J)=P(I,J)
17338 350 CONTINUE
17339 ENDIF
17340 360 CONTINUE
17341
17342C...Generate parton shower.
17343 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17344 if(parj(200).ne.1.) CALL PYSHOW(N-1,N,P(ID,5))
17345 if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,P(ID,5))
17346 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17347 NPART=2
17348 IPART(1)=N-1
17349 IPART(2)=N
17350 PTPART(1)=0.5D0*P(ID,5)
17351 PTPART(2)=PTPART(1)
17352 NCT=NCT+1
17353 IF(K(N-1,2).GT.0) THEN
17354 MCT(N-1,1)=NCT
17355 MCT(N,2)=NCT
17356 ELSE
17357 MCT(N-1,2)=NCT
17358 MCT(N,1)=NCT
17359 ENDIF
17360 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17361 ENDIF
17362
17363C... End special case for Z0: skip ahead.
17364 MSTU(111)=MST111
17365 PARU(112)=PAR112
17366 GOTO 700
17367 ENDIF
17368
17369C...Order incoming partons and outgoing resonances.
17370 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17371 &NINH.EQ.0) THEN
17372 ILIN(1)=MINT(84)+1
17373 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17374 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17375 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17376 ILIN(2)=2*MINT(84)+3-ILIN(1)
17377 IMIN=1
17378 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17379 & .EQ.36) IMIN=3
17380 IMAX=2
17381 IORD=1
17382 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17383 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17384 IAKIPD=IABS(K(IREF(IP,IORD),2))
17385 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17386 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17387
17388C...Order decay products of resonances.
17389 DO 370 JT=IORD,3-IORD,3-2*IORD
17390 IF(KDCY(JT).EQ.0) THEN
17391 ILIN(IMAX+1)=NSD(JT)
17392 IMAX=IMAX+1
17393 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
17394 ILIN(IMAX+1)=N+2*JT-1
17395 ILIN(IMAX+2)=N+2*JT
17396 IMAX=IMAX+2
17397 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17398 K(N+2*JT,2)=K(NSD(JT)+2,2)
17399 ELSE
17400 ILIN(IMAX+1)=N+2*JT
17401
17402 ILIN(IMAX+2)=N+2*JT-1
17403 IMAX=IMAX+2
17404 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17405 K(N+2*JT,2)=K(NSD(JT)+2,2)
17406 ENDIF
17407 370 CONTINUE
17408
17409C...Find charge, isospin, left- and righthanded couplings.
17410 DO 390 I=IMIN,IMAX
17411 DO 380 J=1,4
17412 COUP(I,J)=0D0
17413 380 CONTINUE
17414 KFA=IABS(K(ILIN(I),2))
17415 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
17416 COUP(I,1)=KCHG(KFA,1)/3D0
17417 COUP(I,2)=(-1)**MOD(KFA,2)
17418 COUP(I,4)=-2D0*COUP(I,1)*XWV
17419 COUP(I,3)=COUP(I,2)+COUP(I,4)
17420 390 CONTINUE
17421
17422C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17423 IF(ISUB.EQ.22) THEN
17424 DO 420 I=3,5,2
17425 I1=IORD
17426 IF(I.EQ.5) I1=3-IORD
17427 DO 410 J1=1,2
17428 DO 400 J2=1,2
17429 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
17430 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
17431 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
17432 & COUP(I,J2+2)**2
17433 400 CONTINUE
17434 410 CONTINUE
17435 420 CONTINUE
17436 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17437 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
17438 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
17439 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
17440
17441 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
17442 ENDIF
17443 ENDIF
17444
17445C...Select angular orientation type - Z'/W' only.
17446 MZPWP=0
17447 IF(ISUB.EQ.141) THEN
17448 IF(PYR(0).LT.PARU(130)) MZPWP=1
17449 IF(IP.EQ.2) THEN
17450 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
17451 IAKIR=IABS(K(IREF(2,2),2))
17452 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17453 IF(IAKIR.LE.20) MZPWP=2
17454 ENDIF
17455 IF(IP.GE.3) MZPWP=2
17456 ELSEIF(ISUB.EQ.142) THEN
17457 IF(PYR(0).LT.PARU(136)) MZPWP=1
17458 IF(IP.EQ.2) THEN
17459 IAKIR=IABS(K(IREF(2,2),2))
17460 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17461 IF(IAKIR.LE.20) MZPWP=2
17462 ENDIF
17463 IF(IP.GE.3) MZPWP=2
17464 ENDIF
17465
17466C...Select random angles (begin of weighting procedure).
17467 430 DO 440 JT=1,JTMAX
17468 IF(KDCY(JT).EQ.0) GOTO 440
17469 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
17470 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
17471 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
17472 PHI(JT)=VINT(24)
17473 ELSE
17474 CTHE(JT)=2D0*PYR(0)-1D0
17475 PHI(JT)=PARU(2)*PYR(0)
17476 ENDIF
17477 440 CONTINUE
17478
17479 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
17480C...Construct massless four-vectors.
17481 DO 460 I=N+1,N+4
17482 K(I,1)=1
17483 DO 450 J=1,5
17484 P(I,J)=0D0
17485 V(I,J)=0D0
17486 450 CONTINUE
17487 460 CONTINUE
17488 DO 470 JT=1,JTMAX
17489 IF(KDCY(JT).EQ.0) GOTO 470
17490 ID=IREF(IP,JT)
17491 P(N+2*JT-1,3)=0.5D0*P(ID,5)
17492 P(N+2*JT-1,4)=0.5D0*P(ID,5)
17493 P(N+2*JT,3)=-0.5D0*P(ID,5)
17494 P(N+2*JT,4)=0.5D0*P(ID,5)
17495 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
17496 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17497 470 CONTINUE
17498
17499C...Store incoming and outgoing momenta, with random rotation to
17500C...avoid accidental zeroes in HA expressions.
17501 IF(ISUB.NE.0) THEN
17502 DO 490 I=IMIN,IMAX
17503 K(N+4+I,1)=1
17504 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
17505 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
17506 P(N+4+I,5)=P(ILIN(I),5)
17507 DO 480 J=1,3
17508 P(N+4+I,J)=P(ILIN(I),J)
17509 480 CONTINUE
17510 490 CONTINUE
17511 500 THERR=ACOS(2D0*PYR(0)-1D0)
17512 PHIRR=PARU(2)*PYR(0)
17513 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
17514 DO 520 I=IMIN,IMAX
17515 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
17516 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
17517 DO 510 J=1,4
17518 PK(I,J)=P(N+4+I,J)
17519 510 CONTINUE
17520 520 CONTINUE
17521 ENDIF
17522
17523C...Calculate internal products.
17524 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
17525 & ISUB.EQ.142) THEN
17526 DO 540 I1=IMIN,IMAX-1
17527 DO 530 I2=I1+1,IMAX
17528 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
17529 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
17530 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
17531 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
17532 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
17533 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
17534 HC(I1,I2)=CONJG(HA(I1,I2))
17535 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
17536 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
17537 HA(I2,I1)=-HA(I1,I2)
17538 HC(I2,I1)=-HC(I1,I2)
17539 530 CONTINUE
17540 540 CONTINUE
17541 ENDIF
17542
17543C...Calculate four-products.
17544 IF(ISUB.NE.0) THEN
17545 DO 560 I=1,2
17546 DO 550 J=1,4
17547 PK(I,J)=-PK(I,J)
17548 550 CONTINUE
17549 560 CONTINUE
17550 DO 580 I1=IMIN,IMAX-1
17551 DO 570 I2=I1+1,IMAX
17552 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
17553 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
17554 PKK(I2,I1)=PKK(I1,I2)
17555 570 CONTINUE
17556 580 CONTINUE
17557 ENDIF
17558 ENDIF
17559
17560 KFAGM=IABS(IREF(IP,7))
17561 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
17562C...Isotropic decay selected by user.
17563 WT=1D0
17564 WTMAX=1D0
17565
17566 ELSEIF(JTMAX.EQ.3) THEN
17567C...Isotropic decay when three mother particles.
17568 WT=1D0
17569 WTMAX=1D0
17570
17571 ELSEIF(IT4.GE.1) THEN
17572C... Isotropic decay t -> b + W etc for 4th generation q and l.
17573 WT=1D0
17574 WTMAX=1D0
17575
17576 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
17577 & IREF(IP,7).EQ.36) THEN
17578C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
17579C...CP-odd case added by Kari Ertresvag Myklevoll.
17580C...Now also with mixed Higgs CP-states
17581 ETA=PARP(25)
17582 IF(IP.EQ.1) WTMAX=SH**2
17583 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
17584 KFA=IABS(K(IREF(IP,1),2))
17585 KFT=IABS(K(IREF(IP,2),2))
17586
17587 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
17588 & MSTP(25).GE.3) THEN
17589C...For mixed CP states need epsilon product.
17590 P10=PK(3,4)
17591 P20=PK(4,4)
17592 P30=PK(5,4)
17593 P40=PK(6,4)
17594 P11=PK(3,1)
17595 P21=PK(4,1)
17596 P31=PK(5,1)
17597 P41=PK(6,1)
17598 P12=PK(3,2)
17599 P22=PK(4,2)
17600 P32=PK(5,2)
17601 P42=PK(6,2)
17602 P13=PK(3,3)
17603 P23=PK(4,3)
17604 P33=PK(5,3)
17605 P43=PK(6,3)
17606 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17607 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17608 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17609 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17610 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17611 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17612 & P22*P30*P41+P13*P22*P31*P40
17613C...For mixed CP states need gauge boson masses.
17614 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17615 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17616 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17617 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17618 XMV=PMAS(KFA,1)
17619 ENDIF
17620
17621C...Z decay
17622 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
17623 KFLF1A=IABS(KFL1(1))
17624 EF1=KCHG(KFLF1A,1)/3D0
17625 AF1=SIGN(1D0,EF1+0.1D0)
17626 VF1=AF1-4D0*EF1*XWV
17627 KFLF2A=IABS(KFL1(2))
17628 EF2=KCHG(KFLF2A,1)/3D0
17629 AF2=SIGN(1D0,EF2+0.1D0)
17630 VF2=AF2-4D0*EF2*XWV
17631 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17632 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17633 & THEN
17634C...CP-even decay
17635 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17636 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17637 ELSEIF(MSTP(25).LE.2) THEN
17638C...CP-odd decay
17639 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17640 & -2*PKK(3,4)*PKK(5,6)
17641 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17642 & (PKK(3,4)*PKK(5,6))
17643 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17644 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17645 ELSE
17646C...Mixed CP states.
17647 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17648 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17649 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17650 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17651 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17652 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17653 & +PKK(3,4)*PKK(5,6)
17654 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17655 & +VA12AS*PKK(3,4)*PKK(5,6)
17656 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17657 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17658 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17659 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17660 ENDIF
17661
17662C...W decay
17663 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
17664 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17665 & THEN
17666C...CP-even decay
17667 WT=16D0*PKK(3,5)*PKK(4,6)
17668 ELSEIF(MSTP(25).LE.2) THEN
17669C...CP-odd decay
17670 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17671 & -2*PKK(3,4)*PKK(5,6)
17672 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17673 & (PKK(3,4)*PKK(5,6))
17674 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17675 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17676 ELSE
17677C...Mixed CP states.
17678 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17679 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17680 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17681 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17682 & +PKK(3,4)*PKK(5,6)
17683 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17684 & +PKK(3,4)*PKK(5,6)
17685 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17686 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17687 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17688 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17689 ENDIF
17690
17691C...No angular correlations in other Higgs decays.
17692 ELSE
17693 WT=WTMAX
17694 ENDIF
17695
17696 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17697 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17698 & THEN
17699C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17700 I1=IREF(IP,8)
17701 IF(MOD(KFAGM,2).EQ.0) THEN
17702 I2=N+1
17703 I3=N+2
17704 ELSE
17705 I2=N+2
17706 I3=N+1
17707 ENDIF
17708 I4=IREF(IP,2)
17709 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17710 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17711 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17712 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17713
17714 ELSEIF(ISUB.EQ.1) THEN
17715C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17716 EI=KCHG(IABS(MINT(15)),1)/3D0
17717 AI=SIGN(1D0,EI+0.1D0)
17718 VI=AI-4D0*EI*XWV
17719 EF=KCHG(IABS(KFL1(1)),1)/3D0
17720 AF=SIGN(1D0,EF+0.1D0)
17721
17722 VF=AF-4D0*EF*XWV
17723 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17724 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17725 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17726 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17727 & (VI**2+AI**2)*VINT(114)*VF**2)
17728 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17729 & 4D0*VI*AI*VINT(114)*VF*AF)
17730 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17731 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17732 WTMAX=2D0*(WT1+ABS(WT3))
17733
17734 ELSEIF(ISUB.EQ.2) THEN
17735C...Angular weight for W+/- -> 2 quarks/leptons.
17736 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17737 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17738 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17739 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17740 WTMAX=4D0
17741
17742 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17743C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17744C...-> gluon/gamma + 2 quarks/leptons.
17745 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17746 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17747 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17748 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17749 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17750 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17751 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17752 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17753 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17754 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17755 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17756 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17757 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17758 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17759 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17760 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17761
17762 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17763C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17764C...-> gluon/gamma + 2 quarks/leptons.
17765 WT=PKK(1,3)**2+PKK(2,4)**2
17766 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17767
17768 ELSEIF(ISUB.EQ.22) THEN
17769C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17770 S34=P(IREF(IP,IORD),5)**2
17771 S56=P(IREF(IP,3-IORD),5)**2
17772 TI=PKK(1,3)+PKK(1,4)+S34
17773 UI=PKK(1,5)+PKK(1,6)+S56
17774 TIR=REAL(TI)
17775 UIR=REAL(UI)
17776 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17777 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17778 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17779 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17780 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17781 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17782 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17783 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17784
17785 WT=
17786 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17787 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17788 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17789 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17790 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17791 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17792 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17793 & 1D0/UI**2))
17794
17795 ELSEIF(ISUB.EQ.23) THEN
17796C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17797 D34=P(IREF(IP,IORD),5)**2
17798 D56=P(IREF(IP,3-IORD),5)**2
17799 DT=PKK(1,3)+PKK(1,4)+D34
17800 DU=PKK(1,5)+PKK(1,6)+D56
17801 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17802 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17803 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17804 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17805
17806 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17807 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17808 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17809 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17810 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17811 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17812
17813 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17814C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17815C...(or H0, or A0).
17816 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17817 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17818 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17819 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17820 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17821
17822 ELSEIF(ISUB.EQ.25) THEN
17823C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17824 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17825 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17826 D34=P(IREF(IP,IORD),5)**2
17827 D56=P(IREF(IP,3-IORD),5)**2
17828 DT=PKK(1,3)+PKK(1,4)+D34
17829 DU=PKK(1,5)+PKK(1,6)+D56
17830 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17831 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17832 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17833 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17834 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17835 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17836 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17837 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17838 IF(MSTP(50).LE.0) THEN
17839 WT=FGK135**2+(CCWW*FGK253)**2
17840 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17841 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17842 & DJGK(DT,DU)))
17843 ELSE
17844 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17845 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17846 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17847 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17848 ENDIF
17849
17850 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17851C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17852C...(or H0, or A0).
17853 WT=PKK(1,3)*PKK(2,4)
17854 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17855
17856 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17857C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17858C...-> f + 2 quarks/leptons.
17859 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17860 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17861 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17862 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17863 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17864 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17865 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17866 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17867 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17868 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17869 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17870 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17871 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17872 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17873 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17874 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17875 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17876 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17877
17878 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17879C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17880 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17881 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17882 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17883
17884 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17885 & ISUB.EQ.77) THEN
17886C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17887 WT=16D0*PKK(3,5)*PKK(4,6)
17888 WTMAX=SH**2
17889
17890 ELSEIF(ISUB.EQ.110) THEN
17891C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17892 WT=1D0
17893 WTMAX=1D0
17894
17895 ELSEIF(ISUB.EQ.141) THEN
17896 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17897C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17898C...Couplings of incoming flavour.
17899 KFAI=IABS(MINT(15))
17900 EI=KCHG(KFAI,1)/3D0
17901 AI=SIGN(1D0,EI+0.1D0)
17902 VI=AI-4D0*EI*XWV
17903 KFAIC=1
17904 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17905 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17906 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17907 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17908 VPI=PARU(119+2*KFAIC)
17909 API=PARU(120+2*KFAIC)
17910 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17911 VPI=PARJ(178+2*KFAIC)
17912 API=PARJ(179+2*KFAIC)
17913 ELSE
17914 VPI=PARJ(186+2*KFAIC)
17915 API=PARJ(187+2*KFAIC)
17916 ENDIF
17917C...Couplings of final flavour.
17918 KFAF=IABS(KFL1(1))
17919 EF=KCHG(KFAF,1)/3D0
17920 AF=SIGN(1D0,EF+0.1D0)
17921 VF=AF-4D0*EF*XWV
17922 KFAFC=1
17923 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17924 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17925 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17926 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17927 VPF=PARU(119+2*KFAFC)
17928 APF=PARU(120+2*KFAFC)
17929 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17930 VPF=PARJ(178+2*KFAFC)
17931 APF=PARJ(179+2*KFAFC)
17932 ELSE
17933 VPF=PARJ(186+2*KFAFC)
17934 APF=PARJ(187+2*KFAFC)
17935 ENDIF
17936C...Asymmetry and weight.
17937 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17938 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17939 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17940 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17941 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17942 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17943 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17944 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17945 WTMAX=2D0+ABS(ASYM)
17946 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17947C...Angular weight for f + fbar -> Z' -> W+ + W-.
17948 RM1=P(NSD(1)+1,5)**2/SH
17949 RM2=P(NSD(1)+2,5)**2/SH
17950 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17951 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17952 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17953 & (RM2-RM1)**2)
17954 WT=CFLAT+CCOS2*CTHE(1)**2
17955 WTMAX=CFLAT+MAX(0D0,CCOS2)
17956 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17957 & IABS(KFL1(1)).EQ.37)) THEN
17958C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17959 WT=1D0-CTHE(1)**2
17960 WTMAX=1D0
17961 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17962C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17963 RM1=P(NSD(1)+1,5)**2/SH
17964 RM2=P(NSD(1)+2,5)**2/SH
17965 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17966 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17967 WTMAX=1D0+FLAM2/(8D0*RM1)
17968 ELSEIF(MZPWP.EQ.0) THEN
17969C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17970C...(W:s like if intermediate Z).
17971 D34=P(IREF(IP,IORD),5)**2
17972 D56=P(IREF(IP,3-IORD),5)**2
17973 DT=PKK(1,3)+PKK(1,4)+D34
17974 DU=PKK(1,5)+PKK(1,6)+D56
17975 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17976 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17977 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17978 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17979 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17980 ELSEIF(MZPWP.EQ.1) THEN
17981C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17982C...(W:s approximately longitudinal, like if intermediate H).
17983 WT=16D0*PKK(3,5)*PKK(4,6)
17984 WTMAX=SH**2
17985 ELSE
17986C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17987C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17988 WT=1D0
17989 WTMAX=1D0
17990 ENDIF
17991
17992 ELSEIF(ISUB.EQ.142) THEN
17993 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17994C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17995 KFAI=IABS(MINT(15))
17996 KFAIC=1
17997 IF(KFAI.GT.10) KFAIC=2
17998 VI=PARU(129+2*KFAIC)
17999 AI=PARU(130+2*KFAIC)
18000 KFAF=IABS(KFL1(1))
18001 KFAFC=1
18002 IF(KFAF.GT.10) KFAFC=2
18003 VF=PARU(129+2*KFAFC)
18004 AF=PARU(130+2*KFAFC)
18005 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18006 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18007 WTMAX=2D0+ABS(ASYM)
18008 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18009C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18010 RM1=P(NSD(1)+1,5)**2/SH
18011 RM2=P(NSD(1)+2,5)**2/SH
18012 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18013 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18014 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18015 & (RM2-RM1)**2)
18016 WT=CFLAT+CCOS2*CTHE(1)**2
18017 WTMAX=CFLAT+MAX(0D0,CCOS2)
18018 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18019C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18020 RM1=P(NSD(1)+1,5)**2/SH
18021 RM2=P(NSD(1)+2,5)**2/SH
18022 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18023 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18024 WTMAX=1D0+FLAM2/(8D0*RM1)
18025 ELSEIF(MZPWP.EQ.0) THEN
18026C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18027C...(W/Z like if intermediate W).
18028 D34=P(IREF(IP,IORD),5)**2
18029 D56=P(IREF(IP,3-IORD),5)**2
18030 DT=PKK(1,3)+PKK(1,4)+D34
18031 DU=PKK(1,5)+PKK(1,6)+D56
18032 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18033 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18034 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18035 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18036 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18037 ELSEIF(MZPWP.EQ.1) THEN
18038C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18039C...(W/Z approximately longitudinal, like if intermediate H).
18040 WT=16D0*PKK(3,5)*PKK(4,6)
18041 WTMAX=SH**2
18042 ELSE
18043C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18044C...t + bbar -> t + W + bbar.
18045 WT=1D0
18046 WTMAX=1D0
18047 ENDIF
18048
18049 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18050 & THEN
18051C...Isotropic decay of leptoquarks (assumed spin 0).
18052 WT=1D0
18053 WTMAX=1D0
18054
18055 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18056C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18057 SIDE=1D0
18058 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18059 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18060 WT=1D0+SIDE*CTHE(1)
18061 WTMAX=2D0
18062 ELSEIF(IP.EQ.1) THEN
18063
18064 RM1=P(NSD(1)+1,5)**2/SH
18065 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18066 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18067 ELSE
18068C...W/Z decay assumed isotropic, since not known.
18069 WT=1D0
18070 WTMAX=1D0
18071 ENDIF
18072
18073 ELSEIF(ISUB.EQ.149) THEN
18074C...Isotropic decay of techni-eta.
18075 WT=1D0
18076 WTMAX=1D0
18077
18078 ELSEIF(ISUB.EQ.191) THEN
18079 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18080C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18081C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18082 WT=1D0-CTHE(1)**2
18083 WTMAX=1D0
18084 ELSEIF(IP.EQ.1) THEN
18085C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18086 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18087 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18088 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18089 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18090 KFAI=IABS(MINT(15))
18091 EI=KCHG(KFAI,1)/3D0
18092 AI=SIGN(1D0,EI+0.1D0)
18093 VI=AI-4D0*EI*XWV
18094 VALI=0.5D0*(VI+AI)
18095 VARI=0.5D0*(VI-AI)
18096 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18097 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18098 KFAF=IABS(KFL1(1))
18099 EF=KCHG(KFAF,1)/3D0
18100 AF=SIGN(1D0,EF+0.1D0)
18101 VF=AF-4D0*EF*XWV
18102 VALF=0.5D0*(VF+AF)
18103 VARF=0.5D0*(VF-AF)
18104 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18105 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18106 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18107 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18108 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18109 WTMAX=4D0*MAX(ASAME,AFLIP)
18110 ELSE
18111C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18112 WT=1D0
18113 WTMAX=1D0
18114 ENDIF
18115
18116 ELSEIF(ISUB.EQ.192) THEN
18117 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18118C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18119C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18120 WT=1D0-CTHE(1)**2
18121 WTMAX=1D0
18122 ELSEIF(IP.EQ.1) THEN
18123C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18124 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18125 WT=(1D0+CTHESG)**2
18126 WTMAX=4D0
18127 ELSE
18128C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18129 WT=1D0
18130 WTMAX=1D0
18131 ENDIF
18132
18133 ELSEIF(ISUB.EQ.193) THEN
18134 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18135C...Angular weight for f + fbar -> omega_tc0 ->
18136C...gamma pi_tc0 or Z0 pi_tc0.
18137 WT=1D0+CTHE(1)**2
18138 WTMAX=2D0
18139 ELSEIF(IP.EQ.1) THEN
18140C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18141 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18142 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18143 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18144 KFAI=IABS(MINT(15))
18145 EI=KCHG(KFAI,1)/3D0
18146 AI=SIGN(1D0,EI+0.1D0)
18147 VI=AI-4D0*EI*XWV
18148 VALI=0.5D0*(VI+AI)
18149 VARI=0.5D0*(VI-AI)
18150 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18151 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18152 KFAF=IABS(KFL1(1))
18153 EF=KCHG(KFAF,1)/3D0
18154 AF=SIGN(1D0,EF+0.1D0)
18155 VF=AF-4D0*EF*XWV
18156 VALF=0.5D0*(VF+AF)
18157 VARF=0.5D0*(VF-AF)
18158 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18159 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18160 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18161 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18162 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18163 WTMAX=4D0*MAX(BSAME,BFLIP)
18164 ELSE
18165C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18166 WT=1D0
18167 WTMAX=1D0
18168 ENDIF
18169
18170 ELSEIF(ISUB.EQ.353) THEN
18171C...Angular weight for Z_R0 -> 2 quarks/leptons.
18172 EI=KCHG(IABS(MINT(15)),1)/3D0
18173 AI=SIGN(1D0,EI+0.1D0)
18174 VI=AI-4D0*EI*XWV
18175 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18176 AF=SIGN(1D0,EF+0.1D0)
18177 VF=AF-4D0*EF*XWV
18178 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18179 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18180 WT2=RMF*(VI**2+AI**2)*VF**2
18181 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18182 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18183 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18184 WTMAX=2D0*(WT1+ABS(WT3))
18185
18186 ELSEIF(ISUB.EQ.354) THEN
18187C...Angular weight for W_R+/- -> 2 quarks/leptons.
18188 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18189 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18190 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18191 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18192 WTMAX=4D0
18193
18194 ELSEIF(ISUB.EQ.391) THEN
18195C...Angular weight for f + fbar -> G* -> f + fbar
18196 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18197 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18198 WTMAX=2D0
18199C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18200C...implemented by M.-C. Lemaire
18201 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18202 & IABS(KFL1(1)).EQ.22)) THEN
18203 WT=1D0-CTHE(1)**4
18204 WTMAX=1D0
18205C...Other G* decays not yet implemented angular distributions.
18206 ELSE
18207 WT=1D0
18208 WTMAX=1D0
18209 ENDIF
18210
18211 ELSEIF(ISUB.EQ.392) THEN
18212C...Angular weight for g + g -> G* -> f + fbar
18213 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18214 WT=1D0-CTHE(1)**4
18215 WTMAX=1D0
18216C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18217C...implemented by M.-C. Lemaire
18218 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18219 & IABS(KFL1(1)).EQ.22)) THEN
18220 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18221 WTMAX=8D0
18222C...Other G* decays not yet implemented angular distributions.
18223 ELSE
18224 WT=1D0
18225 WTMAX=1D0
18226 ENDIF
18227
18228C...Obtain correct angular distribution by rejection techniques.
18229 ELSE
18230 WT=1D0
18231 WTMAX=1D0
18232 ENDIF
18233 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18234
18235C...Construct massive four-vectors using angles chosen.
18236 590 DO 690 JT=1,JTMAX
18237 IF(KDCY(JT).EQ.0) GOTO 690
18238 ID=IREF(IP,JT)
18239 DO 600 J=1,5
18240 DPMO(J)=P(ID,J)
18241 600 CONTINUE
18242 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18243CMRENNA++
18244 IF(KFL3(JT).EQ.0) THEN
18245 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18246 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18247 N0=NSD(JT)+2
18248 ELSE
18249 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18250 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18251 N0=NSD(JT)+3
18252 ENDIF
18253
18254 DO 610 J=1,4
18255 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18256 610 CONTINUE
18257C...Fill in position of decay vertex.
18258 DO 630 I=NSD(JT)+1,N0
18259 DO 620 J=1,4
18260 V(I,J)=VDCY(J)
18261 620 CONTINUE
18262 V(I,5)=0D0
18263
18264 630 CONTINUE
18265CMRENNA--
18266
18267C...Mark decayed resonances; trace history.
18268 K(ID,1)=K(ID,1)+10
18269 KFA=IABS(K(ID,2))
18270 KCA=PYCOMP(KFA)
18271 IF(KCQM(JT).NE.0) THEN
18272C...Do not kill colour flow through coloured resonance!
18273 ELSE
18274 K(ID,4)=NSD(JT)+1
18275 K(ID,5)=NSD(JT)+2
18276C...If 3-body or 2-body with junction:
18277 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18278C...If 3-body with junction:
18279 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18280 ENDIF
18281
18282C...Add documentation lines.
18283 ISUBRG=MAX(1,MIN(500,MINT(1)))
18284 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18285 IDOC=MINT(83)+MINT(4)
18286CMRENNA+++
18287 IHI=NSD(JT)+2
18288 IF(KFL3(JT).NE.0) IHI=IHI+1
18289 DO 650 I=NSD(JT)+1,IHI
18290CMRENNA---
18291 I1=MINT(83)+MINT(4)+1
18292 K(I,3)=I1
18293 IF(MSTP(128).GE.1) K(I,3)=ID
18294 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18295 MINT(4)=MINT(4)+1
18296 K(I1,1)=21
18297 K(I1,2)=K(I,2)
18298 K(I1,3)=IREF(IP,JT+3)
18299 DO 640 J=1,5
18300 P(I1,J)=P(I,J)
18301 640 CONTINUE
18302 ENDIF
18303 650 CONTINUE
18304 ELSE
18305 K(NSD(JT)+1,3)=ID
18306 K(NSD(JT)+2,3)=ID
18307C...If 3-body or 2-body with junction:
18308 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18309C...If 3-body with junction:
18310 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18311 ENDIF
18312
18313C...Do showering of two or three objects.
18314 NSHBEF=N
18315 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18316 IF(KFL3(JT).EQ.0) THEN
18317 if(parj(200).ne.1.) CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18318 if(parj(200).eq.1.) CALL PYSHOWQ(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18319 ELSE
18320 if(parj(200).ne.1.) CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18321 if(parj(200).eq.1.) CALL PYSHOWQ(NSD(JT)+1,-3,P(ID,5))
18322 ENDIF
18323
18324c...For pT-ordered shower need set up first, especially colour tags.
18325C...(Need to set up colour tags even if MSTP(71) = 0)
18326 ELSEIF(MINT(35).GE.2) THEN
18327 NPART=2
18328 IF(KFL3(JT).NE.0) NPART=3
18329 IPART(1)=NSD(JT)+1
18330 IPART(2)=NSD(JT)+2
18331 IPART(3)=NSD(JT)+3
18332 PTPART(1)=0.5D0*P(ID,5)
18333 PTPART(2)=PTPART(1)
18334 PTPART(3)=PTPART(1)
18335 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18336 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18337 IF(MOTHER.LE.NSD(JT)) THEN
18338 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18339 ELSE
18340 NCT=NCT+1
18341 MCT(NSD(JT)+1,1)=NCT
18342 MCT(MOTHER,2)=NCT
18343 ENDIF
18344 ENDIF
18345 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18346 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18347 IF(MOTHER.LE.NSD(JT)) THEN
18348 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18349 ELSE
18350 NCT=NCT+1
18351 MCT(NSD(JT)+1,2)=NCT
18352 MCT(MOTHER,1)=NCT
18353 ENDIF
18354 ENDIF
18355 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18356 & KCQ2(JT).EQ.2)) THEN
18357 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18358 IF(MOTHER.LE.NSD(JT)) THEN
18359 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18360 ELSE
18361 NCT=NCT+1
18362 MCT(NSD(JT)+2,1)=NCT
18363 MCT(MOTHER,2)=NCT
18364 ENDIF
18365 ENDIF
18366 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18367 & KCQ2(JT).EQ.2)) THEN
18368 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18369 IF(MOTHER.LE.NSD(JT)) THEN
18370 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18371 ELSE
18372 NCT=NCT+1
18373 MCT(NSD(JT)+2,2)=NCT
18374 MCT(MOTHER,1)=NCT
18375 ENDIF
18376 ENDIF
18377 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18378 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18379 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18380 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18381 ENDIF
18382 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18383 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18384 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18385 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18386 ENDIF
18387 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18388 ENDIF
18389 NSHAFT=N
18390 IF(JT.EQ.1) NAFT1=N
18391
18392C...Check if decay products moved by shower.
18393 NSD1=NSD(JT)+1
18394 NSD2=NSD(JT)+2
18395 NSD3=NSD(JT)+3
18396 IF(NSHAFT.GT.NSHBEF) THEN
18397 IF(K(NSD1,1).GT.10) THEN
18398 DO 660 I=NSHBEF+1,NSHAFT
18399 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
18400 660 CONTINUE
18401 ENDIF
18402 IF(K(NSD2,1).GT.10) THEN
18403 DO 670 I=NSHBEF+1,NSHAFT
18404 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
18405 & I.NE.NSD1) NSD2=I
18406 670 CONTINUE
18407 ENDIF
18408 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
18409 DO 680 I=NSHBEF+1,NSHAFT
18410 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
18411 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
18412 680 CONTINUE
18413 ENDIF
18414 ENDIF
18415
18416C...Store decay products for further treatment.
18417 NP=NP+1
18418 IREF(NP,1)=NSD1
18419 IREF(NP,2)=NSD2
18420 IREF(NP,3)=0
18421 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
18422 IREF(NP,4)=IDOC+1
18423 IREF(NP,5)=IDOC+2
18424 IREF(NP,6)=0
18425 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
18426 IREF(NP,7)=K(IREF(IP,JT),2)
18427 IREF(NP,8)=IREF(IP,JT)
18428 690 CONTINUE
18429
18430
18431C...Fill information for 2 -> 1 -> 2.
18432 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
18433 MINT(7)=MINT(83)+6+2*ISET(ISUB)
18434 MINT(8)=MINT(83)+7+2*ISET(ISUB)
18435 MINT(25)=KFL1(1)
18436 MINT(26)=KFL2(1)
18437 VINT(23)=CTHE(1)
18438 RM3=P(N-1,5)**2/SH
18439 RM4=P(N,5)**2/SH
18440 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18441 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
18442 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
18443 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
18444 VINT(47)=SQRT(VINT(48))
18445 ENDIF
18446
18447C...Possibility of colour rearrangement in W+W- events.
18448 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
18449 IAKF1=IABS(KFL1(1))
18450 IAKF2=IABS(KFL1(2))
18451 IAKF3=IABS(KFL2(1))
18452 IAKF4=IABS(KFL2(2))
18453 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
18454 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
18455 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
18456 IF(MINT(51).NE.0) RETURN
18457 ENDIF
18458
18459C...Loop back if needed.
18460 710 IF(IP.LT.NP) GOTO 170
18461
18462C...Boost back to standard frame.
18463 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
18464 &BEZIN)
18465
18466 RETURN
18467 END
18468
18469C*********************************************************************
18470
18471C...PYMULT
18472C...Initializes treatment of multiple interactions, selects kinematics
18473C...of hardest interaction if low-pT physics included in run, and
18474C...generates all non-hardest interactions.
18475
18476 SUBROUTINE PYMULT(MMUL)
18477
18478C...Double precision and integer declarations.
18479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18480 IMPLICIT INTEGER(I-N)
18481 INTEGER PYK,PYCHGE,PYCOMP
18482C...Commonblocks.
18483 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18486 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18487 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18488 COMMON/PYINT1/MINT(400),VINT(400)
18489 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18490 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18491 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18492 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18493 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
18494 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
18495C...Local arrays and saved variables.
18496 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
18497 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
18498 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
18499 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
18500
18501C...Initialization of multiple interaction treatment.
18502 IF(MMUL.EQ.1) THEN
18503 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
18504 ISUB=96
18505 MINT(1)=96
18506 VINT(63)=0D0
18507 VINT(64)=0D0
18508 VINT(143)=1D0
18509 VINT(144)=1D0
18510
18511C...Loop over phase space points: xT2 choice in 20 bins.
18512 100 SIGSUM=0D0
18513 DO 120 IXT2=1,20
18514 NMUL(IXT2)=MSTP(83)
18515 SIGM(IXT2)=0D0
18516 DO 110 ITRY=1,MSTP(83)
18517 RSCA=0.05D0*((21-IXT2)-PYR(0))
18518 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
18519 XT2=MAX(0.01D0*VINT(149),XT2)
18520 VINT(25)=XT2
18521
18522C...Choose tau and y*. Calculate cos(theta-hat).
18523 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18524 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18525 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18526 ELSE
18527 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18528 ENDIF
18529 VINT(21)=TAU
18530 CALL PYKLIM(2)
18531 RYST=PYR(0)
18532 MYST=1
18533 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18534 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18535 CALL PYKMAP(2,MYST,PYR(0))
18536 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18537
18538C...Calculate differential cross-section.
18539 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18540 CALL PYSIGH(NCHN,SIGS)
18541 SIGM(IXT2)=SIGM(IXT2)+SIGS
18542 110 CONTINUE
18543 SIGSUM=SIGSUM+SIGM(IXT2)
18544 120 CONTINUE
18545 SIGSUM=SIGSUM/(20D0*MSTP(83))
18546
18547C...Reject result if sigma(parton-parton) is smaller than hadronic one.
18548 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
18549 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
18550 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
18551 PARP(82)=0.9D0*PARP(82)
18552 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
18553 & VINT(2)
18554 GOTO 100
18555 ENDIF
18556 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
18557 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
18558
18559C...Start iteration to find k factor.
18560 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
18561 P83A=(1D0-PARP(83))**2
18562 P83B=2D0*PARP(83)*(1D0-PARP(83))
18563 P83C=PARP(83)**2
18564 CQ2I=1D0/PARP(84)**2
18565 CQ2R=2D0/(1D0+PARP(84)**2)
18566 SO=0.5D0
18567 XI=0D0
18568 YI=0D0
18569 XF=0D0
18570 YF=0D0
18571 XK=0.5D0
18572 IIT=0
18573 130 IF(IIT.EQ.0) THEN
18574 XK=2D0*XK
18575 ELSEIF(IIT.EQ.1) THEN
18576 XK=0.5D0*XK
18577 ELSE
18578 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
18579 ENDIF
18580
18581C...Evaluate overlap integrals. Find where to divide the b range.
18582 IF(MSTP(82).EQ.2) THEN
18583 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
18584 SOP=SP/PARU(1)
18585 ELSE
18586 IF(MSTP(82).EQ.3) THEN
18587 DELTAB=0.02D0
18588 ELSEIF(MSTP(82).EQ.4) THEN
18589 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
18590 ELSE
18591 POWIP=MAX(0.4D0,PARP(83))
18592 RPWIP=2D0/POWIP-1D0
18593 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
18594 SO=0D0
18595 ENDIF
18596 SP=0D0
18597 SOP=0D0
18598 BSP=0D0
18599 SOHIGH=0D0
18600 IBDIV=0
18601 B=-0.5D0*DELTAB
18602 140 B=B+DELTAB
18603 IF(MSTP(82).EQ.3) THEN
18604 OV=EXP(-B**2)/PARU(2)
18605 ELSEIF(MSTP(82).EQ.4) THEN
18606 OV=(P83A*EXP(-MIN(50D0,B**2))+
18607 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18608 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18609 ELSE
18610 OV=EXP(-B**POWIP)/PARU(2)
18611 SO=SO+PARU(2)*B*DELTAB*OV
18612 ENDIF
18613 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18614 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18615 SP=SP+PARU(2)*B*DELTAB*PACC
18616 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18617 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18618 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18619 IBDIV=1
18620 BDIV=B+0.5D0*DELTAB
18621 ENDIF
18622 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18623 ENDIF
18624 YK=PARU(1)*XK*SO/SP
18625
18626C...Continue iteration until convergence.
18627 IF(YK.LT.YKE) THEN
18628 XI=XK
18629 YI=YK
18630 IF(IIT.EQ.1) IIT=2
18631 ELSE
18632 XF=XK
18633 YF=YK
18634 IF(IIT.EQ.0) IIT=1
18635 ENDIF
18636 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18637
18638C...Store some results for subsequent use.
18639 BAVG=BSP/SP
18640 VINT(145)=SIGSUM
18641 VINT(146)=SOP/SO
18642 VINT(147)=SOP/SP
18643 VNT145=VINT(145)
18644 VNT146=VINT(146)
18645 VNT147=VINT(147)
18646C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18647 PIK=(VNT146/VNT147)*YKE
18648
18649C...Find relative weight for low and high impact parameter.
18650 PLOWB=PARU(1)*BDIV**2
18651 IF(MSTP(82).EQ.3) THEN
18652 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18653 ELSEIF(MSTP(82).EQ.4) THEN
18654 S4A=P83A*EXP(-BDIV**2)
18655 S4B=P83B*EXP(-BDIV**2*CQ2R)
18656 S4C=P83C*EXP(-BDIV**2*CQ2I)
18657 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18658 ELSEIF(PARP(83).GE.1.999D0) THEN
18659 PHIGHB=PIK*SOHIGH
18660 B2RPDV=BDIV**POWIP
18661 ELSE
18662 PHIGHB=PIK*SOHIGH
18663 B2RPDV=BDIV**POWIP
18664 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18665 ENDIF
18666 PALLB=PLOWB+PHIGHB
18667
18668C...Initialize iteration in xT2 for hardest interaction.
18669 ELSEIF(MMUL.EQ.2) THEN
18670 VINT(145)=VNT145
18671 VINT(146)=VNT146
18672 VINT(147)=VNT147
18673 IF(MSTP(82).LE.0) THEN
18674 ELSEIF(MSTP(82).EQ.1) THEN
18675 XT2=1D0
18676 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18677 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18678 & VINT(317)/(VINT(318)*VINT(320))
18679 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18680 ELSEIF(MSTP(82).EQ.2) THEN
18681 XT2=1D0
18682 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18683 & VINT(149)*(1D0+VINT(149))
18684 ELSE
18685 XC2=4D0*CKIN(3)**2/VINT(2)
18686 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18687 ENDIF
18688
18689C...Select impact parameter for hardest interaction.
18690 IF(MSTP(82).LE.2) RETURN
18691 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18692C...Treatment in low b region.
18693 MINT(39)=1
18694 B=BDIV*SQRT(PYR(0))
18695 IF(MSTP(82).EQ.3) THEN
18696 OV=EXP(-B**2)/PARU(2)
18697 ELSEIF(MSTP(82).EQ.4) THEN
18698 OV=(P83A*EXP(-MIN(50D0,B**2))+
18699 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18700 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18701 ELSE
18702 OV=EXP(-B**POWIP)/PARU(2)
18703 ENDIF
18704 VINT(148)=OV/VNT147
18705 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18706 XT2=1D0
18707 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18708 & VINT(149)*(1D0+VINT(149))
18709 ELSE
18710C...Treatment in high b region.
18711 MINT(39)=2
18712 IF(MSTP(82).EQ.3) THEN
18713 B=SQRT(BDIV**2-LOG(PYR(0)))
18714 OV=EXP(-B**2)/PARU(2)
18715 ELSEIF(MSTP(82).EQ.4) THEN
18716 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18717 IF(S4RNDM.LT.S4A) THEN
18718 B=SQRT(BDIV**2-LOG(PYR(0)))
18719 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18720 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18721 ELSE
18722 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18723 ENDIF
18724 OV=(P83A*EXP(-MIN(50D0,B**2))+
18725 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18726 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18727 ELSEIF(PARP(83).GE.1.999D0) THEN
18728 144 B2RPW=B2RPDV-LOG(PYR(0))
18729 ACCIP=(B2RPW/B2RPDV)**RPWIP
18730 IF(ACCIP.LT.PYR(0)) GOTO 144
18731 OV=EXP(-B2RPW)/PARU(2)
18732 B=B2RPW**(1D0/POWIP)
18733 ELSE
18734 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18735 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18736 IF(ACCIP.LT.PYR(0)) GOTO 146
18737 OV=EXP(-B2RPW)/PARU(2)
18738 B=B2RPW**(1D0/POWIP)
18739 ENDIF
18740 VINT(148)=OV/VNT147
18741 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18742 ENDIF
18743 IF(PACC.LT.PYR(0)) GOTO 142
18744 VINT(139)=B/BAVG
18745
18746 ELSEIF(MMUL.EQ.3) THEN
18747C...Low-pT or multiple interactions (first semihard interaction):
18748C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18749C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18750 ISUB=MINT(1)
18751 VINT(145)=VNT145
18752 VINT(146)=VNT146
18753 VINT(147)=VNT147
18754 IF(MSTP(82).LE.0) THEN
18755 XT2=0D0
18756 ELSEIF(MSTP(82).EQ.1) THEN
18757 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18758C...Use with "Sudakov" for low b values when impact parameter dependence.
18759 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18760 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18761 & VINT(149)))).GT.PYR(0)) XT2=1D0
18762 IF(XT2.GE.1D0) THEN
18763 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18764 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18765 & VINT(149)
18766 ELSE
18767 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18768 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18769 & VINT(149)
18770 ENDIF
18771 XT2=MAX(0.01D0*VINT(149),XT2)
18772C...Use without "Sudakov" for high b values when impact parameter dep.
18773 ELSE
18774 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18775 & PYR(0)*(1D0-XC2))-VINT(149)
18776 XT2=MAX(0.01D0*VINT(149),XT2)
18777 ENDIF
18778 VINT(25)=XT2
18779
18780C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18781 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18782 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18783 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18784 ISUB=95
18785 MINT(1)=ISUB
18786 VINT(21)=0.01D0*VINT(149)
18787 VINT(22)=0D0
18788 VINT(23)=0D0
18789 VINT(25)=0.01D0*VINT(149)
18790
18791 ELSE
18792C...Multiple interactions (first semihard interaction).
18793C...Choose tau and y*. Calculate cos(theta-hat).
18794 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18795 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18796 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18797 ELSE
18798 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18799 ENDIF
18800 VINT(21)=TAU
18801 CALL PYKLIM(2)
18802 RYST=PYR(0)
18803 MYST=1
18804 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18805 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18806 CALL PYKMAP(2,MYST,PYR(0))
18807 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18808 ENDIF
18809 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18810
18811C...Store results of cross-section calculation.
18812 ELSEIF(MMUL.EQ.4) THEN
18813 ISUB=MINT(1)
18814 VINT(145)=VNT145
18815 VINT(146)=VNT146
18816 VINT(147)=VNT147
18817 XTS=VINT(25)
18818 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18819 IF(ISET(ISUB).EQ.2)
18820 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18821 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18822 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18823 & (XTS+VINT(149))))
18824 IRBIN=INT(1D0+20D0*RBIN)
18825 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18826 NMUL(IRBIN)=NMUL(IRBIN)+1
18827 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18828 ENDIF
18829
18830C...Choose impact parameter if not already done.
18831 ELSEIF(MMUL.EQ.5) THEN
18832 ISUB=MINT(1)
18833 VINT(145)=VNT145
18834 VINT(146)=VNT146
18835 VINT(147)=VNT147
18836 150 IF(MINT(39).GT.0) THEN
18837 ELSEIF(MSTP(82).EQ.3) THEN
18838 EXPB2=PYR(0)
18839 B2=-LOG(PYR(0))
18840 VINT(148)=EXPB2/(PARU(2)*VNT147)
18841 VINT(139)=SQRT(B2)/BAVG
18842 ELSEIF(MSTP(82).EQ.4) THEN
18843 RTYPE=PYR(0)
18844 IF(RTYPE.LT.P83A) THEN
18845 B2=-LOG(PYR(0))
18846 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18847 B2=-LOG(PYR(0))/CQ2R
18848 ELSE
18849 B2=-LOG(PYR(0))/CQ2I
18850 ENDIF
18851 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18852 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18853 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18854 VINT(139)=SQRT(B2)/BAVG
18855 ELSEIF(PARP(83).GE.1.999D0) THEN
18856 POWIP=MAX(2D0,PARP(83))
18857 RPWIP=2D0/POWIP-1D0
18858 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18859 160 IF(PYR(0).LT.PROB1) THEN
18860 B2RPW=PYR(0)**(0.5D0*POWIP)
18861 ACCIP=EXP(-B2RPW)
18862 ELSE
18863 B2RPW=1D0-LOG(PYR(0))
18864 ACCIP=B2RPW**RPWIP
18865 ENDIF
18866 IF(ACCIP.LT.PYR(0)) GOTO 160
18867 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18868 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18869 ELSE
18870 POWIP=MAX(0.4D0,PARP(83))
18871 RPWIP=2D0/POWIP-1D0
18872 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18873 170 IF(PYR(0).LT.PROB1) THEN
18874 B2RPW=2D0*RPWIP*PYR(0)
18875 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18876 ELSE
18877 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18878 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18879 ENDIF
18880 IF(ACCIP.LT .PYR(0)) GOTO 170
18881 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18882 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18883 ENDIF
18884
18885C...Multiple interactions (variable impact parameter) : reject with
18886C...probability exp(-overlap*cross-section above pT/normalization).
18887C...Does not apply to low-b region, where "Sudakov" already included.
18888 VINT(150)=1D0
18889 IF(MINT(39).NE.1) THEN
18890 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18891 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18892 DO 180 IBIN=IRBIN+1,20
18893 RNCOR=RNCOR+NMUL(IBIN)
18894 SIGCOR=SIGCOR+SIGM(IBIN)
18895 180 CONTINUE
18896 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18897 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18898 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18899 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18900 ENDIF
18901 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18902 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18903 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18904 IF(VINT(150).LT.PYR(0)) GOTO 150
18905 VINT(150)=1D0
18906 ENDIF
18907
18908C...Generate additional multiple semihard interactions.
18909 ELSEIF(MMUL.EQ.6) THEN
18910 ISUBSV=MINT(1)
18911 VINT(145)=VNT145
18912 VINT(146)=VNT146
18913 VINT(147)=VNT147
18914 DO 190 J=11,80
18915 VINTSV(J)=VINT(J)
18916 190 CONTINUE
18917 ISUB=96
18918 MINT(1)=96
18919 VINT(151)=0D0
18920 VINT(152)=0D0
18921
18922C...Reconstruct strings in hard scattering.
18923 NMAX=MINT(84)+4
18924 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18925 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18926 NSTR=0
18927 DO 210 I=MINT(84)+1,NMAX
18928 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18929 IF(KCS.EQ.0) GOTO 210
18930 DO 200 J=1,4
18931 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18932 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18933 IF(J.LE.2) THEN
18934 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18935 ELSE
18936 IST=MOD(K(I,J+1),MSTU(5))
18937 ENDIF
18938 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18939 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18940 NSTR=NSTR+1
18941 IF(J.EQ.1.OR.J.EQ.4) THEN
18942 KSTR(NSTR,1)=I
18943 KSTR(NSTR,2)=IST
18944 ELSE
18945 KSTR(NSTR,1)=IST
18946 KSTR(NSTR,2)=I
18947 ENDIF
18948 200 CONTINUE
18949 210 CONTINUE
18950
18951C...Set up starting values for iteration in xT2.
18952 XT2=4D0*VINT(62)/VINT(2)
18953 IF(MSTP(82).LE.1) THEN
18954 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18955 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18956 & VINT(317)/(VINT(318)*VINT(320))
18957 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18958 ELSE
18959 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18960 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18961 ENDIF
18962 VINT(63)=0D0
18963 VINT(64)=0D0
18964 VINT(143)=1D0-VINT(141)
18965 VINT(144)=1D0-VINT(142)
18966
18967C...Iterate downwards in xT2.
18968 220 IF(MSTP(82).LE.1) THEN
18969 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18970 IF(XT2.LT.VINT(149)) GOTO 270
18971 ELSE
18972 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18973 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18974 & LOG(PYR(0)))-VINT(149)
18975 IF(XT2.LE.0D0) GOTO 270
18976 XT2=MAX(0.01D0*VINT(149),XT2)
18977 ENDIF
18978 VINT(25)=XT2
18979
18980C...Choose tau and y*. Calculate cos(theta-hat).
18981 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18982 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18983 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18984 ELSE
18985 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18986 ENDIF
18987 VINT(21)=TAU
18988 CALL PYKLIM(2)
18989 RYST=PYR(0)
18990 MYST=1
18991 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18992 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18993 CALL PYKMAP(2,MYST,PYR(0))
18994 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18995
18996C...Check that x not used up. Accept or reject kinematical variables.
18997 X1M=SQRT(TAU)*EXP(VINT(22))
18998 X2M=SQRT(TAU)*EXP(-VINT(22))
18999 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19000 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19001 CALL PYSIGH(NCHN,SIGS)
19002 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19003 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19004
19005C...Reset K, P and V vectors. Select some variables.
19006 DO 240 I=N+1,N+2
19007 DO 230 J=1,5
19008 K(I,J)=0
19009 P(I,J)=0D0
19010 V(I,J)=0D0
19011 230 CONTINUE
19012 240 CONTINUE
19013 RFLAV=PYR(0)
19014 PT=0.5D0*VINT(1)*SQRT(XT2)
19015 PHI=PARU(2)*PYR(0)
19016 CTH=VINT(23)
19017
19018C...Add first parton to event record.
19019 K(N+1,1)=3
19020 K(N+1,2)=21
19021 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19022 & 1+INT((2D0+PARJ(2))*PYR(0))
19023 P(N+1,1)=PT*COS(PHI)
19024 P(N+1,2)=PT*SIN(PHI)
19025 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19026 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19027 P(N+1,5)=0D0
19028
19029C...Add second parton to event record.
19030 K(N+2,1)=3
19031 K(N+2,2)=21
19032 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19033 P(N+2,1)=-P(N+1,1)
19034 P(N+2,2)=-P(N+1,2)
19035 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19036 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19037 P(N+2,5)=0D0
19038
19039 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19040C....Choose relevant string pieces to place gluons on.
19041 DO 260 I=N+1,N+2
19042 DMIN=1D8
19043 DO 250 ISTR=1,NSTR
19044 I1=KSTR(ISTR,1)
19045 I2=KSTR(ISTR,2)
19046 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19047 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19048 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19049 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19050 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19051 DMIN=DIST
19052 IST1=I1
19053 IST2=I2
19054 ISTM=ISTR
19055 ENDIF
19056 250 CONTINUE
19057
19058C....Colour flow adjustments, new string pieces.
19059 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19060 & MOD(K(IST1,4),MSTU(5))
19061 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19062 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19063 K(I,5)=MSTU(5)*IST1
19064 K(I,4)=MSTU(5)*IST2
19065 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19066 & MOD(K(IST2,5),MSTU(5))
19067 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19068 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19069 KSTR(ISTM,2)=I
19070 KSTR(NSTR+1,1)=I
19071 KSTR(NSTR+1,2)=IST2
19072 NSTR=NSTR+1
19073 260 CONTINUE
19074
19075C...String drawing and colour flow for gluon loop.
19076 ELSEIF(K(N+1,2).EQ.21) THEN
19077 K(N+1,4)=MSTU(5)*(N+2)
19078 K(N+1,5)=MSTU(5)*(N+2)
19079 K(N+2,4)=MSTU(5)*(N+1)
19080 K(N+2,5)=MSTU(5)*(N+1)
19081 KSTR(NSTR+1,1)=N+1
19082 KSTR(NSTR+1,2)=N+2
19083 KSTR(NSTR+2,1)=N+2
19084 KSTR(NSTR+2,2)=N+1
19085 NSTR=NSTR+2
19086
19087C...String drawing and colour flow for qqbar pair.
19088 ELSE
19089 K(N+1,4)=MSTU(5)*(N+2)
19090 K(N+2,5)=MSTU(5)*(N+1)
19091 KSTR(NSTR+1,1)=N+1
19092 KSTR(NSTR+1,2)=N+2
19093 NSTR=NSTR+1
19094 ENDIF
19095
19096C...Global statistics.
19097 MINT(351)=MINT(351)+1
19098 VINT(351)=VINT(351)+PT
19099 IF (MINT(351).EQ.1) VINT(356)=PT
19100
19101C...Update remaining energy; iterate.
19102 N=N+2
19103 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19104 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19105 MINT(51)=1
19106 RETURN
19107 ENDIF
19108 MINT(31)=MINT(31)+1
19109 VINT(151)=VINT(151)+VINT(41)
19110 VINT(152)=VINT(152)+VINT(42)
19111 VINT(143)=VINT(143)-VINT(41)
19112 VINT(144)=VINT(144)-VINT(42)
19113C...Allow FSR for UE
19114 IF(MSTP(152).EQ.1) then
19115 if(parj(200).ne.1.) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19116 if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,SQRT(PARP(71))*PT)
19117 endif
19118 IF(MINT(31).LT.240) GOTO 220
19119 270 CONTINUE
19120 MINT(1)=ISUBSV
19121 DO 280 J=11,80
19122 VINT(J)=VINTSV(J)
19123 280 CONTINUE
19124 ENDIF
19125
19126C...Format statements for printout.
19127 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19128 &'actions for MSTP(82) =',I2,' ******')
19129 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19130 &D9.2,' mb: rejected')
19131 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19132 &D9.2,' mb: accepted')
19133
19134 RETURN
19135 END
19136
19137C*********************************************************************
19138
19139C...PYREMN
19140C...Adds on target remnants (one or two from each side) and
19141C...includes primordial kT for hadron beams.
19142
19143 SUBROUTINE PYREMN(IPU1,IPU2)
19144
19145C...Double precision and integer declarations.
19146 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19147 IMPLICIT INTEGER(I-N)
19148 INTEGER PYK,PYCHGE,PYCOMP
19149C...Commonblocks.
19150 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19151 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19152 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19153 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19154 COMMON/PYINT1/MINT(400),VINT(400)
19155 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19156C...Local arrays.
19157 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19158 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19159
19160C...Find event type and remaining energy.
19161 ISUB=MINT(1)
19162 NS=N
19163 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19164 VINT(143)=1D0-VINT(141)
19165 VINT(144)=1D0-VINT(142)
19166 ENDIF
19167
19168C...Define initial partons.
19169 NTRY=0
19170 100 NTRY=NTRY+1
19171 DO 130 JT=1,2
19172 I=MINT(83)+JT+2
19173 IF(JT.EQ.1) IPU=IPU1
19174 IF(JT.EQ.2) IPU=IPU2
19175 K(I,1)=21
19176 K(I,2)=K(IPU,2)
19177 K(I,3)=I-2
19178 PMS(JT)=0D0
19179 VINT(156+JT)=0D0
19180 VINT(158+JT)=0D0
19181 IF(MINT(47).EQ.1) THEN
19182 DO 110 J=1,5
19183 P(I,J)=P(I-2,J)
19184 110 CONTINUE
19185 ELSEIF(ISUB.EQ.95) THEN
19186 K(I,2)=21
19187 ELSE
19188 P(I,5)=P(IPU,5)
19189
19190C...No primordial kT, or chosen according to truncated Gaussian or
19191C...exponential, or (for photon) predetermined or power law.
19192 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19193 IF(MSTP(91).LE.0) THEN
19194 PT=0D0
19195 ELSEIF(MSTP(91).EQ.1) THEN
19196 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19197 ELSE
19198 RPT1=PYR(0)
19199 RPT2=PYR(0)
19200 PT=-PARP(92)*LOG(RPT1*RPT2)
19201 ENDIF
19202 IF(PT.GT.PARP(93)) GOTO 120
19203 ELSEIF(MINT(106+JT).EQ.3) THEN
19204 PTA=SQRT(VINT(282+JT))
19205 PTB=0D0
19206 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19207 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19208 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19209 RPT1=PYR(0)
19210 RPT2=PYR(0)
19211 PTB=-PARP(99)*LOG(RPT1*RPT2)
19212 ENDIF
19213 IF(PTB.GT.PARP(100)) GOTO 120
19214 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19215 PT=PT*0.8D0**MINT(57)
19216 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19217 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19218 IF(MSTP(93).LE.0) THEN
19219 PT=0D0
19220 ELSEIF(MSTP(93).EQ.1) THEN
19221 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19222 ELSEIF(MSTP(93).EQ.2) THEN
19223 RPT1=PYR(0)
19224 RPT2=PYR(0)
19225 PT=-PARP(99)*LOG(RPT1*RPT2)
19226 ELSEIF(MSTP(93).EQ.3) THEN
19227 HA=PARP(99)**2
19228 HB=PARP(100)**2
19229 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19230 ELSE
19231 HA=PARP(99)**2
19232 HB=PARP(100)**2
19233 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19234 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19235 ENDIF
19236 IF(PT.GT.PARP(100)) GOTO 120
19237 ELSE
19238 PT=0D0
19239 ENDIF
19240 VINT(156+JT)=PT
19241 PHI=PARU(2)*PYR(0)
19242 P(I,1)=PT*COS(PHI)
19243 P(I,2)=PT*SIN(PHI)
19244 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19245 ENDIF
19246 130 CONTINUE
19247 IF(MINT(47).EQ.1) RETURN
19248
19249C...Kinematics construction for initial partons.
19250 I1=MINT(83)+3
19251 I2=MINT(83)+4
19252 IF(ISUB.EQ.95) THEN
19253 SHS=0D0
19254 SHR=0D0
19255 ELSE
19256 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19257 & (P(I1,2)+P(I2,2))**2
19258 SHR=SQRT(MAX(0D0,SHS))
19259 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19260 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19261 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19262 P(I2,4)=SHR-P(I1,4)
19263 P(I2,3)=-P(I1,3)
19264
19265C...Transform partons to overall CM-frame.
19266 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19267 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19268 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19269 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19270 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19271 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19272 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19273 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19274 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19275 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19276 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19277 ENDIF
19278
19279C...Optionally fix up x and Q2 definitions for leptoproduction.
19280 IDISXQ=0
19281 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19282 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19283 IF(IDISXQ.EQ.1) THEN
19284
19285C...Find where incoming and outgoing leptons/partons are sitting.
19286 LESD=1
19287 IF(MINT(42).EQ.1) LESD=2
19288 LPIN=MINT(83)+3-LESD
19289 LEIN=MINT(84)+LESD
19290 LQIN=MINT(84)+3-LESD
19291 LEOUT=MINT(84)+2+LESD
19292 LQOUT=MINT(84)+5-LESD
19293 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19294 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19295 LSCMS=0
19296 DO 140 I=MINT(84)+5,N
19297 IF(K(I,2).EQ.94) THEN
19298 LSCMS=I
19299 LEOUT=I+LESD
19300 LQOUT=I+3-LESD
19301 ENDIF
19302 140 CONTINUE
19303 LQBG=IPU1
19304 IF(LESD.EQ.1) LQBG=IPU2
19305
19306C...Calculate actual and wanted momentum transfer.
19307 XNOM=VINT(43-LESD)
19308 Q2NOM=-VINT(45)
19309 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19310 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19311 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19312 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19313 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19314 P(N+1,1)=FAC*P(LEOUT,1)
19315 P(N+1,2)=FAC*P(LEOUT,2)
19316 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19317 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19318 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19319 & P(N+1,3)**2)
19320 DO 150 J=1,4
19321 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19322 QNEW(J)=P(LEIN,J)-P(N+1,J)
19323 150 CONTINUE
19324
19325C...Boost outgoing electron and daughters.
19326 IF(LSCMS.EQ.0) THEN
19327 DO 160 J=1,4
19328 P(LEOUT,J)=P(N+1,J)
19329 160 CONTINUE
19330 ELSE
19331 DO 170 J=1,3
19332 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19333 170 CONTINUE
19334 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19335 DO 180 J=1,3
19336 DBE(J)=PINV*P(N+2,J)
19337 180 CONTINUE
19338 DO 200 I=LSCMS+1,N
19339 IORIG=I
19340 190 IORIG=K(IORIG,3)
19341 IF(IORIG.GT.LEOUT) GOTO 190
19342 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19343 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19344 200 CONTINUE
19345 ENDIF
19346
19347C...Copy shower initiator and all outgoing partons.
19348 NCOP=N+1
19349 K(NCOP,3)=LQBG
19350 DO 210 J=1,5
19351 P(NCOP,J)=P(LQBG,J)
19352 210 CONTINUE
19353 DO 240 I=MINT(84)+1,N
19354 ICOP=0
19355 IF(K(I,1).GT.10) GOTO 240
19356 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19357 ICOP=I
19358 ELSE
19359 IORIG=I
19360 220 IORIG=K(IORIG,3)
19361 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19362 ICOP=IORIG
19363 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19364 GOTO 220
19365 ENDIF
19366 ENDIF
19367 IF(ICOP.NE.0) THEN
19368 NCOP=NCOP+1
19369 K(NCOP,3)=I
19370 DO 230 J=1,5
19371 P(NCOP,J)=P(I,J)
19372 230 CONTINUE
19373 ENDIF
19374 240 CONTINUE
19375
19376C...Calculate relative rescaling factors.
19377 SLC=3-2*LESD
19378 PLCSUM=0D0
19379 DO 250 I=N+2,NCOP
19380 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
19381 250 CONTINUE
19382 DO 260 I=N+2,NCOP
19383 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
19384 260 CONTINUE
19385
19386C...Transfer extra three-momentum of current.
19387 DO 280 I=N+2,NCOP
19388 DO 270 J=1,3
19389 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
19390 270 CONTINUE
19391 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19392 280 CONTINUE
19393
19394C...Iterate change of initiator momentum to get energy right.
19395 ITER=0
19396 290 ITER=ITER+1
19397 PEEX=-P(N+1,4)-QNEW(4)
19398 PEMV=-P(N+1,3)/P(N+1,4)
19399 DO 300 I=N+2,NCOP
19400 PEEX=PEEX+P(I,4)
19401 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
19402 300 CONTINUE
19403 IF(ABS(PEMV).LT.1D-10) THEN
19404 MINT(51)=1
19405 MINT(57)=MINT(57)+1
19406 RETURN
19407 ENDIF
19408 PZCH=-PEEX/PEMV
19409 P(N+1,3)=P(N+1,3)+PZCH
19410 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)
19411 DO 310 I=N+2,NCOP
19412 P(I,3)=P(I,3)+V(I,1)*PZCH
19413 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19414 310 CONTINUE
19415 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
19416
19417C...Modify momenta in event record.
19418 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
19419 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
19420 IF(ABS(HBE).GE.1D0) THEN
19421 MINT(51)=1
19422 MINT(57)=MINT(57)+1
19423 RETURN
19424 ENDIF
19425 I=MINT(83)+5-LESD
19426 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
19427 DO 330 I=N+1,NCOP
19428 ICOP=K(I,3)
19429 DO 320 J=1,4
19430 P(ICOP,J)=P(I,J)
19431 320 CONTINUE
19432 330 CONTINUE
19433 ENDIF
19434
19435C...Check minimum invariant mass of remnant system(s).
19436 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
19437 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
19438 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19439 PMIN(0)=SQRT(PMS(0))
19440 DO 340 JT=1,2
19441 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
19442 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
19443 PMIN(JT)=0D0
19444 IF(MINT(44+JT).EQ.1) GOTO 340
19445 MINT(105)=MINT(102+JT)
19446 MINT(109)=MINT(106+JT)
19447 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
19448 IF(MINT(51).NE.0) THEN
19449 MINT(57)=MINT(57)+1
19450 RETURN
19451 ENDIF
19452 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
19453 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
19454 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
19455 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
19456 & P(MINT(83)+JT+2,2)**2)
19457 340 CONTINUE
19458 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
19459 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
19460 &PSYS(2,4))) THEN
19461 MINT(51)=1
19462 MINT(57)=MINT(57)+1
19463 RETURN
19464 ENDIF
19465
19466C...Loop over two remnants; skip if none there.
19467 I=NS
19468 DO 410 JT=1,2
19469 ISN(JT)=0
19470 IF(MINT(44+JT).EQ.1) GOTO 410
19471 IF(JT.EQ.1) IPU=IPU1
19472 IF(JT.EQ.2) IPU=IPU2
19473
19474C...Store first remnant parton.
19475 I=I+1
19476 IS(JT)=I
19477 ISN(JT)=1
19478 DO 350 J=1,5
19479 K(I,J)=0
19480 P(I,J)=0D0
19481 V(I,J)=0D0
19482 350 CONTINUE
19483 K(I,1)=1
19484 K(I,2)=KFLSP(JT)
19485 K(I,3)=MINT(83)+JT
19486 P(I,5)=PYMASS(K(I,2))
19487
19488C...First parton colour connections and kinematics.
19489 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
19490 IF(KCOL.EQ.2) THEN
19491 K(I,1)=3
19492 K(I,4)=MSTU(5)*IPU+IPU
19493 K(I,5)=MSTU(5)*IPU+IPU
19494 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19495 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19496 ELSEIF(KCOL.NE.0) THEN
19497 K(I,1)=3
19498 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
19499 K(I,KFLS+3)=IPU
19500 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19501 ENDIF
19502 IF(KFLCH(JT).EQ.0) THEN
19503 P(I,1)=-P(MINT(83)+JT+2,1)
19504 P(I,2)=-P(MINT(83)+JT+2,2)
19505 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19506 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19507 P(I,3)=PSYS(JT,3)
19508 P(I,4)=PSYS(JT,4)
19509
19510C...When extra remnant parton or hadron: store extra remnant.
19511 ELSE
19512 I=I+1
19513 ISN(JT)=2
19514 DO 360 J=1,5
19515 K(I,J)=0
19516 P(I,J)=0D0
19517 V(I,J)=0D0
19518 360 CONTINUE
19519 K(I,1)=1
19520 K(I,2)=KFLCH(JT)
19521 K(I,3)=MINT(83)+JT
19522 P(I,5)=PYMASS(K(I,2))
19523
19524C...Find parton colour connections of extra remnant.
19525 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
19526 IF(KCOL.EQ.2) THEN
19527 K(I,1)=3
19528 K(I,4)=MSTU(5)*IPU+IPU
19529 K(I,5)=MSTU(5)*IPU+IPU
19530 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19531 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19532 ELSEIF(KCOL.NE.0) THEN
19533 K(I,1)=3
19534 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
19535 K(I,KFLS+3)=IPU
19536 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19537 ENDIF
19538
19539C...Relative transverse momentum when two remnants.
19540 LOOP=0
19541 370 LOOP=LOOP+1
19542 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
19543 IF(IABS(MINT(10+JT)).LT.20) THEN
19544 P(I-1,1)=0D0
19545 P(I-1,2)=0D0
19546 ELSE
19547 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
19548 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
19549 ENDIF
19550 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
19551 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
19552 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
19553 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19554
19555C...Meson or baryon; photon as meson. For splitup below.
19556 IMB=1
19557 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
19558
19559C***Relative distribution for electron into two electrons. Temporary!
19560 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
19561 & THEN
19562 CHI(JT)=PYR(0)
19563
19564C...Relative distribution of electron energy into electron plus parton.
19565 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
19566 XHRD=VINT(140+JT)
19567 XE=VINT(154+JT)
19568 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
19569
19570C...Relative distribution of energy for particle into two jets.
19571 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
19572 CHIK=PARP(92+2*IMB)
19573 IF(MSTP(92).LE.1) THEN
19574 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19575 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19576 ELSEIF(MSTP(92).EQ.2) THEN
19577 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
19578 ELSEIF(MSTP(92).EQ.3) THEN
19579 CUT=2D0*0.3D0/VINT(1)
19580 380 CHI(JT)=PYR(0)**2
19581 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
19582 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
19583 ELSEIF(MSTP(92).EQ.4) THEN
19584 CUT=2D0*0.3D0/VINT(1)
19585 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
19586 390 CHIR=CUT*CUTR**PYR(0)
19587 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
19588 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
19589 ELSE
19590 CUT=2D0*0.3D0/VINT(1)
19591 CUTA=CUT**(1D0-PARP(98))
19592 CUTB=(1D0+CUT)**(1D0-PARP(98))
19593 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
19594 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
19595 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
19596 ENDIF
19597
19598C...Relative distribution of energy for particle into jet plus particle.
19599 ELSE
19600 IF(MSTP(94).LE.1) THEN
19601 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19602 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19603 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19604 ELSEIF(MSTP(94).EQ.2) THEN
19605 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
19606 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19607 ELSEIF(MSTP(94).EQ.3) THEN
19608 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19609 CHI(JT)=ZZ
19610 ELSE
19611 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19612 CHI(JT)=ZZ
19613 ENDIF
19614 ENDIF
19615
19616C...Construct total transverse mass; reject if too large.
19617 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19618 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19619 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19620 IF(LOOP.LT.100) THEN
19621 GOTO 370
19622 ELSE
19623 MINT(51)=1
19624 MINT(57)=MINT(57)+1
19625 RETURN
19626 ENDIF
19627 ENDIF
19628 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19629 VINT(158+JT)=CHI(JT)
19630
19631C...Subdivide longitudinal momentum according to value selected above.
19632 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19633 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19634 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19635 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19636 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19637 ENDIF
19638 410 CONTINUE
19639 N=I
19640
19641C...Check if longitudinal boosts needed - if so pick two systems.
19642 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19643 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19644 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19645 IF(ISN(1).EQ.0) THEN
19646 IR=0
19647 IL=2
19648 ELSEIF(ISN(2).EQ.0) THEN
19649 IR=1
19650 IL=0
19651 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19652 IR=1
19653 IL=2
19654 ELSEIF(VINT(143).GT.0.2D0) THEN
19655 IR=1
19656 IL=0
19657 ELSEIF(VINT(144).GT.0.2D0) THEN
19658 IR=0
19659 IL=2
19660 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19661 IR=1
19662 IL=0
19663 ELSE
19664 IR=0
19665 IL=2
19666 ENDIF
19667 IG=3-IR-IL
19668
19669C...E+-pL wanted for system to be modified.
19670 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19671 PPB=VINT(1)
19672 PNB=VINT(1)
19673 ELSE
19674 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19675 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19676 ENDIF
19677
19678C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19679 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19680 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19681 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19682 DO 420 J=1,4
19683 PSYS(0,J)=0D0
19684 420 CONTINUE
19685 DO 450 I=MINT(84)+1,NS
19686 IF(K(I,1).GT.10) GOTO 450
19687 INCL=0
19688 IORIG=I
19689 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19690 IORIG=K(IORIG,3)
19691 IF(IORIG.GT.LPIN) GOTO 430
19692 IF(INCL.EQ.0) GOTO 450
19693 DO 440 J=1,4
19694 PSYS(0,J)=PSYS(0,J)+P(I,J)
19695 440 CONTINUE
19696 450 CONTINUE
19697 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19698 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19699 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19700 ENDIF
19701
19702C...Construct longitudinal boosts.
19703 DPMTB=PPB*PNB
19704 DPMTR=PMS(IR)
19705 DPMTL=PMS(IL)
19706 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19707 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19708 MINT(51)=1
19709 MINT(57)=MINT(57)+1
19710 RETURN
19711 ENDIF
19712 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19713 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19714 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19715 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19716 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19717 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19718 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19719
19720C...Perform longitudinal boosts.
19721 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19722 P(IS(1),3)=0D0
19723 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19724 ELSEIF(IR.EQ.1) THEN
19725 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19726 ELSEIF(IDISXQ.EQ.1) THEN
19727 DO 470 I=I1,NS
19728 INCL=0
19729 IORIG=I
19730 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19731 IORIG=K(IORIG,3)
19732 IF(IORIG.GT.LPIN) GOTO 460
19733 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19734 470 CONTINUE
19735 ELSE
19736 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19737 ENDIF
19738 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19739 P(IS(2),3)=0D0
19740 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19741 ELSEIF(IL.EQ.2) THEN
19742 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19743 ELSEIF(IDISXQ.EQ.1) THEN
19744 DO 490 I=I1,NS
19745 INCL=0
19746 IORIG=I
19747 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19748 IORIG=K(IORIG,3)
19749 IF(IORIG.GT.LPIN) GOTO 480
19750 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19751 490 CONTINUE
19752 ELSE
19753 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19754 ENDIF
19755
19756C...Final check that energy-momentum conservation worked.
19757 PESUM=0D0
19758 PZSUM=0D0
19759 DO 500 I=MINT(84)+1,N
19760 IF(K(I,1).GT.10) GOTO 500
19761 PESUM=PESUM+P(I,4)
19762 PZSUM=PZSUM+P(I,3)
19763 500 CONTINUE
19764 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19765 IF(PDEV.GT.1D-4*VINT(1)) THEN
19766 MINT(51)=1
19767 MINT(57)=MINT(57)+1
19768 RETURN
19769 ENDIF
19770
19771C...Calculate rotation and boost from overall CM frame to
19772C...hadronic CM frame in leptoproduction.
19773 MINT(91)=0
19774 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19775 MINT(91)=1
19776 LESD=1
19777 IF(MINT(42).EQ.1) LESD=2
19778 LPIN=MINT(83)+3-LESD
19779
19780C...Sum upp momenta of everything not lepton or photon to define boost.
19781 DO 510 J=1,4
19782 PSUM(J)=0D0
19783 510 CONTINUE
19784 DO 530 I=1,N
19785 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19786 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19787 IF(K(I,2).EQ.22) GOTO 530
19788 DO 520 J=1,4
19789 PSUM(J)=PSUM(J)+P(I,J)
19790 520 CONTINUE
19791 530 CONTINUE
19792 VINT(223)=-PSUM(1)/PSUM(4)
19793 VINT(224)=-PSUM(2)/PSUM(4)
19794 VINT(225)=-PSUM(3)/PSUM(4)
19795
19796C...Boost incoming hadron to hadronic CM frame to determine rotations.
19797 K(N+1,1)=1
19798 DO 540 J=1,5
19799 P(N+1,J)=P(LPIN,J)
19800 V(N+1,J)=V(LPIN,J)
19801 540 CONTINUE
19802 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19803 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19804 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19805 IF(LESD.EQ.2) THEN
19806 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19807 ELSE
19808 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19809 ENDIF
19810 ENDIF
19811
19812 RETURN
19813 END
19814
19815C*********************************************************************
19816
19817C...PYMIGN
19818C...Initializes treatment of new multiple interactions scenario,
19819C...selects kinematics of hardest interaction if low-pT physics
19820C...included in run, and generates all non-hardest interactions.
19821
19822 SUBROUTINE PYMIGN(MMUL)
19823
19824C...Double precision and integer declarations.
19825 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19826 IMPLICIT INTEGER(I-N)
19827 INTEGER PYK,PYCHGE,PYCOMP
19828 EXTERNAL PYALPS
19829 DOUBLE PRECISION PYALPS
19830C...Commonblocks.
19831 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19833 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19834 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19835 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19836 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19837 COMMON/PYINT1/MINT(400),VINT(400)
19838 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19839 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19840 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19841 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19842 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19843 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19844 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19845 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19846 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19847C...Local arrays and saved variables.
19848 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19849 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19850 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19851 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19852 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19853
19854C...Initialization of multiple interaction treatment.
19855 IF(MMUL.EQ.1) THEN
19856 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19857 ISUB=96
19858 MINT(1)=96
19859 VINT(63)=0D0
19860 VINT(64)=0D0
19861 VINT(143)=1D0
19862 VINT(144)=1D0
19863
19864C...Loop over phase space points: xT2 choice in 20 bins.
19865 100 SIGSUM=0D0
19866 DO 120 IXT2=1,20
19867 NMUL(IXT2)=MSTP(83)
19868 SIGM(IXT2)=0D0
19869 DO 110 ITRY=1,MSTP(83)
19870 RSCA=0.05D0*((21-IXT2)-PYR(0))
19871 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19872 XT2=MAX(0.01D0*VINT(149),XT2)
19873 VINT(25)=XT2
19874
19875C...Choose tau and y*. Calculate cos(theta-hat).
19876 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19877 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19878 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19879 ELSE
19880 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19881 ENDIF
19882 VINT(21)=TAU
19883 CALL PYKLIM(2)
19884 RYST=PYR(0)
19885 MYST=1
19886 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19887 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19888 CALL PYKMAP(2,MYST,PYR(0))
19889 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19890
19891C...Calculate differential cross-section.
19892 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19893 CALL PYSIGH(NCHN,SIGS)
19894 SIGM(IXT2)=SIGM(IXT2)+SIGS
19895 110 CONTINUE
19896 SIGSUM=SIGSUM+SIGM(IXT2)
19897 120 CONTINUE
19898 SIGSUM=SIGSUM/(20D0*MSTP(83))
19899
19900C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19901 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19902 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19903 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19904 PARP(82)=0.9D0*PARP(82)
19905 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19906 & VINT(2)
19907 GOTO 100
19908 ENDIF
19909 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19910 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19911
19912C...Start iteration to find k factor.
19913 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19914 P83A=(1D0-PARP(83))**2
19915 P83B=2D0*PARP(83)*(1D0-PARP(83))
19916 P83C=PARP(83)**2
19917 CQ2I=1D0/PARP(84)**2
19918 CQ2R=2D0/(1D0+PARP(84)**2)
19919 SO=0.5D0
19920 XI=0D0
19921 YI=0D0
19922 XF=0D0
19923 YF=0D0
19924 XK=0.5D0
19925 IIT=0
19926 130 IF(IIT.EQ.0) THEN
19927 XK=2D0*XK
19928 ELSEIF(IIT.EQ.1) THEN
19929 XK=0.5D0*XK
19930 ELSE
19931 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19932 ENDIF
19933
19934C...Evaluate overlap integrals. Find where to divide the b range.
19935 IF(MSTP(82).EQ.2) THEN
19936 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19937 SOP=SP/PARU(1)
19938 ELSE
19939 IF(MSTP(82).EQ.3) THEN
19940 DELTAB=0.02D0
19941 ELSEIF(MSTP(82).EQ.4) THEN
19942 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19943 ELSE
19944 POWIP=MAX(0.4D0,PARP(83))
19945 RPWIP=2D0/POWIP-1D0
19946 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19947 SO=0D0
19948 ENDIF
19949 SP=0D0
19950 SOP=0D0
19951 BSP=0D0
19952 SOHIGH=0D0
19953 IBDIV=0
19954 B=-0.5D0*DELTAB
19955 140 B=B+DELTAB
19956 IF(MSTP(82).EQ.3) THEN
19957 OV=EXP(-B**2)/PARU(2)
19958 ELSEIF(MSTP(82).EQ.4) THEN
19959 OV=(P83A*EXP(-MIN(50D0,B**2))+
19960 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19961 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19962 ELSE
19963 OV=EXP(-B**POWIP)/PARU(2)
19964 SO=SO+PARU(2)*B*DELTAB*OV
19965 ENDIF
19966 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19967 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19968 SP=SP+PARU(2)*B*DELTAB*PACC
19969 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19970 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19971 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19972 IBDIV=1
19973 BDIV=B+0.5D0*DELTAB
19974 ENDIF
19975 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19976 ENDIF
19977 YK=PARU(1)*XK*SO/SP
19978
19979C...Continue iteration until convergence.
19980 IF(YK.LT.YKE) THEN
19981 XI=XK
19982 YI=YK
19983 IF(IIT.EQ.1) IIT=2
19984 ELSE
19985 XF=XK
19986 YF=YK
19987 IF(IIT.EQ.0) IIT=1
19988 ENDIF
19989 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19990
19991C...Store some results for subsequent use.
19992 BAVG=BSP/SP
19993 VINT(145)=SIGSUM
19994 VINT(146)=SOP/SO
19995 VINT(147)=SOP/SP
19996 VNT145=VINT(145)
19997 VNT146=VINT(146)
19998 VNT147=VINT(147)
19999C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20000 PIK=(VNT146/VNT147)*YKE
20001
20002C...Find relative weight for low and high impact parameter..
20003 PLOWB=PARU(1)*BDIV**2
20004 IF(MSTP(82).EQ.3) THEN
20005 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20006 ELSEIF(MSTP(82).EQ.4) THEN
20007 S4A=P83A*EXP(-BDIV**2)
20008 S4B=P83B*EXP(-BDIV**2*CQ2R)
20009 S4C=P83C*EXP(-BDIV**2*CQ2I)
20010 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20011 ELSEIF(PARP(83).GE.1.999D0) THEN
20012 PHIGHB=PIK*SOHIGH
20013 B2RPDV=BDIV**POWIP
20014 ELSE
20015 PHIGHB=PIK*SOHIGH
20016 B2RPDV=BDIV**POWIP
20017 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20018 ENDIF
20019 PALLB=PLOWB+PHIGHB
20020
20021C...Initialize iteration in xT2 for hardest interaction.
20022 ELSEIF(MMUL.EQ.2) THEN
20023 VINT(145)=VNT145
20024 VINT(146)=VNT146
20025 VINT(147)=VNT147
20026 IF(MSTP(82).LE.0) THEN
20027 ELSEIF(MSTP(82).EQ.1) THEN
20028 XT2=1D0
20029 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20030 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20031 & VINT(317)/(VINT(318)*VINT(320))
20032 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20033 ELSEIF(MSTP(82).EQ.2) THEN
20034 XT2=1D0
20035 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20036 & VINT(149)*(1D0+VINT(149))
20037 ELSE
20038 XC2=4D0*CKIN(3)**2/VINT(2)
20039 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20040 ENDIF
20041
20042C...Select impact parameter for hardest interaction.
20043 IF(MSTP(82).LE.2) RETURN
20044 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20045C...Treatment in low b region.
20046 MINT(39)=1
20047 B=BDIV*SQRT(PYR(0))
20048 IF(MSTP(82).EQ.3) THEN
20049 OV=EXP(-B**2)/PARU(2)
20050 ELSEIF(MSTP(82).EQ.4) THEN
20051 OV=(P83A*EXP(-MIN(50D0,B**2))+
20052 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20053 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20054 ELSE
20055 OV=EXP(-B**POWIP)/PARU(2)
20056 ENDIF
20057 VINT(148)=OV/VNT147
20058 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20059 XT2=1D0
20060 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20061 & VINT(149)*(1D0+VINT(149))
20062 ELSE
20063C...Treatment in high b region.
20064 MINT(39)=2
20065 IF(MSTP(82).EQ.3) THEN
20066 B=SQRT(BDIV**2-LOG(PYR(0)))
20067 OV=EXP(-B**2)/PARU(2)
20068 ELSEIF(MSTP(82).EQ.4) THEN
20069 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20070 IF(S4RNDM.LT.S4A) THEN
20071 B=SQRT(BDIV**2-LOG(PYR(0)))
20072 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20073 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20074 ELSE
20075 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20076 ENDIF
20077 OV=(P83A*EXP(-MIN(50D0,B**2))+
20078 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20079 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20080 ELSEIF(PARP(83).GE.1.999D0) THEN
20081 144 B2RPW=B2RPDV-LOG(PYR(0))
20082 ACCIP=(B2RPW/B2RPDV)**RPWIP
20083 IF(ACCIP.LT.PYR(0)) GOTO 144
20084 OV=EXP(-B2RPW)/PARU(2)
20085 B=B2RPW**(1D0/POWIP)
20086 ELSE
20087 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20088 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20089 IF(ACCIP.LT.PYR(0)) GOTO 146
20090 OV=EXP(-B2RPW)/PARU(2)
20091 B=B2RPW**(1D0/POWIP)
20092 ENDIF
20093 VINT(148)=OV/VNT147
20094 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20095 ENDIF
20096 IF(PACC.LT.PYR(0)) GOTO 142
20097 VINT(139)=B/BAVG
20098
20099 ELSEIF(MMUL.EQ.3) THEN
20100C...Low-pT or multiple interactions (first semihard interaction):
20101C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20102C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20103 ISUB=MINT(1)
20104 VINT(145)=VNT145
20105 VINT(146)=VNT146
20106 VINT(147)=VNT147
20107 IF(MSTP(82).LE.0) THEN
20108 XT2=0D0
20109 ELSEIF(MSTP(82).EQ.1) THEN
20110 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20111C...Use with "Sudakov" for low b values when impact parameter dependence.
20112 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20113 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20114 & VINT(149)))).GT.PYR(0)) XT2=1D0
20115 IF(XT2.GE.1D0) THEN
20116 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20117 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20118 & VINT(149)
20119 ELSE
20120 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20121 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20122 & VINT(149)
20123 ENDIF
20124 XT2=MAX(0.01D0*VINT(149),XT2)
20125C...Use without "Sudakov" for high b values when impact parameter dep.
20126 ELSE
20127 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20128 & PYR(0)*(1D0-XC2))-VINT(149)
20129 XT2=MAX(0.01D0*VINT(149),XT2)
20130 ENDIF
20131 VINT(25)=XT2
20132
20133C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20134 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20135 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20136 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20137 ISUB=95
20138 MINT(1)=ISUB
20139 VINT(21)=1D-12*VINT(149)
20140 VINT(22)=0D0
20141 VINT(23)=0D0
20142 VINT(25)=1D-12*VINT(149)
20143
20144 ELSE
20145C...Multiple interactions (first semihard interaction).
20146C...Choose tau and y*. Calculate cos(theta-hat).
20147 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20148 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20149 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20150 ELSE
20151 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20152 ENDIF
20153 VINT(21)=TAU
20154 CALL PYKLIM(2)
20155 RYST=PYR(0)
20156 MYST=1
20157 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20158 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20159 CALL PYKMAP(2,MYST,PYR(0))
20160 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20161 ENDIF
20162 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20163
20164C...Store results of cross-section calculation.
20165 ELSEIF(MMUL.EQ.4) THEN
20166 ISUB=MINT(1)
20167 VINT(145)=VNT145
20168 VINT(146)=VNT146
20169 VINT(147)=VNT147
20170 XTS=VINT(25)
20171 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20172 IF(ISET(ISUB).EQ.2)
20173 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20174 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20175 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20176 & (XTS+VINT(149))))
20177 IRBIN=INT(1D0+20D0*RBIN)
20178 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20179 NMUL(IRBIN)=NMUL(IRBIN)+1
20180 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20181 ENDIF
20182
20183C...Choose impact parameter if not already done.
20184 ELSEIF(MMUL.EQ.5) THEN
20185 ISUB=MINT(1)
20186 VINT(145)=VNT145
20187 VINT(146)=VNT146
20188 VINT(147)=VNT147
20189 150 IF(MINT(39).GT.0) THEN
20190 ELSEIF(MSTP(82).EQ.3) THEN
20191 EXPB2=PYR(0)
20192 B2=-LOG(PYR(0))
20193 VINT(148)=EXPB2/(PARU(2)*VNT147)
20194 VINT(139)=SQRT(B2)/BAVG
20195 ELSEIF(MSTP(82).EQ.4) THEN
20196 RTYPE=PYR(0)
20197 IF(RTYPE.LT.P83A) THEN
20198 B2=-LOG(PYR(0))
20199 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20200 B2=-LOG(PYR(0))/CQ2R
20201 ELSE
20202 B2=-LOG(PYR(0))/CQ2I
20203 ENDIF
20204 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20205 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20206 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20207 VINT(139)=SQRT(B2)/BAVG
20208 ELSEIF(PARP(83).GE.1.999D0) THEN
20209 POWIP=MAX(2D0,PARP(83))
20210 RPWIP=2D0/POWIP-1D0
20211 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20212 160 IF(PYR(0).LT.PROB1) THEN
20213 B2RPW=PYR(0)**(0.5D0*POWIP)
20214 ACCIP=EXP(-B2RPW)
20215 ELSE
20216 B2RPW=1D0-LOG(PYR(0))
20217 ACCIP=B2RPW**RPWIP
20218 ENDIF
20219 IF(ACCIP.LT.PYR(0)) GOTO 160
20220 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20221 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20222 ELSE
20223 POWIP=MAX(0.4D0,PARP(83))
20224 RPWIP=2D0/POWIP-1D0
20225 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20226 170 IF(PYR(0).LT.PROB1) THEN
20227 B2RPW=2D0*RPWIP*PYR(0)
20228 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20229 ELSE
20230 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20231 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20232 ENDIF
20233 IF(ACCIP.LT .PYR(0)) GOTO 170
20234 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20235 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20236 ENDIF
20237
20238C...Multiple interactions (variable impact parameter) : reject with
20239C...probability exp(-overlap*cross-section above pT/normalization).
20240C...Does not apply to low-b region, where "Sudakov" already included.
20241 VINT(150)=1D0
20242 IF(MINT(39).NE.1) THEN
20243 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20244 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20245 DO 180 IBIN=IRBIN+1,20
20246 RNCOR=RNCOR+NMUL(IBIN)
20247 SIGCOR=SIGCOR+SIGM(IBIN)
20248 180 CONTINUE
20249 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20250 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20251 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20252 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20253 ENDIF
20254 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20255 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20256 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20257 IF(VINT(150).LT.PYR(0)) GOTO 150
20258 VINT(150)=1D0
20259 ENDIF
20260
20261C...Generate additional multiple semihard interactions.
20262 ELSEIF(MMUL.EQ.6) THEN
20263
20264C...Save data for hardest initeraction, to be restored.
20265 ISUBSV=MINT(1)
20266 VINT(145)=VNT145
20267 VINT(146)=VNT146
20268 VINT(147)=VNT147
20269 M13SV=MINT(13)
20270 M14SV=MINT(14)
20271 M15SV=MINT(15)
20272 M16SV=MINT(16)
20273 M21SV=MINT(21)
20274 M22SV=MINT(22)
20275 DO 190 J=11,80
20276 VINTSV(J)=VINT(J)
20277 190 CONTINUE
20278 V141SV=VINT(141)
20279 V142SV=VINT(142)
20280
20281C...Store data on hardest interaction.
20282 XMI(1,1)=VINT(141)
20283 XMI(2,1)=VINT(142)
20284 PT2MI(1)=VINT(54)
20285 IMISEP(0)=MINT(84)
20286 IMISEP(1)=N
20287
20288C...Change process to generate; sum of x values so far.
20289 ISUB=96
20290 MINT(1)=96
20291 VINT(143)=1D0-VINT(141)
20292 VINT(144)=1D0-VINT(142)
20293 VINT(151)=0D0
20294 VINT(152)=0D0
20295
20296C...Initialize factors for PDF reshaping.
20297 DO 230 JS=1,2
20298 KFBEAM=MINT(10+JS)
20299 KFABM=IABS(KFBEAM)
20300 KFSBM=ISIGN(1,KFBEAM)
20301
20302C...Zero flavour content of incoming beam particle.
20303 KFIVAL(JS,1)=0
20304 KFIVAL(JS,2)=0
20305 KFIVAL(JS,3)=0
20306C...Flavour content of baryon.
20307 IF(KFABM.GT.1000) THEN
20308 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20309 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20310 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20311C...Flavour content of pi+-, K+-.
20312 ELSEIF(KFABM.EQ.211) THEN
20313 KFIVAL(JS,1)=KFSBM*2
20314 KFIVAL(JS,2)=-KFSBM
20315 ELSEIF(KFABM.EQ.321) THEN
20316 KFIVAL(JS,1)=-KFSBM*3
20317 KFIVAL(JS,2)=KFSBM*2
20318C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20319 ENDIF
20320
20321C...Zero initial valence and companion content.
20322 DO 200 IFL=-6,6
20323 NVC(JS,IFL)=0
20324 200 CONTINUE
20325
20326C...Initiate listing of all incoming partons from two sides.
20327 NMI(JS)=0
20328 DO 210 I=MINT(84)+1,N
20329 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20330 IMI(JS,1,1)=I
20331 IMI(JS,1,2)=0
20332 ENDIF
20333 210 CONTINUE
20334
20335C...Decide whether quarks in hard scattering were valence or sea.
20336 IFL=K(IMI(JS,1,1),2)
20337 IF (IABS(IFL).GT.6) GOTO 230
20338
20339C...Get PDFs at X and Q2 of the parton shower initiator for the
20340C...hard scattering.
20341 X=VINT(140+JS)
20342 IF(MSTP(61).GE.1) THEN
20343 Q2=PARP(62)**2
20344 ELSE
20345 Q2=VINT(54)
20346 ENDIF
20347C...Note: XPSVC = x*pdf.
20348 MINT(30)=JS
20349 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20350 SEA=XPSVC(IFL,-1)
20351 VAL=XPSVC(IFL,0)
20352
20353C...Decide (Extra factor x cancels in the division).
20354 RVCS=PYR(0)*(SEA+VAL)
20355 IVNOW=1
20356 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20357C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20358 IVNOW=0
20359 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20360 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20361 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20362 IF(KFIVAL(JS,1).EQ.0) THEN
20363 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20364 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20365 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20366 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20367 ENDIF
20368 IF(IVNOW.EQ.0) GOTO 220
20369C...Mark valence.
20370 IMI(JS,1,2)=0
20371C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20372 IF(KFIVAL(JS,1).EQ.0) THEN
20373 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20374 KFIVAL(JS,1)=IFL
20375 KFIVAL(JS,2)=-IFL
20376 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20377 KFIVAL(JS,1)=IFL
20378 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20379 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20380 ENDIF
20381 ENDIF
20382
20383C...If sea, add opposite sign companion parton. Store X and I.
20384 ELSE
20385 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20386 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20387C...Set pointer to companion
20388 IMI(JS,1,2)=-NVC(JS,-IFL)
20389 ENDIF
20390 230 CONTINUE
20391
20392C...Update counter number of multiple interactions.
20393 NMI(1)=1
20394 NMI(2)=1
20395
20396C...Set up starting values for iteration in xT2.
20397 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
20398 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
20399 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
20400 & ISUBSV.NE.96)) THEN
20401 XT2=(1D0-VINT(141))*(1D0-VINT(142))
20402 ELSE
20403 XT2=VINT(25)
20404 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
20405 IF(ISET(ISUBSV).EQ.2)
20406 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20407 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
20408 ENDIF
20409 IF(MSTP(82).LE.1) THEN
20410 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20411 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20412 & VINT(317)/(VINT(318)*VINT(320))
20413 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20414 ELSE
20415 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20416 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20417 ENDIF
20418 VINT(63)=0D0
20419 VINT(64)=0D0
20420
20421C...Iterate downwards in xT2.
20422 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
20423 XT2=0D0
20424 GOTO 440
20425 ELSEIF(MSTP(82).LE.1) THEN
20426 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20427 IF(XT2.LT.VINT(149)) GOTO 440
20428 ELSE
20429 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
20430 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20431 & LOG(PYR(0)))-VINT(149)
20432 IF(XT2.LE.0D0) GOTO 440
20433 XT2=MAX(0.01D0*VINT(149),XT2)
20434 ENDIF
20435 VINT(25)=XT2
20436
20437C...Choose tau and y*. Calculate cos(theta-hat).
20438 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20439 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20440 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20441 ELSE
20442 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20443 ENDIF
20444 VINT(21)=TAU
20445C...New: require shat > 1.
20446 IF(TAU*VINT(2).LT.1D0) GOTO 240
20447 CALL PYKLIM(2)
20448 RYST=PYR(0)
20449 MYST=1
20450 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20451 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20452 CALL PYKMAP(2,MYST,PYR(0))
20453 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20454
20455C...Check that x not used up. Accept or reject kinematical variables.
20456 X1M=SQRT(TAU)*EXP(VINT(22))
20457 X2M=SQRT(TAU)*EXP(-VINT(22))
20458 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
20459 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20460 CALL PYSIGH(NCHN,SIGS)
20461 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20462 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
20463 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
20464
20465C...Reset K, P and V vectors.
20466 DO 260 I=N+1,N+4
20467 DO 250 J=1,5
20468 K(I,J)=0
20469 P(I,J)=0D0
20470 V(I,J)=0D0
20471 250 CONTINUE
20472 260 CONTINUE
20473 PT=0.5D0*VINT(1)*SQRT(XT2)
20474
20475C...Choose flavour of reacting partons (and subprocess).
20476 RSIGS=SIGS*PYR(0)
20477 DO 270 ICHN=1,NCHN
20478 KFL1=ISIG(ICHN,1)
20479 KFL2=ISIG(ICHN,2)
20480 ICONMI=ISIG(ICHN,3)
20481 RSIGS=RSIGS-SIGH(ICHN)
20482 IF(RSIGS.LE.0D0) GOTO 280
20483 270 CONTINUE
20484
20485C...Reassign to appropriate process codes.
20486 280 ISUBMI=ICONMI/10
20487 ICONMI=MOD(ICONMI,10)
20488
20489C...Choose new quark flavour for annihilation graphs
20490 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
20491 SH=TAU*VINT(2)
20492 CALL PYWIDT(21,SH,WDTP,WDTE)
20493 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
20494 DO 300 I=1,MDCY(21,3)
20495 KFLF=KFDP(I+MDCY(21,2)-1,1)
20496 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
20497 IF(RKFL.LE.0D0) GOTO 310
20498 300 CONTINUE
20499 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
20500 IF(KFLF.GE.4) GOTO 290
20501 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
20502 KFLF=4
20503 ICONMI=ICONMI-2
20504 ELSEIF(ISUBMI.EQ.53) THEN
20505 KFLF=5
20506 ICONMI=ICONMI-4
20507 ENDIF
20508 ENDIF
20509
20510C...Final state flavours and colour flow: default values
20511 JS=1
20512 KFL3=KFL1
20513 KFL4=KFL2
20514 KCC=20
20515 KCS=ISIGN(1,KFL1)
20516
20517 IF(ISUBMI.EQ.11) THEN
20518C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
20519 KCC=ICONMI
20520 IF(KFL1*KFL2.LT.0) KCC=KCC+2
20521
20522 ELSEIF(ISUBMI.EQ.12) THEN
20523C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
20524 KFL3=ISIGN(KFLF,KFL1)
20525 KFL4=-KFL3
20526 KCC=4
20527
20528 ELSEIF(ISUBMI.EQ.13) THEN
20529C...f + fbar -> g + g; th arbitrary
20530 KFL3=21
20531 KFL4=21
20532 KCC=ICONMI+4
20533
20534 ELSEIF(ISUBMI.EQ.28) THEN
20535C...f + g -> f + g; th = (p(f)-p(f))**2
20536 IF(KFL1.EQ.21) JS=2
20537 KCC=ICONMI+6
20538 IF(KFL1.EQ.21) KCC=KCC+2
20539 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
20540 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
20541
20542 ELSEIF(ISUBMI.EQ.53) THEN
20543C...g + g -> f + fbar; th arbitrary
20544 KCS=(-1)**INT(1.5D0+PYR(0))
20545 KFL3=ISIGN(KFLF,KCS)
20546 KFL4=-KFL3
20547 KCC=ICONMI+10
20548
20549 ELSEIF(ISUBMI.EQ.68) THEN
20550C...g + g -> g + g; th arbitrary
20551 KCC=ICONMI+12
20552 KCS=(-1)**INT(1.5D0+PYR(0))
20553 ENDIF
20554
20555C...Store flavours of scattering.
20556 MINT(13)=KFL1
20557 MINT(14)=KFL2
20558 MINT(15)=KFL1
20559 MINT(16)=KFL2
20560 MINT(21)=KFL3
20561 MINT(22)=KFL4
20562
20563C...Set flavours and mothers of scattering partons.
20564 K(N+1,1)=14
20565 K(N+2,1)=14
20566 K(N+3,1)=3
20567 K(N+4,1)=3
20568 K(N+1,2)=KFL1
20569 K(N+2,2)=KFL2
20570 K(N+3,2)=KFL3
20571 K(N+4,2)=KFL4
20572 K(N+1,3)=MINT(83)+1
20573 K(N+2,3)=MINT(83)+2
20574 K(N+3,3)=N+1
20575 K(N+4,3)=N+2
20576
20577C...Store colour connection indices.
20578 DO 320 J=1,2
20579 JC=J
20580 IF(KCS.EQ.-1) JC=3-J
20581 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
20582 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
20583 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
20584 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
20585 320 CONTINUE
20586
20587C...Store incoming and outgoing partons in their CM-frame.
20588 SHR=SQRT(TAU)*VINT(1)
20589 P(N+1,3)=0.5D0*SHR
20590 P(N+1,4)=0.5D0*SHR
20591 P(N+2,3)=-0.5D0*SHR
20592 P(N+2,4)=0.5D0*SHR
20593 P(N+3,5)=PYMASS(K(N+3,2))
20594 P(N+4,5)=PYMASS(K(N+4,2))
20595 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
20596 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
20597 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
20598 P(N+4,4)=SHR-P(N+3,4)
20599 P(N+4,3)=-P(N+3,3)
20600
20601C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
20602 PHI=PARU(2)*PYR(0)
20603 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
20604
20605C...Set up default values before showers.
20606 MINT(31)=MINT(31)+1
20607 IPU1=N+1
20608 IPU2=N+2
20609 IPU3=N+3
20610 IPU4=N+4
20611 VINT(141)=VINT(41)
20612 VINT(142)=VINT(42)
20613 N=N+4
20614
20615C...Showering of initial state partons (optional).
20616C...Note: no showering of final state partons here; it comes later.
20617 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20618 MINT(51)=0
20619 ALAMSV=PARJ(81)
20620 PARJ(81)=PARP(72)
20621 NSAV=N
20622 DO 340 I=1,4
20623 DO 330 J=1,5
20624 KSAV(I,J)=K(N-4+I,J)
20625 PSAV(I,J)=P(N-4+I,J)
20626 330 CONTINUE
20627 340 CONTINUE
20628 CALL PYSSPA(IPU1,IPU2)
20629 PARJ(81)=ALAMSV
20630C...If shower failed then restore to situation before shower.
20631 IF(MINT(51).GE.1) THEN
20632 N=NSAV
20633 DO 360 I=1,4
20634 DO 350 J=1,5
20635 K(N-4+I,J)=KSAV(I,J)
20636 P(N-4+I,J)=PSAV(I,J)
20637 350 CONTINUE
20638 360 CONTINUE
20639 IPU1=N-3
20640 IPU2=N-2
20641 VINT(141)=VINT(41)
20642 VINT(142)=VINT(42)
20643 ENDIF
20644 ENDIF
20645
20646C...Keep track of loose colour ends and information on scattering.
20647 370 IMI(1,MINT(31),1)=IPU1
20648 IMI(2,MINT(31),1)=IPU2
20649 IMI(1,MINT(31),2)=0
20650 IMI(2,MINT(31),2)=0
20651 XMI(1,MINT(31))=VINT(141)
20652 XMI(2,MINT(31))=VINT(142)
20653 PT2MI(MINT(31))=VINT(54)
20654 IMISEP(MINT(31))=N
20655
20656C...Decide whether quarks in last scattering were valence, companion or
20657C...sea.
20658 DO 430 JS=1,2
20659 KFBEAM=MINT(10+JS)
20660 KFSBM=ISIGN(1,MINT(10+JS))
20661 IFL=K(IMI(JS,MINT(31),1),2)
20662 IMI(JS,MINT(31),2)=0
20663 IF (IABS(IFL).GT.6) GOTO 430
20664
20665C...Get PDFs at X and Q2 of the parton shower initiator for the
20666C...last scattering. At this point VINT(143:144) do not yet
20667C...include the scattered x values VINT(141:142).
20668 X=VINT(140+JS)/VINT(142+JS)
20669 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20670 Q2=PARP(62)**2
20671 ELSE
20672 Q2=VINT(54)
20673 ENDIF
20674C...Note: XPSVC = x*pdf.
20675 MINT(30)=JS
20676 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20677 SEA=XPSVC(IFL,-1)
20678 VAL=XPSVC(IFL,0)
20679 CMP=0D0
20680 DO 380 IVC=1,NVC(JS,IFL)
20681 CMP=CMP+XPSVC(IFL,IVC)
20682 380 CONTINUE
20683
20684C...Decide (Extra factor x cancels in the dvision).
20685 RVCS=PYR(0)*(SEA+VAL+CMP)
20686 IVNOW=1
20687 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20688C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20689 IVNOW=0
20690 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20691 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20692 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20693 IF(KFIVAL(JS,1).EQ.0) THEN
20694 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20695 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20696 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20697 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20698 ELSE
20699 DO 400 I1=1,NMI(JS)
20700 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20701 & IVNOW=IVNOW-1
20702 400 CONTINUE
20703 ENDIF
20704 IF(IVNOW.EQ.0) GOTO 390
20705C...Mark valence.
20706 IMI(JS,MINT(31),2)=0
20707C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20708 IF(KFIVAL(JS,1).EQ.0) THEN
20709 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20710 KFIVAL(JS,1)=IFL
20711 KFIVAL(JS,2)=-IFL
20712 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20713 KFIVAL(JS,1)=IFL
20714 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20715 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20716 ENDIF
20717 ENDIF
20718
20719 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20720C...If sea, add opposite sign companion parton. Store X and I.
20721 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20722 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20723C...Set pointer to companion
20724 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20725 ELSE
20726C...If companion, decide which one.
20727 CMPSUM=VAL+SEA
20728 ISEL=0
20729 410 ISEL=ISEL+1
20730 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20731 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20732C...Find original sea (anti-)quark:
20733 IASSOC=0
20734 DO 420 I1=1,NMI(JS)
20735 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20736 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20737 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20738 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20739 ENDIF
20740 420 CONTINUE
20741C...Change X to what associated companion had, so that the correct
20742C...amount of momentum can be subtracted from the companion sum below.
20743 X=XASSOC(JS,IFL,ISEL)
20744C...Mark companion read.
20745 XASSOC(JS,IFL,ISEL)=0D0
20746 ENDIF
20747 430 CONTINUE
20748
20749C...Global statistics.
20750 MINT(351)=MINT(351)+1
20751 VINT(351)=VINT(351)+PT
20752 IF (MINT(351).EQ.1) VINT(356)=PT
20753
20754C...Update remaining energy and other counters.
20755 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20756 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20757 MINT(51)=1
20758 RETURN
20759 ENDIF
20760 NMI(1)=NMI(1)+1
20761 NMI(2)=NMI(2)+1
20762 VINT(151)=VINT(151)+VINT(41)
20763 VINT(152)=VINT(152)+VINT(42)
20764 VINT(143)=VINT(143)-VINT(141)
20765 VINT(144)=VINT(144)-VINT(142)
20766
20767C...Iterate, with more interactions allowed.
20768 IF(MINT(31).LT.240) GOTO 240
20769 440 CONTINUE
20770
20771C...Restore saved quantities for hardest interaction.
20772 MINT(1)=ISUBSV
20773 MINT(13)=M13SV
20774 MINT(14)=M14SV
20775 MINT(15)=M15SV
20776 MINT(16)=M16SV
20777 MINT(21)=M21SV
20778 MINT(22)=M22SV
20779 DO 450 J=11,80
20780 VINT(J)=VINTSV(J)
20781 450 CONTINUE
20782 VINT(141)=V141SV
20783 VINT(142)=V142SV
20784
20785 ENDIF
20786
20787C...Format statements for printout.
20788 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20789 &'actions for MSTP(82) =',I2,' ******')
20790 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20791 &D9.2,' mb: rejected')
20792 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20793 &D9.2,' mb: accepted')
20794
20795 RETURN
20796 END
20797
20798C*********************************************************************
20799
20800C...PYMIHK
20801C...Finds left-behind remnant flavour content and hooks up
20802C...the colour flow between the hard scattering and remnants
20803
20804 SUBROUTINE PYMIHK
20805
20806C...Double precision and integer declarations.
20807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20808 IMPLICIT INTEGER(I-N)
20809 INTEGER PYK,PYCHGE,PYCOMP
20810C...The event record
20811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20812C...Parameters
20813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20814 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20815 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20816 COMMON/PYINT1/MINT(400),VINT(400)
20817C...The common block of dangling ends
20818 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20819 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20820 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20821 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20822C...Local variables
20823 PARAMETER (NERSIZ=4000)
20824 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20825 & ,MACCPT
20826 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20827 SAVE /PYCBLS/,/PYCTAG/
20828 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20829 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20830 DATA NERRPR/0/
20831 SAVE NERRPR
20832 FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1)
20833
20834C...Set up error checkers
20835 IBOOST=0
20836
20837C...Initialize colour arrays: MCO (Original) and MCT (New)
20838 DO 110 I=MINT(84)+1,NERSIZ
20839 DO 100 JC=1,2
20840 MCT(I,JC)=0
20841 MCO(I,JC)=0
20842 100 CONTINUE
20843C...Also zero colour tracing information, if existed.
20844 IF (I.LE.N) THEN
20845 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20846 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20847 ENDIF
20848 110 CONTINUE
20849
20850C...Initialize colour tag collapse arrays:
20851C...JCCO (Original) and JCCN (New).
20852 DO 130 MG=MINT(84)+1,NERSIZ
20853 DO 120 JC=1,2
20854 JCCO(MG,JC)=0
20855 JCCN(MG,JC)=0
20856 120 CONTINUE
20857 130 CONTINUE
20858
20859C...Zero gluon insertion array
20860 DO 150 IM=1,1000
20861 DO 140 J=1,3
20862 INSR(IM,J)=0
20863 140 CONTINUE
20864 150 CONTINUE
20865
20866C...Compute hard scattering system rapidities
20867 IF (MSTP(89).EQ.1) THEN
20868 DO 160 IM=1,240
20869 IF (IM.LE.MINT(31)) THEN
20870 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20871 ELSE
20872C...Set (unsigned) rapidity = 100 for beam remnant systems.
20873 YMI(IM)=100D0
20874 ENDIF
20875 160 CONTINUE
20876 ENDIF
20877
20878C...Treat each side separately
20879 DO 290 JS=1,2
20880
20881C...Initialize side.
20882 NG(JS)=0
20883 JV=0
20884 KFS=ISIGN(1,MINT(10+JS))
20885
20886C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20887 IF(KFIVAL(JS,1).EQ.0) THEN
20888 IF(MINT(10+JS).EQ.111) THEN
20889 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20890 KFIVAL(JS,2)=-KFIVAL(JS,1)
20891 ELSEIF(MINT(10+JS).EQ.22) THEN
20892 PYRKF=PYR(0)
20893 KFIVAL(JS,1)=1
20894 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20895 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20896 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20897 KFIVAL(JS,2)=-KFIVAL(JS,1)
20898 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20899 IF(PYR(0).GT.0.5D0) THEN
20900 KFIVAL(JS,1)=1
20901 KFIVAL(JS,2)=-3
20902 ELSE
20903 KFIVAL(JS,1)=3
20904 KFIVAL(JS,2)=-1
20905 ENDIF
20906 ENDIF
20907 ENDIF
20908
20909C...Initialize beam remnant sea and valence content flavour by flavour.
20910 NVSUM(JS)=0
20911 NBRTOT(JS)=0
20912 DO 210 JFA=1,6
20913C...Count up original number of JFA valence quarks and antiquarks.
20914 NVALQ=0
20915 NVALQB=0
20916 NSEA=0
20917 DO 170 J=1,3
20918 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20919 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20920 170 CONTINUE
20921 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20922C...Subtract kicked out valence and determine sea from flavour cons.
20923 DO 180 IM=1,NMI(JS)
20924 IFL = K(IMI(JS,IM,1),2)
20925 IFA = IABS(IFL)
20926 IFS = ISIGN(1,IFL)
20927 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20928C...Subtract K.O. valence quark from remainder.
20929 NVALQ=NVALQ-1
20930 JV=NVSUM(JS)-NVALQ-NVALQB
20931 IV(JS,JV)=IMI(JS,IM,1)
20932 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20933C...Subtract K.O. valence antiquark from remainder.
20934 NVALQB=NVALQB-1
20935 JV=NVSUM(JS)-NVALQ-NVALQB
20936 IV(JS,JV)=IMI(JS,IM,1)
20937 ELSEIF (IFA.EQ.JFA) THEN
20938C...Outside sea without companion: add opposite sea flavour inside.
20939 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20940 ENDIF
20941 180 CONTINUE
20942C...Check if space left in PYJETS for additional BR flavours
20943 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20944 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20945 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20946 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20947 MINT(51)=1
20948 RETURN
20949 ENDIF
20950C...Add required val+sea content to beam remnant.
20951 IF (NFLSUM.GT.0) THEN
20952 DO 200 IA=1,NFLSUM
20953C...Insert beam remnant quark as p.t. symbolic parton in ER.
20954 N=N+1
20955 DO 190 IX=1,5
20956 K(N,IX)=0
20957 P(N,IX)=0D0
20958 V(N,IX)=0D0
20959 190 CONTINUE
20960 K(N,1)=3
20961 K(N,2)=ISIGN(JFA,NSEA)
20962 IF (IA.LE.NVALQ) K(N,2)=JFA
20963 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20964 K(N,3)=MINT(83)+JS
20965C...Also update NMI, IMI, and IV arrays.
20966 NMI(JS)=NMI(JS)+1
20967 IMI(JS,NMI(JS),1)=N
20968 IMI(JS,NMI(JS),2)=-1
20969 IF (IA.LE.NVALQ+NVALQB) THEN
20970 IMI(JS,NMI(JS),2)=0
20971 JV=JV+1
20972 IV(JS,JV)=IMI(JS,NMI(JS),1)
20973 ENDIF
20974 200 CONTINUE
20975 ENDIF
20976 210 CONTINUE
20977
20978 IM=0
20979 220 IM=IM+1
20980 IF (IM.LE.NMI(JS)) THEN
20981 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20982 NG(JS)=NG(JS)+1
20983C...Add fictitious parent gluons for companion pairs.
20984 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20985C...Randomly assign companions to sea quarks which have none.
20986 IF (IMI(JS,IM,2).LT.0) THEN
20987 IMC=PYR(0)*NMI(JS)
20988 230 IMC=MOD(IMC,NMI(JS))+1
20989 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20990 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20991 IMI(JS, IM,2) = IMI(JS,IMC,1)
20992 IMI(JS,IMC,2) = IMI(JS, IM,1)
20993 ENDIF
20994C...Add fictitious parent gluon
20995 N=N+1
20996 DO 240 IX=1,5
20997 K(N,IX)=0
20998 P(N,IX)=0D0
20999 V(N,IX)=0D0
21000 240 CONTINUE
21001 K(N,1)=14
21002 K(N,2)=21
21003 K(N,3)=MINT(83)+JS
21004C...Set gluon (anti-)colour daughter pointers
21005 K(N,4)=IMI(JS, IM,1)
21006 K(N,5)=IMI(JS, IM,2)
21007C...Set quark (anti-)colour parent pointers
21008 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21009 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21010C...Add gluon to IMI
21011 NMI(JS)=NMI(JS)+1
21012 IMI(JS,NMI(JS),1)=N
21013 IMI(JS,NMI(JS),2)=0
21014 ENDIF
21015 GOTO 220
21016 ENDIF
21017
21018C...If incoming (anti-)baryon, insert inside (anti-)junction.
21019C...Set up initial v-v-j-v configuration. Otherwise set up
21020C...mesonic v-vbar configuration
21021 IF (IABS(MINT(10+JS)).GT.1000) THEN
21022C...Determine junction type (1: B=1 2: B=-1)
21023 ITJUNC(JS) = (3-KFS)/2
21024C...Insert junction.
21025 N=N+1
21026 DO 250 IX=1,5
21027 K(N,IX)=0
21028 P(N,IX)=0D0
21029 V(N,IX)=0D0
21030 250 CONTINUE
21031C...Set special junction codes:
21032 K(N,1)=42
21033 K(N,2)=88
21034C...Set parent to side.
21035 K(N,3)=MINT(83)+JS
21036 K(N,4)=ITJUNC(JS)*MSTU(5)
21037 K(N,5)=0
21038C...Connect valence quarks to junction.
21039 MOUT(JS)=0
21040 MANTI=ITJUNC(JS)-1
21041C...Set (anti)colour mother = junction.
21042 DO 260 JV=1,3
21043 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21044 & +MSTU(5)*N
21045C...Keep track of partons adjacent to junction:
21046 JST(JS,JV)=IV(JS,JV)
21047 260 CONTINUE
21048 ELSE
21049C...Mesons: set up initial q-qbar topology
21050 ITJUNC(JS)=0
21051 IF (K(IV(JS,1),2).GT.0) THEN
21052 IQ=IV(JS,1)
21053 IQBAR=IV(JS,2)
21054 ELSE
21055 IQ=IV(JS,2)
21056 IQBAR=IV(JS,1)
21057 ENDIF
21058 IV(JS,3)=0
21059 JST(JS,1)=IQ
21060 JST(JS,2)=IQBAR
21061 JST(JS,3)=0
21062 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21063 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21064C...Special for mesons. Insert gluon if BR empty.
21065 IF (NBRTOT(JS).EQ.0) THEN
21066 N=N+1
21067 DO 270 IX=1,5
21068 K(N,IX)=0
21069 P(N,IX)=0D0
21070 V(N,IX)=0D0
21071 270 CONTINUE
21072 K(N,1)=3
21073 K(N,2)=21
21074 K(N,3)=MINT(83)+JS
21075 K(N,4)=0
21076 K(N,5)=0
21077 NBRTOT(JS)=1
21078 NG(JS)=NG(JS)+1
21079C...Add gluon to IMI
21080 NMI(JS)=NMI(JS)+1
21081 IMI(JS,NMI(JS),1)=N
21082 IMI(JS,NMI(JS),2)=0
21083 ENDIF
21084 MOUT(JS)=0
21085 ENDIF
21086
21087C...Count up number of valence quarks outside BR.
21088 DO 280 JV=1,3
21089 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21090 & MOUT(JS)=MOUT(JS)+1
21091 280 CONTINUE
21092
21093 290 CONTINUE
21094
21095C...Now both sides have been prepared in an initial vvjv (baryonic) or
21096C...v(g)vbar (mesonic) configuration.
21097
21098C...Create colour line tags starting from initiators.
21099 NCT=0
21100 DO 320 IM=1,MINT(31)
21101C...Consider each side in turn.
21102 DO 310 JS=1,2
21103 I1=IMI(JS,IM,1)
21104 I2=IMI(3-JS,IM,1)
21105 DO 300 JCS=4,5
21106 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21107 & GOTO 300
21108 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21109
21110 KCS=JCS
21111 CALL PYCTTR(I1,KCS,I2)
21112 IF(MINT(51).NE.0) RETURN
21113
21114 300 CONTINUE
21115 310 CONTINUE
21116 320 CONTINUE
21117
21118 DO 340 JS=1,2
21119C...Create colour tags for beam remnant partons.
21120 DO 330 IM=MINT(31)+1,NMI(JS)
21121 IP=IMI(JS,IM,1)
21122 IF (K(IP,2).NE.21) THEN
21123 JC=(3-ISIGN(1,K(IP,2)))/2
21124 IF (MCT(IP,JC).EQ.0) THEN
21125 NCT=NCT+1
21126 MCT(IP,JC)=NCT
21127 ENDIF
21128 ELSE
21129C...Gluons
21130 ICD=K(IP,4)
21131 IAD=K(IP,5)
21132 IF (ICD.NE.0) THEN
21133C...Fictituous gluons just inherit from their quark daughters.
21134 ICC=MCT(ICD,1)
21135 IAC=MCT(IAD,2)
21136 ELSE
21137C...Real beam remnant gluons get their own colours
21138 ICC=NCT+1
21139 IAC=NCT+2
21140 NCT=NCT+2
21141 ENDIF
21142 MCT(IP,1)=ICC
21143 MCT(IP,2)=IAC
21144 ENDIF
21145 330 CONTINUE
21146 340 CONTINUE
21147
21148C...Create colour tags for colour lines which are detached from the
21149C...initial state.
21150
21151 DO 360 MQGST=1,2
21152 DO 350 I=MINT(84)+1,N
21153
21154C...Look for coloured string endpoint, or (later) leftover gluon.
21155 IF (K(I,1).NE.3) GOTO 350
21156 KC=PYCOMP(K(I,2))
21157 IF(KC.EQ.0) GOTO 350
21158 KQ=KCHG(KC,2)
21159 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21160
21161C...Pick up loose string end with no previous tag.
21162 KCS=4
21163 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21164 IF(MCT(I,KCS-3).NE.0) GOTO 350
21165
21166 CALL PYCTTR(I,KCS,I)
21167 IF(MINT(51).NE.0) RETURN
21168
21169 350 CONTINUE
21170 360 CONTINUE
21171
21172C...Store original colour tags
21173 DO 370 I=MINT(84)+1,N
21174 MCO(I,1)=MCT(I,1)
21175 MCO(I,2)=MCT(I,2)
21176 370 CONTINUE
21177
21178C...Iteratively add gluons to already existing string pieces, enforcing
21179C...various possible orderings, and rejecting insertions that would give
21180C...rise to singlet gluons.
21181C...<kappa tau> normalization.
21182 RM0=1.5D0
21183 MRETRY=0
21184 PARP80=PARP(80)
21185
21186C...Set up simplified kinematics.
21187C...Boost hard interaction systems.
21188 IBOOST=IBOOST+1
21189 DO 380 IM=1,MINT(31)
21190 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21191 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21192 380 CONTINUE
21193C...Assign preliminary beam remnant momenta.
21194 DO 390 I=MINT(53)+1,N
21195 JS=K(I,3)
21196 P(I,1)=0D0
21197 P(I,2)=0D0
21198 IF (K(I,2).NE.88) THEN
21199 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21200 P(I,3)=P(I,4)
21201 IF (JS.EQ.2) P(I,3)=-P(I,3)
21202 ELSE
21203C...Junctions are wildcards for the present.
21204 P(I,4)=0D0
21205 P(I,3)=0D0
21206 ENDIF
21207 390 CONTINUE
21208
21209C...Reset colour processing information.
21210 400 DO 410 I=MINT(84)+1,N
21211 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21212 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21213 410 CONTINUE
21214
21215 NCC=0
21216 DO 430 JS=1,2
21217C...If meson, without gluon in BR, collapse q-qbar colour tags:
21218 IF (ITJUNC(JS).EQ.0) THEN
21219 JC1=MCT(JST(JS,1),1)
21220 JC2=MCT(JST(JS,2),2)
21221 NCC=NCC+1
21222 JCCO(NCC,1)=MAX(JC1,JC2)
21223 JCCO(NCC,2)=MIN(JC1,JC2)
21224C...Collapse colour tags in event record
21225 DO 420 I=MINT(84)+1,N
21226 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21227 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21228 420 CONTINUE
21229 ENDIF
21230 430 CONTINUE
21231
21232 440 JS=1
21233 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21234 IF (NG(JS).GT.0) THEN
21235 NOPT=0
21236 RLOPT=1D9
21237C...Start at random gluon (optimizes speed for random attachments)
21238 NMGL=0
21239 IMGL=PYR(0)*NMI(JS)+1
21240 450 IMGL=MOD(IMGL,NMI(JS))+1
21241 NMGL=NMGL+1
21242C...Only loop through NMI once (with upper limit to save time)
21243 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21244 IGL = IMI(JS,IMGL,1)
21245C...If not gluon or if already connected, try next.
21246 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21247 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21248C...Now loop through all possible insertions of this gluon.
21249 NMP1=0
21250 IMP1=PYR(0)*NMI(JS)+1
21251 460 IMP1=MOD(IMP1,NMI(JS))+1
21252 NMP1=NMP1+1
21253 IF (IMP1.EQ.IMGL) GOTO 460
21254C...Only loop through NMI once (with upper limit to save time).
21255 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21256 IP1 = IMI(JS,IMP1,1)
21257C...Try both colour mother and colour anti-mother.
21258C...Randomly select which one to try first.
21259 NANTI=0
21260 MANTI=PYR(0)*2
21261 470 MANTI=MOD(MANTI+1,2)
21262 NANTI=NANTI+1
21263 IF (NANTI.LE.2) THEN
21264 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21265C...Reject if no appropriate mother (or if mother is fictitious
21266C...parent gluon.)
21267 IF (IP2.LE.0) GOTO 470
21268 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21269C...Also reject if this link has already been tried.
21270 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21271 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21272C...Set flag to indicate that this link has now been tried for this
21273C...gluon. IP2 may be junction, which has several mothers.
21274 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21275 IF (K(IP2,2).NE.88) THEN
21276 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21277 ENDIF
21278
21279C...JCG1: Original colour tag of gluon on IP1 side
21280C...JCG2: Original colour tag of gluon on IP2 side
21281C...JCP1: Original colour tag of IP1 on gluon side
21282C...JCP2: Original colour tag of IP2 on gluon side.
21283 JCG1=MCO(IGL,2-MANTI)
21284 JCG2=MCO(IGL,1+MANTI)
21285 JCP1=MCO(IP1,1+MANTI)
21286 JCP2=MCO(IP2,2-MANTI)
21287
21288 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21289C...Reject gluon attachments that give rise to singlet gluons.
21290 IF (MACCPT.EQ.0) GOTO 470
21291
21292C...Update colours
21293 JCG1=MCT(IGL,2-MANTI)
21294 JCG2=MCT(IGL,1+MANTI)
21295 JCP1=MCT(IP1,1+MANTI)
21296 JCP2=MCT(IP2,2-MANTI)
21297
21298C...Select whether to accept this insertion
21299 IF (MSTP(89).EQ.0) THEN
21300C...Random insertions: no measure.
21301 RL=1D0
21302C...For random ordering, we want to suppress beam remnant breakups
21303C...already at this point.
21304 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21305 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21306 NMP1=0
21307 NMGL=0
21308 GOTO 470
21309 ENDIF
21310 ELSEIF (MSTP(89).EQ.1) THEN
21311C...Rapidity ordering:
21312C...YGL = Rapidity of gluon.
21313 YGL=YMI(IMGL)
21314C...If fictitious gluon
21315 IF (YGL.EQ.100D0) THEN
21316 YGL=(3-2*JS)*100D0
21317 IDA1=MOD(K(IGL,4),MSTU(5))
21318 IDA2=MOD(K(IGL,5),MSTU(5))
21319 DO 480 IMT=1,NMI(JS)
21320C...Select (arbitrarily) the most central daughter.
21321 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21322 & THEN
21323 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21324 ENDIF
21325 480 CONTINUE
21326 ENDIF
21327C...YP1 = Rapidity IP1
21328 YP1=YMI(IMP1)
21329C...If fictitious gluon
21330 IF (YP1.EQ.100D0) THEN
21331 YP1=(3-2*JS)*YP1
21332 IDA1=MOD(K(IP1,4),MSTU(5))
21333 IDA2=MOD(K(IP1,5),MSTU(5))
21334 DO 490 IMT=1,NMI(JS)
21335C...Select (arbitrarily) the most central daughter.
21336 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21337 & THEN
21338 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21339 ENDIF
21340 490 CONTINUE
21341 ENDIF
21342C...YP2 = Rapidity of mother system
21343 IF (K(IP2,2).NE.88) THEN
21344 DO 500 IMT=1,NMI(JS)
21345 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21346 500 CONTINUE
21347C...If fictitious gluon
21348 IF (YP2.EQ.100D0) THEN
21349 YP2=(3-2*JS)*YP2
21350 IDA1=MOD(K(IP2,4),MSTU(5))
21351 IDA2=MOD(K(IP2,5),MSTU(5))
21352 DO 510 IMT=1,NMI(JS)
21353C...Select (arbitrarily) the most central daughter.
21354 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21355 & ) THEN
21356 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21357 ENDIF
21358 510 CONTINUE
21359 ENDIF
21360C...Assign (arbitrarily) 100D0 to junction also
21361 ELSE
21362 YP2=(3-2*JS)*100D0
21363 ENDIF
21364 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21365 ELSEIF (MSTP(89).EQ.2) THEN
21366C...Lambda ordering:
21367C...Compute lambda measure for this insertion.
21368 RL=1D0
21369 DO 520 IST=1,6
21370 ISTR(IST)=0
21371 520 CONTINUE
21372C...If IP2 is junction, not caught below.
21373 IF (JCP2.EQ.0) THEN
21374 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
21375C...Anti-junction is colour endpoint et vv., always on JCG2.
21376 ISTR(5-ITJU)=IP2
21377 ENDIF
21378 DO 530 I=MINT(84)+1,N
21379 IF (K(I,1).LT.10) THEN
21380C...The new string pieces
21381 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
21382 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
21383 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
21384 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
21385 ENDIF
21386 530 CONTINUE
21387C...Also identify junctions as string endpoints.
21388 DO 540 I=MINT(84)+1,N
21389 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
21390 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
21391C...Find partons adjacent to junctions.
21392 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
21393 & .EQ.0) ISTR(2) = ICMO
21394 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
21395 & .EQ.0) ISTR(1) = IAMO
21396 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
21397 & .EQ.0) ISTR(4) = ICMO
21398 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
21399 & .EQ.0) ISTR(3) = IAMO
21400 540 CONTINUE
21401C...The old string piece
21402 ISTR(5)=ISTR(1+2*MANTI)
21403 ISTR(6)=ISTR(4-2*MANTI)
21404 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
21405 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
21406 RL=LOG(RL)
21407 ENDIF
21408C...Allow some breadth to speed things up.
21409 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
21410 NOPT=NOPT+1
21411 ELSEIF (RL.GT.RLOPT) THEN
21412 GOTO 470
21413 ELSE
21414 NOPT=1
21415 RLOPT=RL
21416 ENDIF
21417C...INSR(NOPT,1)=Gluon colour mother
21418C...INSR(NOPT,2)=Gluon
21419C...INSR(NOPT,3)=Gluon anticolour mother
21420 IF (NOPT.GT.1000) GOTO 470
21421 INSR(NOPT,1+2*MANTI)=IP2
21422 INSR(NOPT,2)=IGL
21423 INSR(NOPT,3-2*MANTI)=IP1
21424 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
21425 ENDIF
21426 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
21427 ENDIF
21428C...Reset link test information.
21429 DO 550 I=MINT(84)+1,N
21430 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21431 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21432 550 CONTINUE
21433 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
21434 ENDIF
21435C...Now we have a list of best gluon insertions, none of which cause
21436C...singlets to arise. If list is empty, try again a few times. Note:
21437C...this should never happen if we have a meson with a gluon inserted
21438C...in the beam remnant, since that breaks up the colour line.
21439 IF (NOPT.EQ.0) THEN
21440C...Abandon BR-g-BR suppression for retries. This is not serious, it
21441C...just means we happened to start with trying a bad sequence.
21442 PARP80=1D0
21443 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
21444 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
21445 MRETRY=MRETRY+1
21446 DO 590 JS=1,2
21447 IF (ITJUNC(JS).NE.0) THEN
21448 JST(JS,1)=IV(JS,1)
21449 JST(JS,2)=IV(JS,2)
21450 JST(JS,3)=IV(JS,3)
21451C...Reset valence quark parent pointers
21452 DO 560 I=MINT(53)+1,N
21453 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
21454 560 CONTINUE
21455 MANTI=ITJUNC(JS)-1
21456C...Set (anti)colour mother = junction.
21457 DO 570 JV=1,3
21458 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21459 & +MSTU(5)*IJU
21460 570 CONTINUE
21461 ELSE
21462C...Same for mesons. JST unchanged, so needn't be restored.
21463 IQ=JST(JS,1)
21464 IQBAR=JST(JS,2)
21465 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21466 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21467 ENDIF
21468C...Also reset gluon parent pointers.
21469 NG(JS)=0
21470 DO 580 IM=1,NMI(JS)
21471 I=IMI(JS,IM,1)
21472 IF (K(I,2).EQ.21) THEN
21473 K(I,4)=MOD(K(I,4),MSTU(5))
21474 K(I,5)=MOD(K(I,5),MSTU(5))
21475 NG(JS)=NG(JS)+1
21476 ENDIF
21477 580 CONTINUE
21478 590 CONTINUE
21479C...Reset colour tags
21480 DO 600 I=MINT(84)+1,N
21481 MCT(I,1)=MCO(I,1)
21482 MCT(I,2)=MCO(I,2)
21483 600 CONTINUE
21484 GOTO 400
21485 ELSE
21486 IF(NERRPR.LT.5) THEN
21487 NERRPR=NERRPR+1
21488 CALL PYLIST(4)
21489 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
21490 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
21491 ENDIF
21492C...Kill event and start another.
21493 MINT(51)=1
21494 RETURN
21495 ENDIF
21496 ELSE
21497C...Select between insertions, suppressing insertions wholly in the BR.
21498 IIN=PYR(0)*NOPT+1
21499 610 IIN=MOD(IIN,NOPT)+1
21500 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
21501 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
21502 ENDIF
21503
21504C...Now we know which gluon to insert where. Colour tags in JCCO and
21505C...colour connection information should be updated, NG(JS) should be
21506C...counted down, and a new loop performed if there are still gluons
21507C...left on any side.
21508 ICM=INSR(IIN,1)
21509 IACM=INSR(IIN,3)
21510 IGL=INSR(IIN,2)
21511C...JCG : Original gluon colour tag
21512C...JCAG: Original gluon anticolour tag.
21513C...JCM : Original anticolour tag of gluon colour mother
21514C...JACM: Original colour tag of gluon anticolour mother
21515 JCG=MCO(IGL,1)
21516 JCM=MCO(ICM,2)
21517 JACG=MCO(IGL,2)
21518 JACM=MCO(IACM,1)
21519
21520 CALL PYMIHG(JACM,JACG,JCM,JCG)
21521 IF (MACCPT.EQ.0) THEN
21522 IF(NERRPR.LT.5) THEN
21523 NERRPR=NERRPR+1
21524 CALL PYLIST(4)
21525 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
21526 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
21527 ENDIF
21528C...Kill event and start another.
21529 MINT(51)=1
21530 RETURN
21531 ELSE
21532C...If everything went fine, store new JCCN in JCCO.
21533 NCC=NCC+1
21534 DO 620 ICC=1,NCC
21535 JCCO(ICC,1)=JCCN(ICC,1)
21536 JCCO(ICC,2)=JCCN(ICC,2)
21537 620 CONTINUE
21538 ENDIF
21539
21540C...One gluon attached is counted as equivalent to one end outside.
21541 MOUT(JS)=1
21542C...Set IGL colour mother = ICM.
21543 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
21544C...Set ICM anticolour mother = IGL colour.
21545 IF (K(ICM,2).NE.88) THEN
21546 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
21547 ELSE
21548C...If ICM is junction, just update JST array for now.
21549 DO 630 MSJ=1,3
21550 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
21551 630 CONTINUE
21552 ENDIF
21553C...Set IGL anticolour mother = IACM.
21554 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
21555C...Set IACM anticolour mother = IGL anticolour.
21556 IF (K(IACM,2).NE.88) THEN
21557 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
21558 ELSE
21559C...If IACM is junction, just update JST array for now.
21560 DO 640 MSJ=1,3
21561 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
21562 640 CONTINUE
21563 ENDIF
21564C...Count down # unconnected gluons.
21565 NG(JS)=NG(JS)-1
21566 ENDIF
21567 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
21568
21569 DO 840 JS=1,2
21570C...Collapse fictitious gluons.
21571 DO 670 IGL=MINT(53)+1,N
21572 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
21573 & K(IGL,1).EQ.14) THEN
21574 ICM=K(IGL,4)/MSTU(5)
21575 IAM=K(IGL,5)/MSTU(5)
21576 ICD=MOD(K(IGL,4),MSTU(5))
21577 IAD=MOD(K(IGL,5),MSTU(5))
21578C...Set gluon daughters pointing to gluon mothers
21579 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
21580 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
21581C...Set gluon mothers pointing to gluon daughters.
21582 IF (K(ICM,2).NE.88) THEN
21583 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
21584 ELSE
21585C...Special case: mother=junction. Just update JST array for now.
21586 DO 650 MSJ=1,3
21587 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
21588 650 CONTINUE
21589 ENDIF
21590 IF (K(IAM,2).NE.88) THEN
21591 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
21592 ELSE
21593 DO 660 MSJ=1,3
21594 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
21595 660 CONTINUE
21596 ENDIF
21597 ENDIF
21598 670 CONTINUE
21599
21600C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
21601 IM=NMI(JS)+1
21602 680 IM=IM-1
21603 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
21604 IF (IM.GT.MINT(31)) THEN
21605 NMI(JS)=NMI(JS)-1
21606 DO 690 IMR=IM,NMI(JS)
21607 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21608 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21609 690 CONTINUE
21610 GOTO 680
21611 ENDIF
21612
21613C...Finally, connect junction.
21614 IF (ITJUNC(JS).NE.0) THEN
21615 DO 700 I=MINT(53)+1,N
21616 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21617 700 CONTINUE
21618C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21619 NBRJQ =0
21620 NBRVQ =0
21621 DO 720 MSJ=1,3
21622 IDQ(MSJ)=0
21623C...Find jq with no glue inbetween inside beam remnant.
21624 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21625 & THEN
21626 NBRJQ=NBRJQ+1
21627C...Set IDQ = -I if q non-valence and = +I if q valence.
21628 IDQ(NBRJQ)=-JST(JS,MSJ)
21629 DO 710 JV=1,3
21630 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21631 IDQ(NBRJQ)=JST(JS,MSJ)
21632 NBRVQ=NBRVQ+1
21633 ENDIF
21634 710 CONTINUE
21635 ENDIF
21636 I12=MOD(MSJ+1,2)
21637 I45=5
21638 IF (MSJ.EQ.3) I45=4
21639 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21640 720 CONTINUE
21641
21642C...Check if diquark can be formed.
21643 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21644 & .GE.1)) THEN
21645C...If there is less than 2 valence quarks connected to junction
21646C...and MSTP(88)>1, use random non-valence quarks to fill up.
21647 IF (NBRVQ.LE.1) THEN
21648 NDIQ=NBRVQ
21649 730 JFLIP=NBRJQ*PYR(0)+1
21650 IF (IDQ(JFLIP).LT.0) THEN
21651 IDQ(JFLIP)=-IDQ(JFLIP)
21652 NDIQ=NDIQ+1
21653 ENDIF
21654 IF (NDIQ.LE.1) GOTO 730
21655 ENDIF
21656C...Place selected quarks first in IDQ, ordered in flavour.
21657 DO 740 JDQ=1,3
21658 IF (IDQ(JDQ).LE.0) THEN
21659 ITEMP1 = IDQ(JDQ)
21660 IDQ(JDQ)= IDQ(3)
21661 IDQ(3) = -ITEMP1
21662 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21663 ITEMP1 = IDQ(1)
21664 IDQ(1) = IDQ(2)
21665 IDQ(2) = ITEMP1
21666 ENDIF
21667 ENDIF
21668 740 CONTINUE
21669C...Choose diquark spin.
21670 IF (NBRVQ.EQ.2) THEN
21671C...If the selected quarks are both valence, we may use SU(6) rules
21672C...to figure out which spin the diquark has, by a subdivision of the
21673C...original beam hadron into the selected diquark system plus a kicked
21674C...out quark, IKO.
21675 JKO=6
21676 DO 760 JDQ=1,2
21677 DO 750 JV=1,3
21678 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21679 750 CONTINUE
21680 760 CONTINUE
21681 IKO=IV(JS,JKO)
21682 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21683 ELSE
21684C...If one or more of the selected quarks are not valence, we cannot use
21685C...SU(6) subdivisions of the original beam hadron. Instead, with the
21686C...flavours of the diquark already selected, we assume for now
21687C...50:50 spin-1:spin-0 (where spin-0 possible).
21688 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21689 IS=3
21690 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21691 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21692 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21693 ENDIF
21694
21695C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21696C...Note: third quark can per definition not also be valence,
21697C...therefore we can only do this if we are allowed to use sea quarks.
21698 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21699 NTRY=0
21700 780 NTRY=NTRY+1
21701 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21702 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21703 GOTO 780
21704 ELSEIF(NTRY.GT.100) THEN
21705C...If no baryon can be found, give up and form diquark.
21706 IDQ(3)=0
21707 GOTO 770
21708 ELSE
21709C...Replace junction by baryon.
21710 K(IJU,1)=1
21711 K(IJU,2)=KFBAR
21712 K(IJU,3)=MINT(83)+JS
21713 K(IJU,4)=0
21714 K(IJU,5)=0
21715 P(IJU,5)=PYMASS(KFBAR)
21716 DO 790 MSJ=1,3
21717C...Prepare removal of participating quarks from ER.
21718 K(JST(JS,MSJ),1)=-1
21719 790 CONTINUE
21720 ENDIF
21721 ELSE
21722C...If collapse to baryon not possible or not allowed, replace junction
21723C...by diquark. This way, collapsed gluons that were pointing at the
21724C...junction will now point (correctly) at diquark.
21725 MANTI=ITJUNC(JS)-1
21726 K(IJU,1)=3
21727 K(IJU,2)=KFDQ
21728 K(IJU,3)=MINT(83)+JS
21729 K(IJU,4)=0
21730 K(IJU,5)=0
21731 DO 800 MSJ=1,3
21732 IP=JST(JS,MSJ)
21733 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21734 K(IJU,4+MANTI)=0
21735 K(IJU,5-MANTI)=IP*MSTU(5)
21736 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21737 & MSTU(5)*IJU
21738 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21739 ELSE
21740C...Prepare removal of participating quarks from ER.
21741 K(IP,1)=-1
21742 ENDIF
21743 800 CONTINUE
21744 ENDIF
21745
21746C...Update so ER pointers to collapsed quarks
21747C...now go to collapsed object.
21748 DO 820 I=MINT(84)+1,N
21749 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21750 & .K(I,1).GT.0) THEN
21751 DO 810 ISID=4,5
21752 IMO=K(I,ISID)/MSTU(5)
21753 IDA=MOD(K(I,ISID),MSTU(5))
21754 IF (IMO.GT.0) THEN
21755 IF (K(IMO,1).EQ.-1) IMO=IJU
21756 ENDIF
21757 IF (IDA.GT.0) THEN
21758 IF (K(IDA,1).EQ.-1) IDA=IJU
21759 ENDIF
21760 K(I,ISID)=IDA+MSTU(5)*IMO
21761 810 CONTINUE
21762 ENDIF
21763 820 CONTINUE
21764 ENDIF
21765 ENDIF
21766
21767C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21768C...(this only happens for baryons, where we want to force the gluon
21769C...to sit next to the junction. Mesons handled above.)
21770 IF (NBRTOT(JS).EQ.0) THEN
21771 N=N+1
21772 DO 830 IX=1,5
21773 K(N,IX)=0
21774 P(N,IX)=0D0
21775 V(N,IX)=0D0
21776 830 CONTINUE
21777 IGL=N
21778 K(IGL,1)=3
21779 K(IGL,2)=21
21780 K(IGL,3)=MINT(83)+JS
21781 IF (ITJUNC(JS).NE.0) THEN
21782C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21783 JLEG=PYR(0)*NVSUM(JS)+1
21784 I1=JST(JS,JLEG)
21785 JST(JS,JLEG)=IGL
21786 JCT=MCT(I1,ITJUNC(JS))
21787 MCT(IGL,3-ITJUNC(JS))=JCT
21788 NCT=NCT+1
21789 MCT(IGL,ITJUNC(JS))=NCT
21790 MANTI=ITJUNC(JS)-1
21791 ELSE
21792C...Meson. Should not happen.
21793 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21794 IF(NERRPR.LT.5) THEN
21795 WRITE(MSTU(11),*) 'This should not have been possible!'
21796 CALL PYLIST(4)
21797 NERRPR=NERRPR+1
21798 ENDIF
21799 MINT(51)=1
21800 RETURN
21801 ENDIF
21802 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21803 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21804 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21805 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21806 IF (K(I2,2).NE.88) THEN
21807 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21808 ELSE
21809 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21810 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21811 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21812 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21813 ELSE
21814 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21815 ENDIF
21816 ENDIF
21817 ENDIF
21818 840 CONTINUE
21819
21820C...Remove collapsed quarks and junctions from ER and update IMI.
21821 CALL PYEDIT(11)
21822
21823C...Also update beam remnant part of IMI.
21824 NMI(1)=MINT(31)
21825 NMI(2)=MINT(31)
21826 DO 850 I=MINT(53)+1,N
21827 IF (K(I,1).LE.0) GOTO 850
21828C...Restore BR quark/diquark/baryon pointers in IMI.
21829 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21830 JS=K(I,3)-MINT(83)
21831 NMI(JS)=NMI(JS)+1
21832 IMI(JS,NMI(JS),1)=I
21833 IMI(JS,NMI(JS),2)=0
21834 ENDIF
21835 850 CONTINUE
21836
21837C...Restore companion information from collapsed gluons.
21838 DO 870 I=MINT(53)+1,N
21839 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21840 JS=K(I,3)-MINT(83)
21841 JCD=MOD(K(I,4),MSTU(5))
21842 JAD=MOD(K(I,5),MSTU(5))
21843 DO 860 IM=1,NMI(JS)
21844 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21845 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21846 860 CONTINUE
21847 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21848 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21849 ENDIF
21850 870 CONTINUE
21851
21852C...Renumber colour lines (since some have disappeared)
21853 JCT=0
21854 JCD=0
21855 880 JCT=JCT+1
21856 MFOUND=0
21857 I=MINT(84)
21858 890 I=I+1
21859 IF (I.EQ.N+1) THEN
21860 IF (MFOUND.EQ.0) JCD=JCD+1
21861 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21862 MCT(I,1)=JCT-JCD
21863 MFOUND=1
21864 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21865 MCT(I,2)=JCT-JCD
21866 MFOUND=1
21867 ENDIF
21868 IF (I.LE.N) GOTO 890
21869 IF (JCT.LT.NCT) GOTO 880
21870 NCT=JCT-JCD
21871
21872C...Reset hard interaction subsystems to their CM frames.
21873 IF (IBOOST.EQ.1) THEN
21874 DO 900 IM=1,MINT(31)
21875 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21876 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21877 900 CONTINUE
21878C...Zero beam remnant longitudinal momenta and energies
21879 DO 910 I=MINT(53)+1,N
21880 P(I,3)=0D0
21881 P(I,4)=0D0
21882 910 CONTINUE
21883 ELSE
21884 CALL PYERRM(9
21885 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21886C...Kill event and start another.
21887 MINT(51)=1
21888 RETURN
21889 ENDIF
21890
21891 9999 RETURN
21892 END
21893C*********************************************************************
21894
21895C...PYCTTR
21896C...Adapted from PYPREP.
21897C...Assigns LHA1 colour tags to coloured partons based on
21898C...K(I,4) and K(I,5) colour connection record.
21899C...KCS negative signifies that a previous tracing should be continued.
21900C...(in case the tag to be continued is empty, the routine exits)
21901C...Starts at I and ends at I or IEND.
21902C...Special considerations for systems with junctions.
21903
21904 SUBROUTINE PYCTTR(I,KCS,IEND)
21905C...Double precision and integer declarations.
21906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21907 INTEGER PYK,PYCHGE,PYCOMP
21908C...Commonblocks.
21909 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21910 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21911 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21912 COMMON/PYINT1/MINT(400),VINT(400)
21913C...The common block of colour tags.
21914 COMMON/PYCTAG/NCT,MCT(4000,2)
21915 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21916 DATA NERRPR/0/
21917 SAVE NERRPR
21918
21919C...Skip if parton not existing or does not have KCS
21920 IF (K(I,1).LE.0) GOTO 120
21921 KC=PYCOMP(K(I,2))
21922 IF (KC.EQ.0) GOTO 120
21923 KQ=KCHG(KC,2)
21924 IF (KQ.EQ.0) GOTO 120
21925 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21926 & GOTO 120
21927
21928 IF (KCS.GT.0) THEN
21929 NCT=NCT+1
21930C...Set colour tag of first parton.
21931 MCT(I,KCS-3)=NCT
21932 NCS=NCT
21933 ELSE
21934 KCS=-KCS
21935 NCS=MCT(I,KCS-3)
21936 IF (NCS.EQ.0) GOTO 120
21937 ENDIF
21938
21939 IA=I
21940 NSTP=0
21941 100 NSTP=NSTP+1
21942 IF(NSTP.GT.4*N) THEN
21943 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21944 GOTO 120
21945 ENDIF
21946
21947C...Finished if reached final-state triplet.
21948 IF(K(IA,1).EQ.3) THEN
21949 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21950 ENDIF
21951
21952C...Also finished if reached junction.
21953 IF(K(IA,1).EQ.42) THEN
21954 GOTO 120
21955 ENDIF
21956
21957C...GOTO next parton in colour space.
21958 110 IB=IA
21959C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21960 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21961 & .NE.0) THEN
21962 IA=MOD(K(IB,KCS),MSTU(5))
21963 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21964 MREV=0
21965 ELSE
21966C...If KCS mother traced or KCS mother nonexistent, switch colour.
21967 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21968 & MSTU(5)).EQ.0) THEN
21969 KCS=9-KCS
21970 NCT=NCT+1
21971 NCS=NCT
21972C...Assign new colour tag on other side of old parton.
21973 MCT(IB,KCS-3)=NCT
21974 ENDIF
21975C...Goto (new) KCS mother, set mother traced tag
21976 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21977 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21978 MREV=1
21979 ENDIF
21980 IF(IA.LE.0.OR.IA.GT.N) THEN
21981 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21982 IF(NERRPR.LT.5) THEN
21983 write(*,*) 'began at ',I
21984 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
21985 & ' NCS=',NCS,' MREV=',MREV
21986 CALL PYLIST(4)
21987 NERRPR=NERRPR+1
21988 ENDIF
21989 MINT(51)=1
21990 RETURN
21991 ENDIF
21992 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21993 & MSTU(5)).EQ.IB) THEN
21994 IF(MREV.EQ.1) KCS=9-KCS
21995 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21996C...Set KSC mother traced tag for IA
21997 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21998 ELSE
21999 IF(MREV.EQ.0) KCS=9-KCS
22000 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22001C...Set KCS daughter traced tag for IA
22002 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22003 ENDIF
22004C...Assign new colour tag
22005 MCT(IA,KCS-3)=NCS
22006 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
22007
22008 120 RETURN
22009 END
22010
22011*********************************************************************
22012
22013C...PYMIHG
22014C...Collapse JCP1 and connecting tags to JCG1.
22015C...Collapse JCP2 and connecting tags to JCG2.
22016
22017 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22018C...Double precision and integer declarations.
22019 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22020 IMPLICIT INTEGER(I-N)
22021 INTEGER PYK,PYCHGE,PYCOMP
22022C...The event record
22023 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22024C...Parameters
22025 COMMON/PYINT1/MINT(400),VINT(400)
22026 SAVE /PYJETS/,/PYINT1/
22027C...Local variables
22028 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22029 COMMON /PYCTAG/NCT,MCT(4000,2)
22030 SAVE /PYCBLS/,/PYCTAG/
22031
22032C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22033C...in temporary tag collapse array JCCN. Only break up one connection.
22034 MACCPT=1
22035 MCLPS=0
22036 DO 100 ICC=1,NCC
22037 JCCN(ICC,1)=JCCO(ICC,1)
22038 JCCN(ICC,2)=JCCO(ICC,2)
22039C...If there was a mother, it was previously connected to JCP1.
22040C...Should be changed to JCP2.
22041 IF (MCLPS.EQ.0) THEN
22042 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22043 & ,JCP2)) THEN
22044 JCCN(ICC,1)=MAX(JCG2,JCP2)
22045 JCCN(ICC,2)=MIN(JCG2,JCP2)
22046 MCLPS=1
22047 ENDIF
22048 ENDIF
22049 100 CONTINUE
22050C...Also collapse colours on JCP1 side of JCG1
22051 IF (JCP1.NE.0) THEN
22052 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22053 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22054 ELSE
22055 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22056 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22057 ENDIF
22058
22059C...Initialize event record colour tag array MCT array to MCO.
22060 DO 110 I=MINT(84)+1,N
22061 MCT(I,1)=MCO(I,1)
22062 MCT(I,2)=MCO(I,2)
22063 110 CONTINUE
22064
22065C...Collapse tags:
22066C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22067C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22068C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22069C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22070 DO 160 IS=1,4
22071C...Skip if junction.
22072 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22073C...Define starting point in tag space.
22074C...JCA = previous tag
22075C...JCO = present tag
22076C...JCN = new tag
22077 IF (MOD(IS,2).EQ.1) THEN
22078 JCO=JCP1
22079 JCN=JCG1
22080 JCALL=JCG1
22081 ELSEIF (MOD(IS,2).EQ.0) THEN
22082 JCO=JCP2
22083 JCN=JCG2
22084 JCALL=JCG2
22085 ENDIF
22086 ITRACE=0
22087 120 ITRACE=ITRACE+1
22088 IF (ITRACE.GT.1000) THEN
22089C...NB: Proper error message should be defined here.
22090 CALL PYERRM(14
22091 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22092 MINT(57)=MINT(57)+1
22093 MINT(51)=1
22094 RETURN
22095 ENDIF
22096C...Collapse all JCN tags to JCALL
22097 DO 130 I=MINT(84)+1,N
22098 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22099 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22100 130 CONTINUE
22101C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22102 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22103 JCA=JCN
22104 JCN=JCO
22105 ELSE
22106 JCA=JCO
22107 JCO=JCN
22108 ENDIF
22109C...If possible, step from JCO to new tag JCN not equal to JCA.
22110 DO 140 ICC=1,NCC+1
22111 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22112 & JCCN(ICC,2)
22113 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22114 & JCCN(ICC,1)
22115 140 CONTINUE
22116C...Iterate if new colour was arrived at, but don't go in circles.
22117 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22118C...Change all JCN tags in MCO to JCALL in MCT.
22119 DO 150 I=MINT(84)+1,N
22120 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22121 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22122C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22123 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22124 & .NE.0) MACCPT=0
22125 150 CONTINUE
22126 160 CONTINUE
22127
22128 DO 200 JCL=NCT,1,-1
22129 JCA=0
22130 JCN=JCL
22131 170 JCO=JCN
22132 DO 180 ICC=1,NCC+1
22133 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22134 & =JCCN(ICC,2)
22135 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22136 & =JCCN(ICC,1)
22137 180 CONTINUE
22138C...Overpaint all JCN with JCL
22139 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22140 DO 190 I=MINT(84)+1,N
22141 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22142 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22143C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22144 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22145 & .NE.0) MACCPT=0
22146 190 CONTINUE
22147 JCA=JCO
22148 GOTO 170
22149 ENDIF
22150 200 CONTINUE
22151
22152 RETURN
22153 END
22154
22155C*********************************************************************
22156
22157C...PYMIRM
22158C...Picks primordial kT and shares longitudinal momentum among
22159C...beam remnants.
22160
22161 SUBROUTINE PYMIRM
22162
22163C...Double precision and integer declarations.
22164 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22165 IMPLICIT INTEGER(I-N)
22166 INTEGER PYK,PYCHGE,PYCOMP
22167C...The event record
22168 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22169C...Parameters
22170 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22171 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22172 COMMON/PYINT1/MINT(400),VINT(400)
22173C...The common block of colour tags.
22174 COMMON/PYCTAG/NCT,MCT(4000,2)
22175C...The common block of dangling ends
22176 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22177 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22178 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22179 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22180C...Local variables
22181 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22182C...W(I,J)| J=0 | 1 | 2 |
22183C... I=0 | Wrem**2 | W+ | W- |
22184C... 1 | W1**2 | W1+ | W1- |
22185C... 2 | W2**2 | W2+ | W2- |
22186C...4-product
22187 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)
22188C...Tentative parametrization of <kT> as a function of Q.
22189 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22190C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22191C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22192 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22193C...Lambda kinematic function.
22194 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22195
22196C...Beginning and end of beam remnant partons
22197 NOUT=MINT(53)
22198 ISUB=MINT(1)
22199
22200C...Loopback point if kinematic choices gives impossible configuration.
22201 NTRY=0
22202 100 NTRY=NTRY+1
22203
22204C...Assign kT values on each side separately.
22205 DO 180 JS=1,2
22206
22207C...First zero all kT on this side. Skip if no kT to generate.
22208 DO 110 IM=1,NMI(JS)
22209 P(IMI(JS,IM,1),1)=0D0
22210 P(IMI(JS,IM,1),2)=0D0
22211 110 CONTINUE
22212 IF(MSTP(91).LE.0) GOTO 180
22213
22214C...Now assign kT to each (non-collapsed) parton in IMI.
22215 DO 170 IM=1,NMI(JS)
22216 I=IMI(JS,IM,1)
22217C...Select kT according to truncated gaussian or 1/kt6 tails.
22218C...For first interaction, either use rms width = PARP(91) or fitted.
22219 IF (IM.EQ.1) THEN
22220 SIGMA=PARP(91)
22221 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22222 Q=SQRT(PT2MI(IM))
22223 SIGMA=SIGPT(Q)
22224 ENDIF
22225 ELSE
22226C...For subsequent interactions and BR partons use fragmentation width.
22227 SIGMA=PARJ(21)
22228 ENDIF
22229 PHI=PARU(2)*PYR(0)
22230 PT=0D0
22231 IF(NTRY.LE.100) THEN
22232 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22233 PT=GETPT(Q,SIGMA)
22234 PTX=PT*COS(PHI)
22235 PTY=PT*SIN(PHI)
22236 ELSEIF (MSTP(91).EQ.2) THEN
22237 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22238 & 'available, using MSTP(91)=1.')
22239 CALL PYGIVE('MSTP(91)=1')
22240 GOTO 111
22241 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22242C...Use distribution with kt**6 tails, rms width = PARP(91).
22243 EPS=SQRT(3D0/2D0)*SIGMA
22244C...Generate PTX and PTY separately, each propto 1/KT**6
22245 DO 119 IXY=1,2
22246C...Decide which interval to try
22247 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22248 IF (PYR(0).LT.P12) THEN
22249C...Use flat approx with accept/reject up to EPS.
22250 PT=PYR(0)*EPS
22251 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22252 IF (PYR(0).GT.WT) GOTO 112
22253 ELSE
22254C...Above EPS, use 1/kt**6 approx with accept/reject.
22255 PT=EPS/(PYR(0)**(1D0/5D0))
22256 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22257 IF (PYR(0).GT.WT) GOTO 112
22258 ENDIF
22259 MSIGN=1
22260 IF (PYR(0).GT.0.5D0) MSIGN=-1
22261 IF (IXY.EQ.1) PTX=MSIGN*PT
22262 IF (IXY.EQ.2) PTY=MSIGN*PT
22263 119 CONTINUE
22264 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22265 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22266 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22267 ENDIF
22268C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22269 PT=SQRT(PTX**2+PTY**2)
22270 WT=1D0
22271 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22272 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22273 PTX=PTX*WT
22274 PTY=PTY*WT
22275 PT=SQRT(PTX**2+PTY**2)
22276 ENDIF
22277
22278 P(I,1)=P(I,1)+PTX
22279 P(I,2)=P(I,2)+PTY
22280
22281C...Compensation kicks, with varying degree of local anticorrelations.
22282 MCORR=MSTP(90)
22283 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22284 PTCX=-PTX/(NMI(JS)-1)
22285 PTCY=-PTY/(NMI(JS)-1)
22286 IF(ISUB.EQ.95) THEN
22287 PTCX=-PTX/(NMI(JS)-2)
22288 PTCY=-PTY/(NMI(JS)-2)
22289 ENDIF
22290 DO 120 IMC=1,NMI(JS)
22291 IF (IMC.EQ.IM) GOTO 120
22292 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22293 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22294 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22295 120 CONTINUE
22296 ELSEIF (MCORR.GE.1) THEN
22297 DO 140 MSID=4,5
22298 NNXT(MSID-3)=0
22299C...Count up # of neighbours on either side
22300 IMO=I
22301 130 IMO=K(IMO,MSID)/MSTU(5)
22302 IF (IMO.EQ.0) GOTO 140
22303 NNXT(MSID-3)=NNXT(MSID-3)+1
22304C...Stop at quarks and junctions
22305 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22306 140 CONTINUE
22307C...How should compensation be shared when unequal numbers on the
22308C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22309 NSUM=NNXT(1)+NNXT(2)
22310 T1=0
22311 DO 160 MSID=4,5
22312C...Total momentum to be compensated on this side
22313 IF (NNXT(MSID-3).EQ.0) GOTO 160
22314 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22315 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22316C...RS: compensation supression factor as we go out from parton I.
22317C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22318C...since (for now) MSTP(90) provides enough variability.
22319 RS=0.5D0
22320 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22321 IMO=I
22322 150 IDA=IMO
22323 IMO=K(IMO,MSID)/MSTU(5)
22324 IF (IMO.EQ.0) GOTO 160
22325 FAC=FAC*RS
22326 IF (K(IMO,2).NE.88) THEN
22327 P(IMO,1)=P(IMO,1)+FAC*PTCX
22328 P(IMO,2)=P(IMO,2)+FAC*PTCY
22329 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22330C...If we reach junction, divide out the kT that would have been
22331C...assigned to the junction on each of its other legs.
22332 ELSE
22333 L1=MOD(K(IMO,4),MSTU(5))
22334 L2=K(IMO,5)/MSTU(5)
22335 L3=MOD(K(IMO,5),MSTU(5))
22336 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22337 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22338 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22339 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22340 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22341 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22342 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22343 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22344 ENDIF
22345
22346 160 CONTINUE
22347 ENDIF
22348 170 CONTINUE
22349C...End assignment of kT values to initiators and remnants.
22350 180 CONTINUE
22351
22352C...Check kinematics constraints for non-BR partons.
22353 DO 190 IM=1,MINT(31)
22354 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
22355 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
22356 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
22357 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
22358 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
22359 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
22360 IF(NTRY.GE.100) THEN
22361C...Kill this event and start another.
22362 CALL PYERRM(11,
22363 & '(PYMIRM:) No consistent (x,kT) sets found')
22364 MINT(51)=1
22365 RETURN
22366 ENDIF
22367 GOTO 100
22368 ENDIF
22369 190 CONTINUE
22370
22371C...Calculate W+ and W- available for combined remnant system.
22372 W(0,1)=VINT(1)
22373 W(0,2)=VINT(1)
22374 DO 200 IM=1,MINT(31)
22375 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
22376 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
22377 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
22378 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
22379 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
22380 200 CONTINUE
22381C...Also store Wrem**2 = W+ * W-
22382 W(0,0)=W(0,1)*W(0,2)
22383
22384 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
22385 IF(NTRY.GE.100) THEN
22386C...Kill this event and start another.
22387 CALL PYERRM(11,
22388 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22389 MINT(51)=1
22390 RETURN
22391 ENDIF
22392 GOTO 100
22393 ENDIF
22394
22395C...Assign unscaled x values to partons/hadrons in each of the
22396C...beam remnants and calculate unscaled W+ and W- from them.
22397 NTRYX=0
22398 210 NTRYX=NTRYX+1
22399 DO 280 JS=1,2
22400 W(JS,1)=0D0
22401 W(JS,2)=0D0
22402 DO 270 IM=MINT(31)+1,NMI(JS)
22403 I=IMI(JS,IM,1)
22404 KF=K(I,2)
22405 KFA=IABS(KF)
22406 ICOMP=IMI(JS,IM,2)
22407
22408C...Skip collapsed gluons and junctions. Reset.
22409 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
22410 IF (KFA.EQ.88) GOTO 270
22411 X=0D0
22412 IVALQ(1)=0
22413 IVALQ(2)=0
22414 ICOMQ(1)=0
22415 ICOMQ(2)=0
22416
22417C...If gluon then only beam remnant, so takes all.
22418 IF(KFA.EQ.21) THEN
22419 X=1D0
22420C...If valence quark then use parametrized valence distribution.
22421 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
22422 IVALQ(1)=KF
22423C...If companion quark then derive from companion x.
22424 ELSEIF(KFA.LE.6) THEN
22425 ICOMQ(1)=ICOMP
22426C...If valence diquark then use two parametrized valence distributions.
22427 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22428 & ICOMP.EQ.0) THEN
22429 IVALQ(1)=ISIGN(KFA/1000,KF)
22430 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
22431C...If valence+sea diquark then combine valence + companion choices.
22432 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22433 & ICOMP.LT.MSTU(5)) THEN
22434 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
22435 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
22436 ELSE
22437 IVALQ(1)=ISIGN(KFA/1000,KF)
22438 ENDIF
22439 ICOMQ(1)=ICOMP
22440C...Extra code: workaround for diquark made out of two sea
22441C...quarks, but where not (yet) ICOMP > MSTU(5).
22442 DO 220 IM1=1,MINT(31)
22443 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
22444 ICOMQ(2)=IMI(JS,IM1,1)
22445 IVALQ(1)=0
22446 ENDIF
22447 220 CONTINUE
22448C...If sea diquark then sum of two derived from companion x.
22449 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
22450 ICOMQ(1)=MOD(ICOMP,MSTU(5))
22451 ICOMQ(2)=ICOMP/MSTU(5)
22452C...If meson or baryon then use fragmentation function.
22453C...Somewhat arbitrary split into old and new flavour, but OK normally.
22454 ELSE
22455 KFL3=MOD(KFA/10,10)
22456 IF(MOD(KFA/1000,10).EQ.0) THEN
22457 KFL1=MOD(KFA/100,10)
22458 ELSE
22459 KFL1=MOD(KFA,10000)-10*KFL3-1
22460 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
22461 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
22462 ENDIF
22463 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
22464 CALL PYZDIS(KFL1,KFL3,PR,X)
22465 ENDIF
22466
22467 DO 260 IQ=1,2
22468C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
22469C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
22470C...In other baryons combine u and d from proton appropriately.
22471 IF(IVALQ(IQ).NE.0) THEN
22472 NVAL=0
22473 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
22474 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
22475 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
22476C...Meson.
22477 IF(KFIVAL(JS,3).EQ.0) THEN
22478 MDU=0
22479C...Baryon with three identical quarks: mix u and d forms.
22480 ELSEIF(NVAL.EQ.3) THEN
22481 MDU=INT(PYR(0)+5D0/3D0)
22482C...Baryon, one of two identical quarks: u form.
22483 ELSEIF(NVAL.EQ.2) THEN
22484 MDU=2
22485C...Baryon with two identical quarks, but not the one picked: d form.
22486 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
22487 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
22488 MDU=1
22489C...Baryon with three nonidentical quarks: mix u and d forms.
22490 ELSE
22491 MDU=INT(PYR(0)+5D0/3D0)
22492 ENDIF
22493 XPOW=0.8D0
22494 IF(MDU.EQ.1) XPOW=3.5D0
22495 IF(MDU.EQ.2) XPOW=2D0
22496 230 XX=PYR(0)**2
22497 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
22498 X=X+XX
22499 ENDIF
22500
22501C...Calculation of x of companion quark.
22502 IF(ICOMQ(IQ).NE.0) THEN
22503 XCOMP=1D-4
22504 DO 240 IM1=1,MINT(31)
22505 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
22506 240 CONTINUE
22507 NPOW=MAX(0,MIN(4,MSTP(87)))
22508 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
22509 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
22510 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
22511 IF(CORR.LT.PYR(0)) GOTO 250
22512 X=X+XX
22513 ENDIF
22514 260 CONTINUE
22515
22516C...Optionally enchance x of composite systems (e.g. diquarks)
22517 IF (KFA.GT.100) X=PARP(79)*X
22518
22519C...Store x. Also calculate light cone energies of each system.
22520 XMI(JS,IM)=X
22521 W(JS,JS)=W(JS,JS)+X
22522 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
22523 270 CONTINUE
22524 W(JS,JS)=W(JS,JS)*W(0,JS)
22525 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
22526 W(JS,0)=W(JS,1)*W(JS,2)
22527 280 CONTINUE
22528
22529C...Check W1 W2 < Wrem (can be done before rescaling, since W
22530C...insensitive to global rescalings of the BR x values).
22531 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
22532 & THEN
22533 GOTO 210
22534 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
22535 GOTO 100
22536 ELSEIF (NTRYX.GT.100) THEN
22537 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
22538 MINT(57)=MINT(57)+1
22539 MINT(51)=1
22540 RETURN
22541 ENDIF
22542
22543C...Compute x rescaling factors
22544 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
22545 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
22546 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
22547
22548 IF (R1.LT.0.OR.R2.LT.0) THEN
22549 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
22550 MINT(57)=MINT(57)+1
22551 MINT(51)=1
22552 ENDIF
22553
22554C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
22555 W(1,1)=W(1,1)*R1
22556 W(1,2)=W(1,2)/R1
22557 W(2,1)=W(2,1)/R2
22558 W(2,2)=W(2,2)*R2
22559
22560C...Rescale BR x values.
22561 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
22562 XMI(1,IM)=XMI(1,IM)*R1
22563 XMI(2,IM)=XMI(2,IM)*R2
22564 290 CONTINUE
22565
22566C...Now we have a consistent set of x and kT values.
22567C...First set up the initiators and their daughters correctly.
22568 DO 300 IM=1,MINT(31)
22569 I1=IMI(1,IM,1)
22570 I2=IMI(2,IM,1)
22571 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
22572 & (P(I1,2)+P(I2,2))**2
22573 PT12=P(I1,1)**2+P(I1,2)**2
22574 PT22=P(I2,1)**2+P(I2,2)**2
22575C...p_z
22576 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
22577 P(I2,3)=-P(I1,3)
22578C...Energies (masses should be zero at this stage)
22579 P(I1,4)=SQRT(PT12+P(I1,3)**2)
22580 P(I2,4)=SQRT(PT22+P(I2,3)**2)
22581
22582C...Transverse 12 system initiator velocity:
22583 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
22584 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
22585C...Boost to overall initiator system rest frame
22586 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
22587 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
22588
22589C...Compute phi,theta coordinates of I1 and rotate z axis.
22590 PHI=PYANGL(P(I1,1),P(I1,2))
22591 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
22592 IMIN=IMISEP(IM-1)+1
22593C...(include documentation lines if MI = 1)
22594 IF (IM.EQ.1) IMIN=MINT(83)+5
22595 IMAX=IMISEP(IM)
22596C...Rotate entire system in phi
22597 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
22598C...Only rotate 12 system in theta
22599 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
22600 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
22601
22602C...Now boost entire system back to LAB
22603 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22604 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
22605 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
22606
22607 300 CONTINUE
22608
22609
22610C...For the beam remnant partons/hadrons, we only need to set pz and E.
22611 DO 320 JS=1,2
22612 DO 310 IM=MINT(31)+1,NMI(JS)
22613 I=IMI(JS,IM,1)
22614C...Skip collapsed gluons and junctions.
22615 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22616 IF (KFA.EQ.88) GOTO 310
22617 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22618 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22619 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22620 IF (JS.EQ.2) P(I,3)=-P(I,3)
22621 310 CONTINUE
22622 320 CONTINUE
22623
22624
22625C...Documentation lines
22626 DO 340 JS=1,2
22627 IN=MINT(83)+JS+2
22628 IO=IMI(JS,1,1)
22629 K(IN,1)=21
22630 K(IN,2)=K(IO,2)
22631 K(IN,3)=MINT(83)+JS
22632 K(IN,4)=0
22633 K(IN,5)=0
22634 DO 330 J=1,5
22635 P(IN,J)=P(IO,J)
22636 V(IN,J)=V(IO,J)
22637 330 CONTINUE
22638 MCT(IN,1)=MCT(IO,1)
22639 MCT(IN,2)=MCT(IO,2)
22640 340 CONTINUE
22641
22642C...Final state colour reconnections.
22643 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22644
22645C...Number of colour tags for which a recoupling will be tried.
22646 NTOT=NCT
22647C...Number of recouplings to try
22648 MINT(34)=0
22649 NRECP=0
22650 NITER=0
22651 350 NRECP=MINT(34)
22652 NITER=NITER+1
22653 IITER=0
22654 360 IITER=IITER+1
22655 IF (IITER.LE.PARP(78)*NTOT) THEN
22656C...Select two colour tags at random
22657C...NB: jj strings do not have colour tags assigned to them,
22658C...thus they are as yet not affected by anything done here.
22659 JCT=PYR(0)*NCT+1
22660 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22661 IJ1=0
22662 IJ2=0
22663 IK1=0
22664 IK2=0
22665C...Find final state partons with this (anti)colour
22666 DO 370 I=MINT(84)+1,N
22667 IF (K(I,1).EQ.3) THEN
22668 IF (MCT(I,1).EQ.JCT) IJ1=I
22669 IF (MCT(I,2).EQ.JCT) IJ2=I
22670 IF (MCT(I,1).EQ.KCT) IK1=I
22671 IF (MCT(I,2).EQ.KCT) IK2=I
22672 ENDIF
22673 370 CONTINUE
22674C...Only consider recouplings not involving junctions for now.
22675 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22676
22677 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22678 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22679 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22680 MCT(IJ2,2)=KCT
22681 MCT(IK2,2)=JCT
22682C...Count up number of reconnections
22683 MINT(34)=MINT(34)+1
22684 ENDIF
22685 IF (MINT(34).LE.1000) THEN
22686 GOTO 360
22687 ELSE
22688 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22689 GOTO 380
22690 ENDIF
22691 ENDIF
22692 IF (NRECP.LT.MINT(34)) GOTO 350
22693
22694C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22695 380 MINT(33)=1
22696
22697 RETURN
22698 END
22699
22700C*********************************************************************
22701
22702C...PYFSCR
22703C...Performs colour annealing.
22704C...MSTP(95) : CR Type
22705C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22706C... = 2 : Type I(no gg loops); hadron-hadron only
22707C... = 3 : Type I(no gg loops); all beams
22708C... = 4 : Type II(gg loops) ; hadron-hadron only
22709C... = 5 : Type II(gg loops) ; all beams
22710C... = 6 : Type S ; hadron-hadron only
22711C... = 7 : Type S ; all beams
22712C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22713C...Type S is driven by starting only from free triplets, not octets.
22714C...A string piece remains unchanged with probability
22715C... PKEEP = (1-PARP(78))**N
22716C...This scaling corresponds to each string piece having to go through
22717C...N other ones, each with probability PARP(78) for reconnection, where
22718C...N is here chosen simply as the number of multiple interactions,
22719C...for a rough scaling with the general level of activity.
22720
22721 SUBROUTINE PYFSCR(IP)
22722C...Double precision and integer declarations.
22723 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22724 INTEGER PYK,PYCHGE,PYCOMP
22725C...Commonblocks.
22726 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22728 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22729 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22730 COMMON/PYINT1/MINT(400),VINT(400)
22731C...The common block of colour tags.
22732 COMMON/PYCTAG/NCT,MCT(4000,2)
22733 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22734 &/PYPARS/
22735C...MCN: Temporary storage of new colour tags
22736 DOUBLE PRECISION MCN(4000,2)
22737
22738C...Function to give four-product.
22739 FOUR(I,J)=P(I,4)*P(J,4)
22740 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22741
22742C...Check valid range of MSTP(95), local copy
22743 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22744 MSTP95=MOD(MSTP(95),10)
22745C...Set whether CR allowed inside resonance systems or not
22746C...(not implemented yet)
22747C MRESCR=1
22748C IF (MSTP(95).GE.10) MRESCR=0
22749
22750C...Check whether colour tags already defined
22751 IF (MINT(33).EQ.0) THEN
22752C...Erase any existing colour tags for this event
22753 DO 100 I=1,N
22754 MCT(I,1)=0
22755 MCT(I,2)=0
22756 100 CONTINUE
22757C...Create colour tags for this event
22758 DO 120 I=1,N
22759 IF (K(I,1).EQ.3) THEN
22760 DO 110 KCS=4,5
22761 KCSIN=KCS
22762 IF (MCT(I,KCSIN-3).EQ.0) THEN
22763 CALL PYCTTR(I,KCSIN,I)
22764 ENDIF
22765 110 CONTINUE
22766 ENDIF
22767 120 CONTINUE
22768C...Instruct PYPREP to use colour tags
22769 MINT(33)=1
22770 ENDIF
22771
22772C...For MSTP(95) even, only apply to hadron-hadron
22773 IF (MOD(MSTP(95),2).EQ.0) THEN
22774 KA1=IABS(MINT(11))
22775 KA2=IABS(MINT(12))
22776 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22777 ENDIF
22778
22779C...Initialize new tag array (but do not delete old yet)
22780 LCT=NCT
22781 DO 130 I=MAX(1,IP),N
22782 MCN(I,1)=0
22783 MCN(I,2)=0
22784 130 CONTINUE
22785
22786C...For each final-state dipole, check whether string should be
22787C...preserved.
22788 DO 150 ICT=1,NCT
22789 IC=0
22790 IA=0
22791 DO 140 I=MAX(1,IP),N
22792 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22793 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22794 140 CONTINUE
22795 IF (IC.NE.0.AND.IA.NE.0) THEN
22796C...Chiefly consider large strings.
22797 PKEEP=(1D0-PARP(78))**MINT(31)
22798 IF (PYR(0).LE.PKEEP) THEN
22799 LCT=LCT+1
22800 MCN(IC,1)=LCT
22801 MCN(IA,2)=LCT
22802 ENDIF
22803 ENDIF
22804 150 CONTINUE
22805
22806C...Loop over event record, starting from IP
22807C...(Ignore junctions for now.)
22808 NLOOP=0
22809 160 NLOOP=NLOOP+1
22810 MCIMAX=0
22811 MCJMAX=0
22812 RLMAX=0D0
22813 ILMAX=0
22814 JLMAX=0
22815 DO 230 I=MAX(1,IP),N
22816 IF (K(I,1).NE.3) GOTO 230
22817C...Check colour charge
22818 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22819 IF (MCI.EQ.0) GOTO 230
22820C...For Seattle algorithm, only start from partons with one dangling
22821C...colour tag
22822 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22823 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22824 ENDIF
22825C... Find optimal partner
22826 JLOPT=0
22827 MCJOPT=0
22828 MBROPT=0
22829 MGGOPT=0
22830 RLOPT=1D19
22831C...Loop over I colour/anticolour, check whether already connected
22832 170 DO 220 ICL=1,2
22833 IF (MCN(I,ICL).NE.0) GOTO 220
22834 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22835 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22836C...Check whether this is a dangling colour tag (ie to junction!)
22837 IFOUND=0
22838 DO 180 J=MAX(1,IP),N
22839 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22840 180 CONTINUE
22841 IF (IFOUND.EQ.0) GOTO 220
22842 DO 210 J=MAX(1,IP),N
22843 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22844C...Do not make direct connections between partons in same Beam Remnant
22845 MBRSTR=0
22846 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22847 & MBRSTR=1
22848C...Check colour charge
22849 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22850 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22851C...Check for gluon loops
22852 MGGSTR=0
22853 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22854 ICLA=3-ICL
22855 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22856 & MCN(I,ICLA).NE.0) MGGSTR=1
22857 ENDIF
22858C...Loop over J colour/anticolour, check whether already connected
22859 DO 200 JCL=1,2
22860 IF (MCN(J,JCL).NE.0) GOTO 200
22861 IF (JCL.EQ.ICL) GOTO 200
22862 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22863 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22864C...Check whether this is a dangling colour tag (ie to junction!)
22865 IFOUND=0
22866 DO 190 J2=MAX(1,IP),N
22867 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22868 & IFOUND=1
22869 190 CONTINUE
22870 IF (IFOUND.EQ.0) GOTO 200
22871C...Save connection with smallest lambda measure
22872C...If best so far was a BR string and this is not, also save.
22873C...If best so far was a gg string and this is not, also save.
22874 RL=FOUR(I,J)
22875 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22876 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22877 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22878 RLOPT=RL
22879 JLOPT=J
22880 ICOPT=ICL
22881 JCOPT=JCL
22882 MCJOPT=MCJ
22883 MBROPT=MBRSTR
22884 MGGOPT=MGGSTR
22885 ENDIF
22886 200 CONTINUE
22887 210 CONTINUE
22888 220 CONTINUE
22889 IF (JLOPT.NE.0) THEN
22890C...Save pair with largest RLOPT so far
22891 IF (RLOPT.GE.RLMAX) THEN
22892 RLMAX=RLOPT
22893 ILMAX=I
22894 JLMAX=JLOPT
22895 ICMAX=ICOPT
22896 JCMAX=JCOPT
22897 MCJMAX=MCJOPT
22898 MCIMAX=MCI
22899 ENDIF
22900 ENDIF
22901 230 CONTINUE
22902C...Save and iterate
22903 IF (ILMAX.GT.0) THEN
22904 LCT=LCT+1
22905 MCN(ILMAX,ICMAX)=LCT
22906 MCN(JLMAX,JCMAX)=LCT
22907 IF (NLOOP.LE.2*(N-IP)) THEN
22908 GOTO 160
22909 ELSE
22910 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
22911 CALL PYSTOP(11)
22912 ENDIF
22913 ELSE
22914C...Save and exit. First check for leftover gluon(s)
22915 DO 260 I=MAX(1,IP),N
22916C...Check colour charge
22917 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22918 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22919 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22920C...Decide where to put left-over gluon (minimal insertion)
22921 ILMAX=0
22922 RLMAX=1D19
22923 DO 250 KCT=NCT+1,LCT
22924 DO 240 IT=MAX(1,IP),N
22925 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22926 IF (MCN(IT,1).EQ.KCT) IC=IT
22927 IF (MCN(IT,2).EQ.KCT) IA=IT
22928 240 CONTINUE
22929 RL=FOUR(IC,I)*FOUR(IA,I)
22930 IF (RL.LT.RLMAX) THEN
22931 RLMAX=RL
22932 ICMAX=IC
22933 IAMAX=IA
22934 ENDIF
22935 250 CONTINUE
22936 LCT=LCT+1
22937 MCN(I,1)=MCN(ICMAX,1)
22938 MCN(I,2)=LCT
22939 MCN(ICMAX,1)=LCT
22940 ENDIF
22941 260 CONTINUE
22942 DO 270 I=MAX(1,IP),N
22943C...Do not erase parton shower colour history
22944 IF (K(I,1).NE.3) GOTO 270
22945C...Check colour charge
22946 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22947 IF (MCI.EQ.0) GOTO 270
22948 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22949 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22950 270 CONTINUE
22951 ENDIF
22952
22953 9999 RETURN
22954 END
22955
22956C*********************************************************************
22957
22958C...PYDIFF
22959C...Handles diffractive and elastic scattering.
22960
22961 SUBROUTINE PYDIFF
22962
22963C...Double precision and integer declarations.
22964 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22965 IMPLICIT INTEGER(I-N)
22966 INTEGER PYK,PYCHGE,PYCOMP
22967C...Commonblocks.
22968 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22969 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22970 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22971 COMMON/PYINT1/MINT(400),VINT(400)
22972 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22973
22974C...Reset K, P and V vectors. Store incoming particles.
22975 DO 110 JT=1,MSTP(126)+10
22976 I=MINT(83)+JT
22977 DO 100 J=1,5
22978 K(I,J)=0
22979 P(I,J)=0D0
22980 V(I,J)=0D0
22981 100 CONTINUE
22982 110 CONTINUE
22983 N=MINT(84)
22984 MINT(3)=0
22985 MINT(21)=0
22986 MINT(22)=0
22987 MINT(23)=0
22988 MINT(24)=0
22989 MINT(4)=4
22990 DO 130 JT=1,2
22991 I=MINT(83)+JT
22992 K(I,1)=21
22993 K(I,2)=MINT(10+JT)
22994 DO 120 J=1,5
22995 P(I,J)=VINT(285+5*JT+J)
22996 120 CONTINUE
22997 130 CONTINUE
22998 MINT(6)=2
22999
23000C...Subprocess; kinematics.
23001 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23002 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23003 DO 200 JT=1,2
23004 I=MINT(83)+JT
23005 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23006 KFH=MINT(102+JT)
23007
23008C...Elastically scattered particle. (Except elastic GVMD states.)
23009 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23010 & MINT(106+JT).NE.3)) THEN
23011 N=N+1
23012 K(N,1)=1
23013 K(N,2)=KFH
23014 K(N,3)=I+2
23015 P(N,3)=PZ*(-1)**(JT+1)
23016 P(N,4)=PE
23017 P(N,5)=SQRT(VINT(62+JT))
23018
23019C...Decay rho from elastic scattering of gamma with sin**2(theta)
23020C...distribution of decay products (in rho rest frame).
23021 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23022 NSAV=N
23023 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23024 P(N,3)=0D0
23025 P(N,4)=P(N,5)
23026 CALL PYDECY(NSAV)
23027 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23028 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23029 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23030 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23031 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23032 140 CTHE=2D0*PYR(0)-1D0
23033 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23034 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23035 ENDIF
23036 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23037 ENDIF
23038
23039C...Diffracted particle: low-mass system to two particles.
23040 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23041 N=N+2
23042 K(N-1,1)=1
23043 K(N,1)=1
23044 K(N-1,3)=I+2
23045 K(N,3)=I+2
23046 PMMAS=SQRT(VINT(62+JT))
23047 NTRY=0
23048 150 NTRY=NTRY+1
23049 IF(NTRY.LT.20) THEN
23050 MINT(105)=MINT(102+JT)
23051 MINT(109)=MINT(106+JT)
23052 CALL PYSPLI(KFH,21,KFL1,KFL2)
23053 CALL PYKFDI(KFL1,0,KFL3,KF1)
23054 IF(KF1.EQ.0) GOTO 150
23055 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23056 IF(KF2.EQ.0) GOTO 150
23057 ELSE
23058 KF1=KFH
23059 KF2=111
23060 ENDIF
23061 PM1=PYMASS(KF1)
23062 PM2=PYMASS(KF2)
23063 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23064 K(N-1,2)=KF1
23065 K(N,2)=KF2
23066 P(N-1,5)=PM1
23067 P(N,5)=PM2
23068 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23069 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23070 P(N-1,3)=PZP
23071 P(N,3)=-PZP
23072 P(N-1,4)=SQRT(PM1**2+PZP**2)
23073 P(N,4)=SQRT(PM2**2+PZP**2)
23074 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23075 & 0D0,0D0,0D0)
23076 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23077 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23078
23079C...Diffracted particle: valence quark kicked out.
23080 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23081 & PARP(101))) THEN
23082 N=N+2
23083 K(N-1,1)=2
23084 K(N,1)=1
23085 K(N-1,3)=I+2
23086 K(N,3)=I+2
23087 MINT(105)=MINT(102+JT)
23088 MINT(109)=MINT(106+JT)
23089 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23090 P(N-1,5)=PYMASS(K(N-1,2))
23091 P(N,5)=PYMASS(K(N,2))
23092 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23093 & 4D0*P(N-1,5)**2*P(N,5)**2
23094 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23095 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23096 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23097 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23098 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23099
23100C...Diffracted particle: gluon kicked out.
23101 ELSE
23102 N=N+3
23103 K(N-2,1)=2
23104 K(N-1,1)=2
23105 K(N,1)=1
23106 K(N-2,3)=I+2
23107 K(N-1,3)=I+2
23108 K(N,3)=I+2
23109 MINT(105)=MINT(102+JT)
23110 MINT(109)=MINT(106+JT)
23111 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23112 K(N-1,2)=21
23113 P(N-2,5)=PYMASS(K(N-2,2))
23114 P(N-1,5)=0D0
23115 P(N,5)=PYMASS(K(N,2))
23116C...Energy distribution for particle into two jets.
23117 160 IMB=1
23118 IF(MOD(KFH/1000,10).NE.0) IMB=2
23119 CHIK=PARP(92+2*IMB)
23120 IF(MSTP(92).LE.1) THEN
23121 IF(IMB.EQ.1) CHI=PYR(0)
23122 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23123 ELSEIF(MSTP(92).EQ.2) THEN
23124 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23125 ELSEIF(MSTP(92).EQ.3) THEN
23126 CUT=2D0*0.3D0/VINT(1)
23127 170 CHI=PYR(0)**2
23128 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23129 & PYR(0)) GOTO 170
23130 ELSEIF(MSTP(92).EQ.4) THEN
23131 CUT=2D0*0.3D0/VINT(1)
23132 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23133 180 CHIR=CUT*CUTR**PYR(0)
23134 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23135 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23136 ELSE
23137 CUT=2D0*0.3D0/VINT(1)
23138 CUTA=CUT**(1D0-PARP(98))
23139 CUTB=(1D0+CUT)**(1D0-PARP(98))
23140 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23141 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23142 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23143 ENDIF
23144 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23145 & VINT(62+JT)) GOTO 160
23146 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23147 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23148 & (2D0*VINT(62+JT))
23149 PEI=SQRT(PZI**2+SQM)
23150 PQQP=(1D0-CHI)*(PEI+PZI)
23151 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23152 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23153 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23154 P(N-1,3)=P(N-1,4)*(-1)**JT
23155 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23156 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23157 ENDIF
23158
23159C...Documentation lines.
23160 K(I+2,1)=21
23161 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23162 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23163 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23164 K(I+2,3)=I
23165 P(I+2,3)=PZ*(-1)**(JT+1)
23166 P(I+2,4)=PE
23167 P(I+2,5)=SQRT(VINT(62+JT))
23168 200 CONTINUE
23169
23170C...Rotate outgoing partons/particles using cos(theta).
23171 IF(VINT(23).LT.0.9D0) THEN
23172 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23173 ELSE
23174 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23175 ENDIF
23176
23177 RETURN
23178 END
23179
23180C*********************************************************************
23181
23182C...PYDISG
23183C...Set up a DIS process as gamma* + f -> f, with beam remnant
23184C...and showering added consecutively. Photon flux by the PYGAGA
23185C...routine (if at all).
23186
23187 SUBROUTINE PYDISG
23188
23189C...Double precision and integer declarations.
23190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23191 IMPLICIT INTEGER(I-N)
23192 INTEGER PYK,PYCHGE,PYCOMP
23193C...Parameter statement to help give large particle numbers.
23194 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23195 &KEXCIT=4000000,KDIMEN=5000000)
23196C...Commonblocks.
23197 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23199 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23200 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23201 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23202 COMMON/PYINT1/MINT(400),VINT(400)
23203 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23204C...Local arrays.
23205 DIMENSION PMS(4)
23206
23207C...Choice of subprocess, number of documentation lines
23208 IDOC=7
23209 MINT(3)=IDOC-6
23210 MINT(4)=IDOC
23211 IPU1=MINT(84)+1
23212 IPU2=MINT(84)+2
23213 IPU3=MINT(84)+3
23214 ISIDE=1
23215 IF(MINT(107).EQ.4) ISIDE=2
23216
23217C...Reset K, P and V vectors. Store incoming particles
23218 DO 110 JT=1,MSTP(126)+20
23219 I=MINT(83)+JT
23220 DO 100 J=1,5
23221 K(I,J)=0
23222 P(I,J)=0D0
23223 V(I,J)=0D0
23224 100 CONTINUE
23225 110 CONTINUE
23226 DO 130 JT=1,2
23227 I=MINT(83)+JT
23228 K(I,1)=21
23229 K(I,2)=MINT(10+JT)
23230 DO 120 J=1,5
23231 P(I,J)=VINT(285+5*JT+J)
23232 120 CONTINUE
23233 130 CONTINUE
23234 MINT(6)=2
23235
23236C...Store incoming partons in hadronic CM-frame
23237 DO 140 JT=1,2
23238 I=MINT(84)+JT
23239 K(I,1)=14
23240 K(I,2)=MINT(14+JT)
23241 K(I,3)=MINT(83)+2+JT
23242 140 CONTINUE
23243 IF(MINT(15).EQ.22) THEN
23244 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23245 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23246 P(MINT(84)+1,5)=-SQRT(VINT(307))
23247 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23248 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23249 KFRES=MINT(16)
23250 ISIDE=2
23251 ELSE
23252 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23253 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23254 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23255 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23256 P(MINT(84)+1,5)=-SQRT(VINT(308))
23257 KFRES=MINT(15)
23258 ISIDE=1
23259 ENDIF
23260 SIDESG=(-1D0)**(ISIDE-1)
23261
23262C...Copy incoming partons to documentation lines.
23263 DO 170 JT=1,2
23264 I1=MINT(83)+4+JT
23265 I2=MINT(84)+JT
23266 K(I1,1)=21
23267 K(I1,2)=K(I2,2)
23268 K(I1,3)=I1-2
23269 DO 150 J=1,5
23270 P(I1,J)=P(I2,J)
23271 150 CONTINUE
23272
23273C...Second copy for partons before ISR shower, since no such.
23274 I1=MINT(83)+2+JT
23275 K(I1,1)=21
23276 K(I1,2)=K(I2,2)
23277 K(I1,3)=I1-2
23278 DO 160 J=1,5
23279 P(I1,J)=P(I2,J)
23280 160 CONTINUE
23281 170 CONTINUE
23282
23283C...Define initial partons.
23284 NTRY=0
23285 180 NTRY=NTRY+1
23286 IF(NTRY.GT.100) THEN
23287 MINT(51)=1
23288 RETURN
23289 ENDIF
23290
23291C...Scattered quark in hadronic CM frame.
23292 I=MINT(83)+7
23293 K(IPU3,1)=3
23294 K(IPU3,2)=KFRES
23295 K(IPU3,3)=I
23296 P(IPU3,5)=PYMASS(KFRES)
23297 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
23298 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
23299 P(IPU3,5)=0D0
23300 K(I,1)=21
23301 K(I,2)=KFRES
23302 K(I,3)=MINT(83)+4+ISIDE
23303 P(I,3)=P(IPU3,3)
23304 P(I,4)=P(IPU3,4)
23305 P(I,5)=P(IPU3,5)
23306 N=IPU3
23307 MINT(21)=KFRES
23308 MINT(22)=0
23309
23310C...No primordial kT, or chosen according to truncated Gaussian or
23311C...exponential, or (for photon) predetermined or power law.
23312 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
23313 IF(MSTP(91).LE.0) THEN
23314 PT=0D0
23315 ELSEIF(MSTP(91).EQ.1) THEN
23316 PT=PARP(91)*SQRT(-LOG(PYR(0)))
23317 ELSE
23318 RPT1=PYR(0)
23319 RPT2=PYR(0)
23320 PT=-PARP(92)*LOG(RPT1*RPT2)
23321 ENDIF
23322 IF(PT.GT.PARP(93)) GOTO 190
23323 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
23324 PTA=SQRT(VINT(282+ISIDE))
23325 PTB=0D0
23326 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
23327 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
23328 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
23329 RPT1=PYR(0)
23330 RPT2=PYR(0)
23331 PTB=-PARP(99)*LOG(RPT1*RPT2)
23332 ENDIF
23333 IF(PTB.GT.PARP(100)) GOTO 190
23334 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
23335 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
23336 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
23337 IF(MSTP(93).LE.0) THEN
23338 PT=0D0
23339 ELSEIF(MSTP(93).EQ.1) THEN
23340 PT=PARP(99)*SQRT(-LOG(PYR(0)))
23341 ELSEIF(MSTP(93).EQ.2) THEN
23342 RPT1=PYR(0)
23343 RPT2=PYR(0)
23344 PT=-PARP(99)*LOG(RPT1*RPT2)
23345 ELSEIF(MSTP(93).EQ.3) THEN
23346 HA=PARP(99)**2
23347 HB=PARP(100)**2
23348 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
23349 ELSE
23350 HA=PARP(99)**2
23351 HB=PARP(100)**2
23352 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
23353 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
23354 ENDIF
23355 IF(PT.GT.PARP(100)) GOTO 190
23356 ELSE
23357 PT=0D0
23358 ENDIF
23359 VINT(156+ISIDE)=PT
23360 PHI=PARU(2)*PYR(0)
23361 P(IPU3,1)=PT*COS(PHI)
23362 P(IPU3,2)=PT*SIN(PHI)
23363 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
23364 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
23365 PCP=P(IPU3,4)+ABS(P(IPU3,3))
23366
23367C...Find one or two beam remnants.
23368 MINT(105)=MINT(102+ISIDE)
23369 MINT(109)=MINT(106+ISIDE)
23370 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
23371 IF(MINT(51).NE.0) THEN
23372 MINT(51)=0
23373 GOTO 180
23374 ENDIF
23375
23376C...Store first remnant parton, with colour info and kinematics.
23377 I=N+1
23378 K(I,1)=1
23379 K(I,2)=KFLSP
23380 K(I,3)=MINT(83)+ISIDE
23381 P(I,5)=PYMASS(K(I,2))
23382 KCOL=KCHG(PYCOMP(KFLSP),2)
23383 IF(KCOL.NE.0) THEN
23384 K(I,1)=3
23385 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
23386 K(I,KFLS+3)=MSTU(5)*IPU3
23387 K(IPU3,6-KFLS)=MSTU(5)*I
23388 ICOLR=I
23389 ENDIF
23390 IF(KFLCH.EQ.0) THEN
23391 P(I,1)=-P(IPU3,1)
23392 P(I,2)=-P(IPU3,2)
23393 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23394 P(I,3)=-P(IPU3,3)
23395 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
23396 PRP=P(I,4)+ABS(P(I,3))
23397
23398C...When extra remnant parton or hadron: store extra remnant.
23399 ELSE
23400 I=I+1
23401 K(I,1)=1
23402 K(I,2)=KFLCH
23403 K(I,3)=MINT(83)+ISIDE
23404 P(I,5)=PYMASS(K(I,2))
23405 KCOL=KCHG(PYCOMP(KFLCH),2)
23406 IF(KCOL.NE.0) THEN
23407 K(I,1)=3
23408 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
23409 K(I,KFLS+3)=MSTU(5)*IPU3
23410 K(IPU3,6-KFLS)=MSTU(5)*I
23411 ICOLR=I
23412 ENDIF
23413
23414C...Relative transverse momentum when two remnants.
23415 LOOP=0
23416 200 LOOP=LOOP+1
23417 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
23418 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
23419 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
23420 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
23421 P(I,1)=-P(IPU3,1)-P(I-1,1)
23422 P(I,2)=-P(IPU3,2)-P(I-1,2)
23423 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23424
23425C...Relative distribution of energy for particle into jet plus particle.
23426 IMB=1
23427 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
23428 IF(MSTP(94).LE.1) THEN
23429 IF(IMB.EQ.1) CHI=PYR(0)
23430 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23431 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23432 ELSEIF(MSTP(94).EQ.2) THEN
23433 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
23434 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23435 ELSEIF(MSTP(94).EQ.3) THEN
23436 CALL PYZDIS(1,0,PMS(4),ZZ)
23437 CHI=ZZ
23438 ELSE
23439 CALL PYZDIS(1000,0,PMS(4),ZZ)
23440 CHI=ZZ
23441 ENDIF
23442
23443C...Construct total transverse mass; reject if too large.
23444 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
23445 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
23446 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
23447 IF(LOOP.LT.10) GOTO 200
23448 GOTO 180
23449 ENDIF
23450 VINT(158+ISIDE)=CHI
23451
23452C...Subdivide longitudinal momentum according to value selected above.
23453 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
23454 PW1=(1D0-CHI)*PRP
23455 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
23456 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
23457 PW2=CHI*PRP
23458 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
23459 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
23460 ENDIF
23461 N=I
23462
23463C...Boost current and remnant systems to correct frame.
23464 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
23465 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
23466 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
23467 &(2D0*VINT(1)*PCP)
23468 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
23469 &(2D0*VINT(1)*PRP)
23470 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
23471 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
23472 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
23473 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
23474
23475C...Let current quark shower; recoil but no showering by colour partner.
23476 QMAX=2D0*SQRT(VINT(309-ISIDE))
23477 MSTJ48=MSTJ(48)
23478 MSTJ(48)=1
23479 PARJ86=PARJ(86)
23480 PARJ(86)=0D0
23481 IF(MSTP(71).EQ.1) then
23482 if(parj(200).ne.1.) CALL PYSHOW(IPU3,ICOLR,QMAX)
23483 if(parj(200).eq.1.) CALL PYSHOWQ(IPU3,ICOLR,QMAX)
23484 endif
23485 MSTJ(48)=MSTJ48
23486 PARJ(86)=PARJ86
23487
23488 RETURN
23489 END
23490
23491C*********************************************************************
23492
23493C...PYDOCU
23494C...Handles the documentation of the process in MSTI and PARI,
23495C...and also computes cross-sections based on accumulated statistics.
23496
23497 SUBROUTINE PYDOCU
23498
23499C...Double precision and integer declarations.
23500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23501 IMPLICIT INTEGER(I-N)
23502 INTEGER PYK,PYCHGE,PYCOMP
23503C...Commonblocks.
23504 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23505 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23507 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23508 COMMON/PYINT1/MINT(400),VINT(400)
23509 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23510 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
23511 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
23512 &/PYINT5/
23513
23514C...Calculate Monte Carlo estimates of cross-sections.
23515 ISUB=MINT(1)
23516 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
23517 NGEN(0,3)=NGEN(0,3)+1
23518 XSEC(0,3)=0D0
23519 DO 100 I=1,500
23520 IF(I.EQ.96.OR.I.EQ.97) THEN
23521 XSEC(I,3)=0D0
23522 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
23523 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
23524 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23525 & DBLE(NGEN(96,2)))
23526 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
23527 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23528 & DBLE(NGEN(96,2)))
23529 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
23530 XSEC(I,3)=0D0
23531 ELSEIF(NGEN(I,2).EQ.0) THEN
23532 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
23533 & DBLE(NGEN(0,2)))
23534 ELSE
23535 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
23536 & DBLE(NGEN(I,2)))
23537 ENDIF
23538 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
23539 100 CONTINUE
23540
23541C...Rescale to known low-pT cross-section for standard QCD processes.
23542 IF(MSUB(95).EQ.1) THEN
23543 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
23544 & XSEC(68,3)+XSEC(95,3)
23545 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
23546 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
23547 FAC=XSECW/XSECH
23548 XSEC(11,3)=FAC*XSEC(11,3)
23549 XSEC(12,3)=FAC*XSEC(12,3)
23550 XSEC(13,3)=FAC*XSEC(13,3)
23551 XSEC(28,3)=FAC*XSEC(28,3)
23552 XSEC(53,3)=FAC*XSEC(53,3)
23553 XSEC(68,3)=FAC*XSEC(68,3)
23554 XSEC(95,3)=FAC*XSEC(95,3)
23555 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
23556 ENDIF
23557 ENDIF
23558
23559C...Save information for gamma-p and gamma-gamma.
23560 IF(MINT(121).GT.1) THEN
23561 IGA=MINT(122)
23562 CALL PYSAVE(2,IGA)
23563 CALL PYSAVE(5,0)
23564 ENDIF
23565
23566C...Reset information on hard interaction.
23567 DO 110 J=1,200
23568 MSTI(J)=0
23569 PARI(J)=0D0
23570 110 CONTINUE
23571
23572C...Copy integer valued information from MINT into MSTI.
23573 DO 120 J=1,32
23574 MSTI(J)=MINT(J)
23575 120 CONTINUE
23576 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
23577
23578C...Store cross-section variables in PARI.
23579 PARI(1)=XSEC(0,3)
23580 PARI(2)=XSEC(0,3)/MINT(5)
23581 PARI(7)=VINT(97)
23582 PARI(9)=VINT(99)
23583 PARI(10)=VINT(100)
23584 VINT(98)=VINT(98)+VINT(100)
23585 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
23586
23587C...Store kinematics variables in PARI.
23588 PARI(11)=VINT(1)
23589 PARI(12)=VINT(2)
23590 IF(ISUB.NE.95) THEN
23591 DO 130 J=13,26
23592 PARI(J)=VINT(30+J)
23593 130 CONTINUE
23594 PARI(29)=VINT(39)
23595 PARI(30)=VINT(40)
23596 PARI(31)=VINT(141)
23597 PARI(32)=VINT(142)
23598 PARI(33)=VINT(41)
23599 PARI(34)=VINT(42)
23600 PARI(35)=PARI(33)-PARI(34)
23601 PARI(36)=VINT(21)
23602 PARI(37)=VINT(22)
23603 PARI(38)=VINT(26)
23604 PARI(39)=VINT(157)
23605 PARI(40)=VINT(158)
23606 PARI(41)=VINT(23)
23607 PARI(42)=2D0*VINT(47)/VINT(1)
23608 ENDIF
23609
23610C...Store information on scattered partons in PARI.
23611 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
23612 DO 140 IS=7,8
23613 I=MINT(IS)
23614 PARI(36+IS)=P(I,3)/VINT(1)
23615 PARI(38+IS)=P(I,4)/VINT(1)
23616 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23617 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23618 & SQRT(PR),1D20)),P(I,3))
23619 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23620 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23621 & SQRT(PR),1D20)),P(I,3))
23622 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23623 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23624 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23625 140 CONTINUE
23626 ENDIF
23627
23628C...Store sum up transverse and longitudinal momenta.
23629 PARI(65)=2D0*PARI(17)
23630 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23631 DO 150 I=MSTP(126)+1,N
23632 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23633 PT=SQRT(P(I,1)**2+P(I,2)**2)
23634 PARI(69)=PARI(69)+PT
23635 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23636 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23637 150 CONTINUE
23638 PARI(67)=PARI(68)
23639 PARI(71)=VINT(151)
23640 PARI(72)=VINT(152)
23641 PARI(73)=VINT(151)
23642 PARI(74)=VINT(152)
23643 ELSE
23644 PARI(66)=PARI(65)
23645 PARI(69)=PARI(65)
23646 ENDIF
23647
23648C...Store various other pieces of information into PARI.
23649 PARI(61)=VINT(148)
23650 PARI(75)=VINT(155)
23651 PARI(76)=VINT(156)
23652 PARI(77)=VINT(159)
23653 PARI(78)=VINT(160)
23654 PARI(81)=VINT(138)
23655
23656C...Store information on lepton -> lepton + gamma in PYGAGA.
23657 MSTI(71)=MINT(141)
23658 MSTI(72)=MINT(142)
23659 PARI(101)=VINT(301)
23660 PARI(102)=VINT(302)
23661 DO 160 I=103,114
23662 PARI(I)=VINT(I+202)
23663 160 CONTINUE
23664
23665C...Set information for PYTABU.
23666 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23667 MSTU(161)=MINT(21)
23668 MSTU(162)=0
23669 ELSEIF(ISET(ISUB).EQ.5) THEN
23670 MSTU(161)=MINT(23)
23671 MSTU(162)=0
23672 ELSE
23673 MSTU(161)=MINT(21)
23674 MSTU(162)=MINT(22)
23675 ENDIF
23676
23677 RETURN
23678 END
23679
23680C*********************************************************************
23681
23682C...PYFRAM
23683C...Performs transformations between different coordinate frames.
23684
23685 SUBROUTINE PYFRAM(IFRAME)
23686
23687C...Double precision and integer declarations.
23688 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23689 IMPLICIT INTEGER(I-N)
23690 INTEGER PYK,PYCHGE,PYCOMP
23691C...Commonblocks.
23692 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23693 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23694 COMMON/PYINT1/MINT(400),VINT(400)
23695 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23696
23697C...Check that transformation can and should be done.
23698 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23699 &MINT(91).EQ.1)) THEN
23700 IF(IFRAME.EQ.MINT(6)) RETURN
23701 ELSE
23702 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23703 RETURN
23704 ENDIF
23705
23706 IF(MINT(6).EQ.1) THEN
23707C...Transform from fixed target or user specified frame to
23708C...overall CM frame.
23709 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23710 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23711 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23712 ELSEIF(MINT(6).EQ.3) THEN
23713C...Transform from hadronic CM frame in DIS to overall CM frame.
23714 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23715 & -VINT(225))
23716 ENDIF
23717
23718 IF(IFRAME.EQ.1) THEN
23719C...Transform from overall CM frame to fixed target or user specified
23720C...frame.
23721 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23722 ELSEIF(IFRAME.EQ.3) THEN
23723C...Transform from overall CM frame to hadronic CM frame in DIS.
23724 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23725 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23726 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23727 ENDIF
23728
23729C...Set information about new frame.
23730 MINT(6)=IFRAME
23731 MSTI(6)=IFRAME
23732
23733 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23734 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23735 &1X,I5)
23736
23737 RETURN
23738 END
23739
23740C*********************************************************************
23741
23742C...PYWIDT
23743C...Calculates full and partial widths of resonances.
23744
23745 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23746
23747C...Double precision and integer declarations.
23748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23749 IMPLICIT INTEGER(I-N)
23750 INTEGER PYK,PYCHGE,PYCOMP
23751C...Parameter statement to help give large particle numbers.
23752 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23753 &KEXCIT=4000000,KDIMEN=5000000)
23754C...Commonblocks.
23755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23756 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23757 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23758 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23759 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23760 COMMON/PYINT1/MINT(400),VINT(400)
23761 COMMON/PYINT4/MWID(500),WIDS(500,5)
23762 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23763 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23764 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23765 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23766 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23767 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23768C...Local arrays and saved variables.
23769 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23770 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23771 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23772 SAVE MOFSV,WIDWSV,WID2SV
23773 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23774
23775C...Compressed code and sign; mass.
23776 KFLA=IABS(KFLR)
23777 KFLS=ISIGN(1,KFLR)
23778 KC=PYCOMP(KFLA)
23779 SHR=SQRT(SH)
23780 PMR=PMAS(KC,1)
23781
23782C...Reset width information.
23783 DO 110 I=0,MDCY(KC,3)
23784 WDTP(I)=0D0
23785 DO 100 J=0,5
23786 WDTE(I,J)=0D0
23787 100 CONTINUE
23788 110 CONTINUE
23789
23790C...Allow for fudge factor to rescale resonance width.
23791 FUDGE=1D0
23792 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23793 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23794 IF(MSTP(110).EQ.KFLA) THEN
23795 FUDGE=PARP(110)
23796 ELSEIF(MSTP(110).EQ.-1) THEN
23797 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23798 ELSEIF(MSTP(110).EQ.-2) THEN
23799 FUDGE=PARP(110)
23800 ENDIF
23801 ENDIF
23802
23803C...Not to be treated as a resonance: return.
23804 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23805 &KFLA.NE.22) THEN
23806 WDTP(0)=1D0
23807 WDTE(0,0)=1D0
23808 MINT(61)=0
23809 MINT(62)=0
23810 MINT(63)=0
23811 RETURN
23812
23813C...Treatment as a resonance based on tabulated branching ratios.
23814 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23815C...Loop over possible decay channels; skip irrelevant ones.
23816 DO 120 I=1,MDCY(KC,3)
23817 IDC=I+MDCY(KC,2)-1
23818 IF(MDME(IDC,1).LT.0) GOTO 120
23819
23820C...Read out decay products and nominal masses.
23821 KFD1=KFDP(IDC,1)
23822 KFC1=PYCOMP(KFD1)
23823 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23824 PM1=PMAS(KFC1,1)
23825 KFD2=KFDP(IDC,2)
23826 KFC2=PYCOMP(KFD2)
23827 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23828 PM2=PMAS(KFC2,1)
23829 KFD3=KFDP(IDC,3)
23830 PM3=0D0
23831 IF(KFD3.NE.0) THEN
23832 KFC3=PYCOMP(KFD3)
23833 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23834 PM3=PMAS(KFC3,1)
23835 ENDIF
23836
23837C...Naive partial width and alternative threshold factors.
23838 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23839 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23840 & PM1+PM2+PM3.GE.SHR) THEN
23841 WDTP(I)=0D0
23842 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23843 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23844 & 4D0*PM1**2*PM2**2))/SH
23845 ELSEIF(MDME(IDC,2).EQ.52) THEN
23846 PMA=MAX(PM1,PM2,PM3)
23847 PMC=MIN(PM1,PM2,PM3)
23848 PMB=PM1+PM2+PM3-PMA-PMC
23849 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23850 PMAN=PMA**2/SH
23851 PMBN=PMB**2/SH
23852 PMCN=PMC**2/SH
23853 PMBCN=PMBC**2/SH
23854 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23855 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23856 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23857 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23858 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23859 & ((1D0-PMBCN)*PMBCN*SH)
23860 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23861 WDTP(I)=WDTP(I)*SQRT(
23862 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23863 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23864 ELSEIF(MDME(IDC,2).EQ.53) THEN
23865 PMA=MAX(PM1,PM2,PM3)
23866 PMC=MIN(PM1,PM2,PM3)
23867 PMB=PM1+PM2+PM3-PMA-PMC
23868 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23869 PMAN=PMA**2/SH
23870 PMBN=PMB**2/SH
23871 PMCN=PMC**2/SH
23872 PMBCN=PMBC**2/SH
23873 FACACT=SQRT(MAX(0D0,
23874 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23875 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23876 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23877 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23878 & ((1D0-PMBCN)*PMBCN*SH)
23879 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23880 PMAN=PMA**2/PMR**2
23881 PMBN=PMB**2/PMR**2
23882 PMCN=PMC**2/PMR**2
23883 PMBCN=PMBC**2/PMR**2
23884 FACNOM=SQRT(MAX(0D0,
23885 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23886 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23887 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23888 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23889 & ((1D0-PMBCN)*PMBCN*PMR**2)
23890 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23891 ENDIF
23892 WDTP(I)=FUDGE*WDTP(I)
23893 WDTP(0)=WDTP(0)+WDTP(I)
23894
23895C...Calculate secondary width (at most two identical/opposite).
23896 WID2=1D0
23897 IF(MDME(IDC,1).GT.0) THEN
23898 IF(KFD2.EQ.KFD1) THEN
23899 IF(KCHG(KFC1,3).EQ.0) THEN
23900 WID2=WIDS(KFC1,1)
23901 ELSEIF(KFD1.GT.0) THEN
23902 WID2=WIDS(KFC1,4)
23903 ELSE
23904 WID2=WIDS(KFC1,5)
23905 ENDIF
23906 IF(KFD3.GT.0) THEN
23907 WID2=WID2*WIDS(KFC3,2)
23908 ELSEIF(KFD3.LT.0) THEN
23909 WID2=WID2*WIDS(KFC3,3)
23910 ENDIF
23911 ELSEIF(KFD2.EQ.-KFD1) THEN
23912 WID2=WIDS(KFC1,1)
23913 IF(KFD3.GT.0) THEN
23914 WID2=WID2*WIDS(KFC3,2)
23915 ELSEIF(KFD3.LT.0) THEN
23916 WID2=WID2*WIDS(KFC3,3)
23917 ENDIF
23918 ELSEIF(KFD3.EQ.KFD1) THEN
23919 IF(KCHG(KFC1,3).EQ.0) THEN
23920 WID2=WIDS(KFC1,1)
23921 ELSEIF(KFD1.GT.0) THEN
23922 WID2=WIDS(KFC1,4)
23923 ELSE
23924 WID2=WIDS(KFC1,5)
23925 ENDIF
23926 IF(KFD2.GT.0) THEN
23927 WID2=WID2*WIDS(KFC2,2)
23928 ELSEIF(KFD2.LT.0) THEN
23929 WID2=WID2*WIDS(KFC2,3)
23930 ENDIF
23931 ELSEIF(KFD3.EQ.-KFD1) THEN
23932 WID2=WIDS(KFC1,1)
23933 IF(KFD2.GT.0) THEN
23934 WID2=WID2*WIDS(KFC2,2)
23935 ELSEIF(KFD2.LT.0) THEN
23936 WID2=WID2*WIDS(KFC2,3)
23937 ENDIF
23938 ELSEIF(KFD3.EQ.KFD2) THEN
23939 IF(KCHG(KFC2,3).EQ.0) THEN
23940 WID2=WIDS(KFC2,1)
23941 ELSEIF(KFD2.GT.0) THEN
23942 WID2=WIDS(KFC2,4)
23943 ELSE
23944 WID2=WIDS(KFC2,5)
23945 ENDIF
23946 IF(KFD1.GT.0) THEN
23947 WID2=WID2*WIDS(KFC1,2)
23948 ELSEIF(KFD1.LT.0) THEN
23949 WID2=WID2*WIDS(KFC1,3)
23950 ENDIF
23951 ELSEIF(KFD3.EQ.-KFD2) THEN
23952 WID2=WIDS(KFC2,1)
23953 IF(KFD1.GT.0) THEN
23954 WID2=WID2*WIDS(KFC1,2)
23955 ELSEIF(KFD1.LT.0) THEN
23956 WID2=WID2*WIDS(KFC1,3)
23957 ENDIF
23958 ELSE
23959 IF(KFD1.GT.0) THEN
23960 WID2=WIDS(KFC1,2)
23961 ELSE
23962 WID2=WIDS(KFC1,3)
23963 ENDIF
23964 IF(KFD2.GT.0) THEN
23965 WID2=WID2*WIDS(KFC2,2)
23966 ELSE
23967 WID2=WID2*WIDS(KFC2,3)
23968 ENDIF
23969 IF(KFD3.GT.0) THEN
23970 WID2=WID2*WIDS(KFC3,2)
23971 ELSEIF(KFD3.LT.0) THEN
23972 WID2=WID2*WIDS(KFC3,3)
23973 ENDIF
23974 ENDIF
23975
23976C...Store effective widths according to case.
23977 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23978 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23979 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23980 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23981 ENDIF
23982 120 CONTINUE
23983C...Return.
23984 MINT(61)=0
23985 MINT(62)=0
23986 MINT(63)=0
23987 RETURN
23988 ENDIF
23989
23990C...Here begins detailed dynamical calculation of resonance widths.
23991C...Shared treatment of Higgs states.
23992 KFHIGG=25
23993 IHIGG=1
23994 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23995 KFHIGG=KFLA
23996 IHIGG=KFLA-33
23997 ENDIF
23998
23999C...Common electroweak and strong constants.
24000 XW=PARU(102)
24001 XWV=XW
24002 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24003 XW1=1D0-XW
24004 AEM=PYALEM(SH)
24005 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24006 AS=PYALPS(SH)
24007 RADC=1D0+AS/PARU(1)
24008
24009 IF(KFLA.EQ.6) THEN
24010C...t quark.
24011 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24012 RADCT=1D0-2.5D0*AS/PARU(1)
24013 DO 140 I=1,MDCY(KC,3)
24014 IDC=I+MDCY(KC,2)-1
24015 IF(MDME(IDC,1).LT.0) GOTO 140
24016 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24017 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24018 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24019 WID2=1D0
24020 IF(I.GE.4.AND.I.LE.7) THEN
24021C...t -> W + q; including approximate QCD correction factor.
24022 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24023 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24024 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24025 IF(KFLR.GT.0) THEN
24026 WID2=WIDS(24,2)
24027 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24028 ELSE
24029 WID2=WIDS(24,3)
24030 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24031 ENDIF
24032 ELSEIF(I.EQ.9) THEN
24033C...t -> H + b.
24034 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24035 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24036 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24037 & 4D0*SQRT(RM2R*RM2))
24038 WID2=WIDS(37,2)
24039 IF(KFLR.LT.0) WID2=WIDS(37,3)
24040CMRENNA++
24041 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24042C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24043 BETA=ATAN(RMSS(5))
24044 SINB=SIN(BETA)
24045 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24046 ET=KCHG(6,1)/3D0
24047 T3L=SIGN(0.5D0,ET)
24048 KFC1=PYCOMP(KFDP(IDC,1))
24049 KFC2=PYCOMP(KFDP(IDC,2))
24050 PMNCHI=PMAS(KFC1,1)
24051 PMSTOP=PMAS(KFC2,1)
24052 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24053 IZ=I-9
24054 DO 130 IK=1,4
24055 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24056 130 CONTINUE
24057 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24058 AR=-ET*ZMIXC(IZ,1)*TANW
24059 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24060 BR=AL
24061 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24062 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24063 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24064 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24065 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24066 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24067 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24068 IF(KFLR.GT.0) THEN
24069 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24070 ELSE
24071 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24072 ENDIF
24073 ENDIF
24074 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24075C...t -> ~g + ~t
24076 KFC1=PYCOMP(KFDP(IDC,1))
24077 KFC2=PYCOMP(KFDP(IDC,2))
24078 PMNCHI=PMAS(KFC1,1)
24079 PMSTOP=PMAS(KFC2,1)
24080 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24081 RL=SFMIX(6,1)
24082 RR=-SFMIX(6,2)
24083 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24084 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24085 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24086 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24087 IF(KFLR.GT.0) THEN
24088 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24089 ELSE
24090 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24091 ENDIF
24092 ENDIF
24093 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24094C...t -> ~gravitino + ~t
24095 XMP2=RMSS(29)**2
24096 KFC1=PYCOMP(KFDP(IDC,1))
24097 XMGR2=PMAS(KFC1,1)**2
24098 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24099 KFC2=PYCOMP(KFDP(IDC,2))
24100 WID2=WIDS(KFC2,2)
24101 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24102CMRENNA--
24103 ENDIF
24104 WDTP(I)=FUDGE*WDTP(I)
24105 WDTP(0)=WDTP(0)+WDTP(I)
24106 IF(MDME(IDC,1).GT.0) THEN
24107 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24108 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24109 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24110 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24111 ENDIF
24112 140 CONTINUE
24113
24114 ELSEIF(KFLA.EQ.7) THEN
24115C...b' quark.
24116 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24117 DO 150 I=1,MDCY(KC,3)
24118 IDC=I+MDCY(KC,2)-1
24119 IF(MDME(IDC,1).LT.0) GOTO 150
24120 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24121 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24122 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24123 WID2=1D0
24124 IF(I.GE.4.AND.I.LE.7) THEN
24125C...b' -> W + q.
24126 WDTP(I)=FAC*VCKM(I-3,4)*
24127 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24128 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24129 IF(KFLR.GT.0) THEN
24130 WID2=WIDS(24,3)
24131 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24132 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24133 ELSE
24134 WID2=WIDS(24,2)
24135 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24136 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24137 ENDIF
24138 WID2=WIDS(24,3)
24139 IF(KFLR.LT.0) WID2=WIDS(24,2)
24140 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24141C...b' -> H + q.
24142 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24143 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24144 IF(KFLR.GT.0) THEN
24145 WID2=WIDS(37,3)
24146 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24147 ELSE
24148 WID2=WIDS(37,2)
24149 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24150 ENDIF
24151 ENDIF
24152 WDTP(I)=FUDGE*WDTP(I)
24153 WDTP(0)=WDTP(0)+WDTP(I)
24154 IF(MDME(IDC,1).GT.0) THEN
24155 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24156 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24157 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24158 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24159 ENDIF
24160 150 CONTINUE
24161
24162 ELSEIF(KFLA.EQ.8) THEN
24163C...t' quark.
24164 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24165 DO 160 I=1,MDCY(KC,3)
24166 IDC=I+MDCY(KC,2)-1
24167 IF(MDME(IDC,1).LT.0) GOTO 160
24168 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24169 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24170 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24171 WID2=1D0
24172 IF(I.GE.4.AND.I.LE.7) THEN
24173C...t' -> W + q.
24174 WDTP(I)=FAC*VCKM(4,I-3)*
24175 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24176 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24177 IF(KFLR.GT.0) THEN
24178 WID2=WIDS(24,2)
24179 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24180 ELSE
24181 WID2=WIDS(24,3)
24182 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24183 ENDIF
24184 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24185C...t' -> H + q.
24186 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24187 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24188 IF(KFLR.GT.0) THEN
24189 WID2=WIDS(37,2)
24190 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24191 ELSE
24192 WID2=WIDS(37,3)
24193 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24194 ENDIF
24195 ENDIF
24196 WDTP(I)=FUDGE*WDTP(I)
24197 WDTP(0)=WDTP(0)+WDTP(I)
24198 IF(MDME(IDC,1).GT.0) THEN
24199 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24200 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24201 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24202 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24203 ENDIF
24204 160 CONTINUE
24205
24206 ELSEIF(KFLA.EQ.17) THEN
24207C...tau' lepton.
24208 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24209 DO 170 I=1,MDCY(KC,3)
24210 IDC=I+MDCY(KC,2)-1
24211 IF(MDME(IDC,1).LT.0) GOTO 170
24212 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24213 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24214 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24215 WID2=1D0
24216 IF(I.EQ.3) THEN
24217C...tau' -> W + nu'_tau.
24218 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24219 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24220 IF(KFLR.GT.0) THEN
24221 WID2=WIDS(24,3)
24222 WID2=WID2*WIDS(18,2)
24223 ELSE
24224 WID2=WIDS(24,2)
24225 WID2=WID2*WIDS(18,3)
24226 ENDIF
24227 ELSEIF(I.EQ.5) THEN
24228C...tau' -> H + nu'_tau.
24229 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24230 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24231 IF(KFLR.GT.0) THEN
24232 WID2=WIDS(37,3)
24233 WID2=WID2*WIDS(18,2)
24234 ELSE
24235 WID2=WIDS(37,2)
24236 WID2=WID2*WIDS(18,3)
24237 ENDIF
24238 ENDIF
24239 WDTP(I)=FUDGE*WDTP(I)
24240 WDTP(0)=WDTP(0)+WDTP(I)
24241 IF(MDME(IDC,1).GT.0) THEN
24242 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24243 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24244 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24245 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24246 ENDIF
24247 170 CONTINUE
24248
24249 ELSEIF(KFLA.EQ.18) THEN
24250C...nu'_tau neutrino.
24251 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24252 DO 180 I=1,MDCY(KC,3)
24253 IDC=I+MDCY(KC,2)-1
24254 IF(MDME(IDC,1).LT.0) GOTO 180
24255 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24256 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24257 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24258 WID2=1D0
24259 IF(I.EQ.2) THEN
24260C...nu'_tau -> W + tau'.
24261 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24262 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24263 IF(KFLR.GT.0) THEN
24264 WID2=WIDS(24,2)
24265 WID2=WID2*WIDS(17,2)
24266 ELSE
24267 WID2=WIDS(24,3)
24268 WID2=WID2*WIDS(17,3)
24269 ENDIF
24270 ELSEIF(I.EQ.3) THEN
24271C...nu'_tau -> H + tau'.
24272 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24273 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24274 IF(KFLR.GT.0) THEN
24275 WID2=WIDS(37,2)
24276 WID2=WID2*WIDS(17,2)
24277 ELSE
24278 WID2=WIDS(37,3)
24279 WID2=WID2*WIDS(17,3)
24280 ENDIF
24281 ENDIF
24282 WDTP(I)=FUDGE*WDTP(I)
24283 WDTP(0)=WDTP(0)+WDTP(I)
24284 IF(MDME(IDC,1).GT.0) THEN
24285 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24286 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24287 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24288 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24289 ENDIF
24290 180 CONTINUE
24291
24292 ELSEIF(KFLA.EQ.21) THEN
24293C...QCD:
24294C***Note that widths are not given in dimensional quantities here.
24295 DO 190 I=1,MDCY(KC,3)
24296 IDC=I+MDCY(KC,2)-1
24297 IF(MDME(IDC,1).LT.0) GOTO 190
24298 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24299 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24300 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
24301 WID2=1D0
24302 IF(I.LE.8) THEN
24303C...QCD -> q + qbar
24304 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24305 IF(I.EQ.6) WID2=WIDS(6,1)
24306 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24307 ENDIF
24308 WDTP(I)=FUDGE*WDTP(I)
24309 WDTP(0)=WDTP(0)+WDTP(I)
24310 IF(MDME(IDC,1).GT.0) THEN
24311 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24312 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24313 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24314 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24315 ENDIF
24316 190 CONTINUE
24317
24318 ELSEIF(KFLA.EQ.22) THEN
24319C...QED photon.
24320C***Note that widths are not given in dimensional quantities here.
24321 DO 200 I=1,MDCY(KC,3)
24322 IDC=I+MDCY(KC,2)-1
24323 IF(MDME(IDC,1).LT.0) GOTO 200
24324 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24325 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24326 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
24327 WID2=1D0
24328 IF(I.LE.8) THEN
24329C...QED -> q + qbar.
24330 EF=KCHG(I,1)/3D0
24331 FCOF=3D0*RADC
24332 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24333 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24334 IF(I.EQ.6) WID2=WIDS(6,1)
24335 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24336 ELSEIF(I.LE.12) THEN
24337C...QED -> l+ + l-.
24338 EF=KCHG(9+2*(I-8),1)/3D0
24339 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24340 IF(I.EQ.12) WID2=WIDS(17,1)
24341 ENDIF
24342 WDTP(I)=FUDGE*WDTP(I)
24343 WDTP(0)=WDTP(0)+WDTP(I)
24344 IF(MDME(IDC,1).GT.0) THEN
24345 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24346 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24347 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24348 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24349 ENDIF
24350 200 CONTINUE
24351
24352 ELSEIF(KFLA.EQ.23) THEN
24353C...Z0:
24354 ICASE=1
24355 XWC=1D0/(16D0*XW*XW1)
24356 FAC=(AEM*XWC/3D0)*SHR
24357 210 CONTINUE
24358 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24359 VINT(111)=0D0
24360 VINT(112)=0D0
24361 VINT(114)=0D0
24362 ENDIF
24363 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24364 KFI=IABS(MINT(15))
24365 IF(KFI.GT.20) KFI=IABS(MINT(16))
24366 EI=KCHG(KFI,1)/3D0
24367 AI=SIGN(1D0,EI)
24368 VI=AI-4D0*EI*XWV
24369 SQMZ=PMAS(23,1)**2
24370 HZ=SHR*WDTP(0)
24371 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
24372 IF(MSTP(43).EQ.3) VINT(112)=
24373 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24374 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24375 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24376 ENDIF
24377 DO 220 I=1,MDCY(KC,3)
24378 IDC=I+MDCY(KC,2)-1
24379 IF(MDME(IDC,1).LT.0) GOTO 220
24380 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24381 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24382 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
24383 WID2=1D0
24384 IF(I.LE.8) THEN
24385C...Z0 -> q + qbar
24386 EF=KCHG(I,1)/3D0
24387 AF=SIGN(1D0,EF+0.1D0)
24388 VF=AF-4D0*EF*XWV
24389 FCOF=3D0*RADC
24390 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24391 IF(I.EQ.6) WID2=WIDS(6,1)
24392 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24393 ELSEIF(I.LE.16) THEN
24394C...Z0 -> l+ + l-, nu + nubar
24395 EF=KCHG(I+2,1)/3D0
24396 AF=SIGN(1D0,EF+0.1D0)
24397 VF=AF-4D0*EF*XWV
24398 FCOF=1D0
24399 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24400 ENDIF
24401 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24402 IF(ICASE.EQ.1) THEN
24403 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
24404 & BE34
24405 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24406 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24407 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
24408 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
24409 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24410 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24411 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24412 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24413 ENDIF
24414 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
24415 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
24416 IF(MDME(IDC,1).GT.0) THEN
24417 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24418 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24419 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24420 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24421 & WDTE(I,MDME(IDC,1))
24422 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24423 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24424 ENDIF
24425 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24426 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
24427 & VINT(111)+FGGF*WID2
24428 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
24429 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24430 & VINT(114)+FZZF*WID2
24431 ENDIF
24432 ENDIF
24433 220 CONTINUE
24434 IF(MINT(61).GE.1) ICASE=3-ICASE
24435 IF(ICASE.EQ.2) GOTO 210
24436
24437 ELSEIF(KFLA.EQ.24) THEN
24438C...W+/-:
24439 FAC=(AEM/(24D0*XW))*SHR
24440 DO 230 I=1,MDCY(KC,3)
24441 IDC=I+MDCY(KC,2)-1
24442 IF(MDME(IDC,1).LT.0) GOTO 230
24443 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24444 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
24446 WID2=1D0
24447 IF(I.LE.16) THEN
24448C...W+/- -> q + qbar'
24449 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
24450 IF(KFLR.GT.0) THEN
24451 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24452 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24453 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24454 ELSE
24455 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24456 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24457 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24458 ENDIF
24459 ELSEIF(I.LE.20) THEN
24460C...W+/- -> l+/- + nu
24461 FCOF=1D0
24462 IF(KFLR.GT.0) THEN
24463 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24464 ELSE
24465 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24466 ENDIF
24467 ENDIF
24468 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24469 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24470 WDTP(I)=FUDGE*WDTP(I)
24471 WDTP(0)=WDTP(0)+WDTP(I)
24472 IF(MDME(IDC,1).GT.0) THEN
24473 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24474 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24475 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24476 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24477 ENDIF
24478 230 CONTINUE
24479
24480 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24481C...h0 (or H0, or A0):
24482 SHFS=SH
24483 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24484 DO 270 I=1,MDCY(KFHIGG,3)
24485 IDC=I+MDCY(KFHIGG,2)-1
24486 IF(MDME(IDC,1).LT.0) GOTO 270
24487 KFC1=PYCOMP(KFDP(IDC,1))
24488 KFC2=PYCOMP(KFDP(IDC,2))
24489 RM1=PMAS(KFC1,1)**2/SH
24490 RM2=PMAS(KFC2,1)**2/SH
24491 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
24492 & GOTO 270
24493 WID2=1D0
24494
24495 IF(I.LE.8) THEN
24496C...h0 -> q + qbar
24497 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
24498 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
24499C...A0 behaves like beta, ho and H0 like beta**3.
24500 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24501 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24502 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
24503 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
24504 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
24505 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
24506 IF(IHIGG.NE.3) THEN
24507 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24508 & PARU(151+10*IHIGG))**2
24509 ENDIF
24510 ENDIF
24511 ENDIF
24512 IF(I.EQ.6) WID2=WIDS(6,1)
24513 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24514 ELSEIF(I.LE.12) THEN
24515C...h0 -> l+ + l-
24516 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
24517C...A0 behaves like beta, ho and H0 like beta**3.
24518 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24519 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24520 & PARU(153+10*IHIGG)**2
24521 IF(I.EQ.12) WID2=WIDS(17,1)
24522
24523 ELSEIF(I.EQ.13) THEN
24524C...h0 -> g + g; quark loop contribution only
24525 ETARE=0D0
24526 ETAIM=0D0
24527 DO 240 J=1,2*MSTP(1)
24528 EPS=(2D0*PMAS(J,1))**2/SH
24529C...Loop integral; function of eps=4m^2/shat; different for A0.
24530 IF(EPS.LE.1D0) THEN
24531 IF(EPS.GT.1D-4) THEN
24532 ROOT=SQRT(1D0-EPS)
24533 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24534 ELSE
24535 RLN=LOG(4D0/EPS-2D0)
24536 ENDIF
24537 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24538 PHIIM=0.5D0*PARU(1)*RLN
24539 ELSE
24540 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24541 PHIIM=0D0
24542 ENDIF
24543 IF(IHIGG.LE.2) THEN
24544 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24545 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
24546 ELSE
24547 ETAREJ=-0.5D0*EPS*PHIRE
24548 ETAIMJ=-0.5D0*EPS*PHIIM
24549 ENDIF
24550C...Couplings (=1 for standard model Higgs).
24551 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24552 IF(MOD(J,2).EQ.1) THEN
24553 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
24554 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
24555 ELSE
24556 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
24557 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
24558 ENDIF
24559 ENDIF
24560 ETARE=ETARE+ETAREJ
24561 ETAIM=ETAIM+ETAIMJ
24562 240 CONTINUE
24563 ETA2=ETARE**2+ETAIM**2
24564 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
24565
24566 ELSEIF(I.EQ.14) THEN
24567C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
24568 ETARE=0D0
24569 ETAIM=0D0
24570 JMAX=3*MSTP(1)+1
24571 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24572 DO 250 J=1,JMAX
24573 IF(J.LE.2*MSTP(1)) THEN
24574 EJ=KCHG(J,1)/3D0
24575 EPS=(2D0*PMAS(J,1))**2/SH
24576 ELSEIF(J.LE.3*MSTP(1)) THEN
24577 JL=2*(J-2*MSTP(1))-1
24578 EJ=KCHG(10+JL,1)/3D0
24579 EPS=(2D0*PMAS(10+JL,1))**2/SH
24580 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24581 EPS=(2D0*PMAS(24,1))**2/SH
24582 ELSE
24583 EPS=(2D0*PMAS(37,1))**2/SH
24584 ENDIF
24585C...Loop integral; function of eps=4m^2/shat.
24586 IF(EPS.LE.1D0) THEN
24587 IF(EPS.GT.1D-4) THEN
24588 ROOT=SQRT(1D0-EPS)
24589 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24590 ELSE
24591 RLN=LOG(4D0/EPS-2D0)
24592 ENDIF
24593 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24594 PHIIM=0.5D0*PARU(1)*RLN
24595 ELSE
24596 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24597 PHIIM=0D0
24598 ENDIF
24599 IF(J.LE.3*MSTP(1)) THEN
24600C...Fermion loops: loop integral different for A0; charges.
24601 IF(IHIGG.LE.2) THEN
24602 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24603 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
24604 ELSE
24605 PHIPRE=-0.5D0*EPS*PHIRE
24606 PHIPIM=-0.5D0*EPS*PHIIM
24607 ENDIF
24608 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24609 EJC=3D0*EJ**2
24610 EJH=PARU(151+10*IHIGG)
24611 ELSEIF(J.LE.2*MSTP(1)) THEN
24612 EJC=3D0*EJ**2
24613 EJH=PARU(152+10*IHIGG)
24614 ELSE
24615 EJC=EJ**2
24616 EJH=PARU(153+10*IHIGG)
24617 ENDIF
24618 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24619 ETAREJ=EJC*EJH*PHIPRE
24620 ETAIMJ=EJC*EJH*PHIPIM
24621 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24622C...W loops: loop integral and charges.
24623 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24624 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24625 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24626 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24627 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24628 ENDIF
24629 ELSE
24630C...Charged H loops: loop integral and charges.
24631 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24632 & PARU(158+10*IHIGG+2*(IHIGG/3))
24633 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24634 ETAIMJ=-EPS**2*PHIIM*FACHHH
24635 ENDIF
24636 ETARE=ETARE+ETAREJ
24637 ETAIM=ETAIM+ETAIMJ
24638 250 CONTINUE
24639 ETA2=ETARE**2+ETAIM**2
24640 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24641
24642 ELSEIF(I.EQ.15) THEN
24643C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24644 ETARE=0D0
24645 ETAIM=0D0
24646 JMAX=3*MSTP(1)+1
24647 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24648 DO 260 J=1,JMAX
24649 IF(J.LE.2*MSTP(1)) THEN
24650 EJ=KCHG(J,1)/3D0
24651 AJ=SIGN(1D0,EJ+0.1D0)
24652 VJ=AJ-4D0*EJ*XWV
24653 EPS=(2D0*PMAS(J,1))**2/SH
24654 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24655 ELSEIF(J.LE.3*MSTP(1)) THEN
24656 JL=2*(J-2*MSTP(1))-1
24657 EJ=KCHG(10+JL,1)/3D0
24658 AJ=SIGN(1D0,EJ+0.1D0)
24659 VJ=AJ-4D0*EJ*XWV
24660 EPS=(2D0*PMAS(10+JL,1))**2/SH
24661 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24662 ELSE
24663 EPS=(2D0*PMAS(24,1))**2/SH
24664 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24665 ENDIF
24666C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24667 IF(EPS.LE.1D0) THEN
24668 ROOT=SQRT(1D0-EPS)
24669 IF(EPS.GT.1D-4) THEN
24670 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24671 ELSE
24672 RLN=LOG(4D0/EPS-2D0)
24673 ENDIF
24674 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24675 PHIIM=0.5D0*PARU(1)*RLN
24676 PSIRE=0.5D0*ROOT*RLN
24677 PSIIM=-0.5D0*ROOT*PARU(1)
24678 ELSE
24679 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24680 PHIIM=0D0
24681 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24682 PSIIM=0D0
24683 ENDIF
24684 IF(EPSP.LE.1D0) THEN
24685 ROOT=SQRT(1D0-EPSP)
24686 IF(EPSP.GT.1D-4) THEN
24687 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24688 ELSE
24689 RLN=LOG(4D0/EPSP-2D0)
24690 ENDIF
24691 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24692 PHIIMP=0.5D0*PARU(1)*RLN
24693 PSIREP=0.5D0*ROOT*RLN
24694 PSIIMP=-0.5D0*ROOT*PARU(1)
24695 ELSE
24696 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24697 PHIIMP=0D0
24698 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24699 PSIIMP=0D0
24700 ENDIF
24701 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24702 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24703 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24704 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24705 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24706 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24707 IF(J.LE.3*MSTP(1)) THEN
24708C...Fermion loops: loop integral different for A0; charges.
24709 IF(IHIGG.EQ.3) FXYRE=0D0
24710 IF(IHIGG.EQ.3) FXYIM=0D0
24711 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24712 EJC=-3D0*EJ*VJ
24713 EJH=PARU(151+10*IHIGG)
24714 ELSEIF(J.LE.2*MSTP(1)) THEN
24715 EJC=-3D0*EJ*VJ
24716 EJH=PARU(152+10*IHIGG)
24717 ELSE
24718 EJC=-EJ*VJ
24719 EJH=PARU(153+10*IHIGG)
24720 ENDIF
24721 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24722 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24723 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24724 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24725C...W loops: loop integral and charges.
24726 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24727 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24728 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24729 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24730 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24731 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24732 ENDIF
24733 ELSE
24734C...Charged H loops: loop integral and charges.
24735 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24736 & PARU(158+10*IHIGG+2*(IHIGG/3))
24737 ETAREJ=FACHHH*FXYRE
24738 ETAIMJ=FACHHH*FXYIM
24739 ENDIF
24740 ETARE=ETARE+ETAREJ
24741 ETAIM=ETAIM+ETAIMJ
24742 260 CONTINUE
24743 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24744 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24745 WID2=WIDS(23,2)
24746
24747 ELSEIF(I.LE.17) THEN
24748C...h0 -> Z0 + Z0, W+ + W-
24749 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24750 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24751 IF(MINT(62).GE.1) THEN
24752 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24753 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24754 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24755 MOFSV(IHIGG,I-15)=0
24756 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24757 & 1D0-4D0*RM1))
24758 WID2=1D0
24759 ELSE
24760 MOFSV(IHIGG,I-15)=1
24761 RMAS=SQRT(MAX(0D0,SH))
24762 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24763 & WID2)
24764 WIDWSV(IHIGG,I-15)=WIDW
24765 WID2SV(IHIGG,I-15)=WID2
24766 ENDIF
24767 ELSE
24768 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24769 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24770 & 1D0-4D0*RM1))
24771 WID2=1D0
24772 ELSE
24773 WIDW=WIDWSV(IHIGG,I-15)
24774 WID2=WID2SV(IHIGG,I-15)
24775 ENDIF
24776 ENDIF
24777 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24778 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24779 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24780 & PARU(138+I+10*IHIGG)**2
24781 WID2=WID2*WIDS(7+I,1)
24782
24783 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24784C...H0 -> Z0 + h0, A0-> Z0 + h0
24785 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24786 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24787 IF(IHIGG.EQ.2) THEN
24788 WDTP(I)=WDTP(I)*PARU(179)**2
24789 ELSEIF(IHIGG.EQ.3) THEN
24790 WDTP(I)=WDTP(I)*PARU(186)**2
24791 ENDIF
24792 WID2=WIDS(23,2)*WIDS(25,2)
24793
24794 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24795C...H0 -> h0 + h0, A0-> h0 + h0
24796 WDTP(I)=FAC*0.25D0*
24797 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24798 IF(IHIGG.EQ.2) THEN
24799 WDTP(I)=WDTP(I)*PARU(176)**2
24800 ELSEIF(IHIGG.EQ.3) THEN
24801 WDTP(I)=WDTP(I)*PARU(169)**2
24802 ENDIF
24803 WID2=WIDS(25,1)
24804 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24805C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24806 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24807 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24808 & *PARU(195+IHIGG)**2
24809 IF(I.EQ.20) THEN
24810 WID2=WIDS(24,2)*WIDS(37,3)
24811 ELSEIF(I.EQ.21) THEN
24812 WID2=WIDS(24,3)*WIDS(37,2)
24813 ENDIF
24814
24815 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24816C...H0 -> Z0 + A0.
24817 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24818 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24819 WID2=WIDS(36,2)*WIDS(23,2)
24820
24821 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24822C...H0 -> h0 + A0.
24823 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24824 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24825 WID2=WIDS(25,2)*WIDS(36,2)
24826
24827 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24828C...H0 -> A0 + A0
24829 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24830 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24831 WID2=WIDS(36,1)
24832
24833CMRENNA++
24834 ELSE
24835C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24836 RM10=RM1*SH/PMR**2
24837 RM20=RM2*SH/PMR**2
24838 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24839 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24840 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24841 WFAC=0D0
24842 ELSE
24843 WFAC=WFAC/WFAC0
24844 ENDIF
24845 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24846CMRENNA--
24847 IF(KFC2.EQ.KFC1) THEN
24848 WID2=WIDS(KFC1,1)
24849 ELSE
24850 KSGN1=2
24851 IF(KFDP(IDC,1).LT.0) KSGN1=3
24852 KSGN2=2
24853 IF(KFDP(IDC,2).LT.0) KSGN2=3
24854 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24855 ENDIF
24856 ENDIF
24857 WDTP(I)=FUDGE*WDTP(I)
24858 WDTP(0)=WDTP(0)+WDTP(I)
24859 IF(MDME(IDC,1).GT.0) THEN
24860 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24861 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24862 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24863 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24864 ENDIF
24865 270 CONTINUE
24866
24867 ELSEIF(KFLA.EQ.32) THEN
24868C...Z'0:
24869 ICASE=1
24870 XWC=1D0/(16D0*XW*XW1)
24871 FAC=(AEM*XWC/3D0)*SHR
24872 VINT(117)=0D0
24873 280 CONTINUE
24874 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24875 VINT(111)=0D0
24876 VINT(112)=0D0
24877 VINT(113)=0D0
24878 VINT(114)=0D0
24879 VINT(115)=0D0
24880 VINT(116)=0D0
24881 ENDIF
24882 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24883 KFAI=IABS(MINT(15))
24884 EI=KCHG(KFAI,1)/3D0
24885 AI=SIGN(1D0,EI+0.1D0)
24886 VI=AI-4D0*EI*XWV
24887 KFAIC=1
24888 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24889 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24890 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24891 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24892 VPI=PARU(119+2*KFAIC)
24893 API=PARU(120+2*KFAIC)
24894 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24895 VPI=PARJ(178+2*KFAIC)
24896 API=PARJ(179+2*KFAIC)
24897 ELSE
24898 VPI=PARJ(186+2*KFAIC)
24899 API=PARJ(187+2*KFAIC)
24900 ENDIF
24901 SQMZ=PMAS(23,1)**2
24902 HZ=SHR*VINT(117)
24903 SQMZP=PMAS(32,1)**2
24904 HZP=SHR*WDTP(0)
24905 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24906 & MSTP(44).EQ.7) VINT(111)=1D0
24907 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24908 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24909 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24910 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24911 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24912 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24913 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24914 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24915 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24916 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24917 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24918 ENDIF
24919 DO 290 I=1,MDCY(KC,3)
24920 IDC=I+MDCY(KC,2)-1
24921 IF(MDME(IDC,1).LT.0) GOTO 290
24922 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24923 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24924 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24925 WID2=1D0
24926 IF(I.LE.16) THEN
24927 IF(I.LE.8) THEN
24928C...Z'0 -> q + qbar
24929 EF=KCHG(I,1)/3D0
24930 AF=SIGN(1D0,EF+0.1D0)
24931 VF=AF-4D0*EF*XWV
24932 IF(I.LE.2) THEN
24933 VPF=PARU(123-2*MOD(I,2))
24934 APF=PARU(124-2*MOD(I,2))
24935 ELSEIF(I.LE.4) THEN
24936 VPF=PARJ(182-2*MOD(I,2))
24937 APF=PARJ(183-2*MOD(I,2))
24938 ELSE
24939 VPF=PARJ(190-2*MOD(I,2))
24940 APF=PARJ(191-2*MOD(I,2))
24941 ENDIF
24942 FCOF=3D0*RADC
24943 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24944 & PYHFTH(SH,SH*RM1,1D0)
24945 IF(I.EQ.6) WID2=WIDS(6,1)
24946 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24947 ELSEIF(I.LE.16) THEN
24948C...Z'0 -> l+ + l-, nu + nubar
24949 EF=KCHG(I+2,1)/3D0
24950 AF=SIGN(1D0,EF+0.1D0)
24951 VF=AF-4D0*EF*XWV
24952 IF(I.LE.10) THEN
24953 VPF=PARU(127-2*MOD(I,2))
24954 APF=PARU(128-2*MOD(I,2))
24955 ELSEIF(I.LE.12) THEN
24956 VPF=PARJ(186-2*MOD(I,2))
24957 APF=PARJ(187-2*MOD(I,2))
24958 ELSE
24959 VPF=PARJ(194-2*MOD(I,2))
24960 APF=PARJ(195-2*MOD(I,2))
24961 ENDIF
24962 FCOF=1D0
24963 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24964 ENDIF
24965 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24966 IF(ICASE.EQ.1) THEN
24967 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24968 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24969 & APF**2*(1D0-4D0*RM1))*BE34
24970 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24971 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24972 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24973 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24974 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24975 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24976 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24977 ELSEIF(MINT(61).EQ.2) THEN
24978 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24979 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24980 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24981 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24982 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24983 & BE34
24984 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24985 & BE34
24986 ENDIF
24987 ELSEIF(I.EQ.17) THEN
24988C...Z'0 -> W+ + W-
24989 WDTPZP=PARU(129)**2*XW1**2*
24990 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24991 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24992 IF(ICASE.EQ.1) THEN
24993 WDTPZ=0D0
24994 WDTP(I)=FAC*WDTPZP
24995 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24996 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24997 ELSEIF(MINT(61).EQ.2) THEN
24998 FGGF=0D0
24999 FGZF=0D0
25000 FGZPF=0D0
25001 FZZF=0D0
25002 FZZPF=0D0
25003 FZPZPF=WDTPZP
25004 ENDIF
25005 WID2=WIDS(24,1)
25006 ELSEIF(I.EQ.18) THEN
25007C...Z'0 -> H+ + H-
25008 CZC=2D0*(1D0-2D0*XW)
25009 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25010 IF(ICASE.EQ.1) THEN
25011 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25012 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25013 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25014 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25015 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25016 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25017 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25018 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25019 ELSEIF(MINT(61).EQ.2) THEN
25020 FGGF=0.25D0*BE34C
25021 FGZF=0.25D0*PARU(142)*CZC*BE34C
25022 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25023 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25024 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25025 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25026 ENDIF
25027 WID2=WIDS(37,1)
25028 ELSEIF(I.EQ.19) THEN
25029C...Z'0 -> Z0 + gamma.
25030 ELSEIF(I.EQ.20) THEN
25031C...Z'0 -> Z0 + h0
25032 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25033 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25034 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25035 IF(ICASE.EQ.1) THEN
25036 WDTPZ=0D0
25037 WDTP(I)=FAC*WDTPZP
25038 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25039 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25040 ELSEIF(MINT(61).EQ.2) THEN
25041 FGGF=0D0
25042 FGZF=0D0
25043 FGZPF=0D0
25044 FZZF=0D0
25045 FZZPF=0D0
25046 FZPZPF=WDTPZP
25047 ENDIF
25048 WID2=WIDS(23,2)*WIDS(25,2)
25049 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25050C...Z' -> h0 + A0 or H0 + A0.
25051 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25052 IF(I.EQ.21) THEN
25053 CZAH=PARU(186)
25054 CZPAH=PARU(188)
25055 ELSE
25056 CZAH=PARU(187)
25057 CZPAH=PARU(189)
25058 ENDIF
25059 IF(ICASE.EQ.1) THEN
25060 WDTPZ=CZAH**2*BE34C
25061 WDTP(I)=FAC*CZPAH**2*BE34C
25062 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25063 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25064 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25065 & VINT(116))*BE34C
25066 ELSEIF(MINT(61).EQ.2) THEN
25067 FGGF=0D0
25068 FGZF=0D0
25069 FGZPF=0D0
25070 FZZF=CZAH**2*BE34C
25071 FZZPF=CZAH*CZPAH*BE34C
25072 FZPZPF=CZPAH**2*BE34C
25073 ENDIF
25074 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25075 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25076 ENDIF
25077 IF(ICASE.EQ.1) THEN
25078 VINT(117)=VINT(117)+FAC*WDTPZ
25079 WDTP(I)=FUDGE*WDTP(I)
25080 WDTP(0)=WDTP(0)+WDTP(I)
25081 ENDIF
25082 IF(MDME(IDC,1).GT.0) THEN
25083 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25084 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25085 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25086 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25087 & WDTE(I,MDME(IDC,1))
25088 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25089 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25090 ENDIF
25091 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25092 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25093 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25094 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25095 & FGZF*WID2
25096 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25097 & FGZPF*WID2
25098 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25099 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25100 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25101 & FZZPF*WID2
25102 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25103 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25104 ENDIF
25105 ENDIF
25106 290 CONTINUE
25107 IF(MINT(61).GE.1) ICASE=3-ICASE
25108 IF(ICASE.EQ.2) GOTO 280
25109
25110 ELSEIF(KFLA.EQ.34) THEN
25111C...W'+/-:
25112 FAC=(AEM/(24D0*XW))*SHR
25113 DO 300 I=1,MDCY(KC,3)
25114 IDC=I+MDCY(KC,2)-1
25115 IF(MDME(IDC,1).LT.0) GOTO 300
25116 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25117 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25118 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25119 WID2=1D0
25120 IF(I.LE.20) THEN
25121 IF(I.LE.16) THEN
25122C...W'+/- -> q + qbar'
25123 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25124 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25125 IF(KFLR.GT.0) THEN
25126 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25127 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25128 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25129 ELSE
25130 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25131 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25132 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25133 ENDIF
25134 ELSEIF(I.LE.20) THEN
25135C...W'+/- -> l+/- + nu
25136 FCOF=PARU(133)**2+PARU(134)**2
25137 IF(KFLR.GT.0) THEN
25138 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25139 ELSE
25140 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25141 ENDIF
25142 ENDIF
25143 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25144 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25145 ELSEIF(I.EQ.21) THEN
25146C...W'+/- -> W+/- + Z0
25147 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25148 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25149 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25150 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25151 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25152 ELSEIF(I.EQ.23) THEN
25153C...W'+/- -> W+/- + h0
25154 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25155 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25156 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25157 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25158 ENDIF
25159 WDTP(I)=FUDGE*WDTP(I)
25160 WDTP(0)=WDTP(0)+WDTP(I)
25161 IF(MDME(IDC,1).GT.0) THEN
25162 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25163 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25164 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25165 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25166 ENDIF
25167 300 CONTINUE
25168
25169 ELSEIF(KFLA.EQ.37) THEN
25170C...H+/-:
25171C IF(MSTP(49).EQ.0) THEN
25172 SHFS=SH
25173C ELSE
25174C SHFS=PMAS(37,1)**2
25175C ENDIF
25176 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25177 DO 310 I=1,MDCY(KC,3)
25178 IDC=I+MDCY(KC,2)-1
25179 IF(MDME(IDC,1).LT.0) GOTO 310
25180 KFC1=PYCOMP(KFDP(IDC,1))
25181 KFC2=PYCOMP(KFDP(IDC,2))
25182 RM1=PMAS(KFC1,1)**2/SH
25183 RM2=PMAS(KFC2,1)**2/SH
25184 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25185 WID2=1D0
25186 IF(I.LE.4) THEN
25187C...H+/- -> q + qbar'
25188 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25189 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25190 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25191 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25192 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25193 IF(KFLR.GT.0) THEN
25194 IF(I.EQ.3) WID2=WIDS(6,2)
25195 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25196 ELSE
25197 IF(I.EQ.3) WID2=WIDS(6,3)
25198 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25199 ENDIF
25200 ELSEIF(I.LE.8) THEN
25201C...H+/- -> l+/- + nu
25202 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25203 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25204 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25205 IF(KFLR.GT.0) THEN
25206 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25207 ELSE
25208 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25209 ENDIF
25210 ELSEIF(I.EQ.9) THEN
25211C...H+/- -> W+/- + h0.
25212 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25213 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25214 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25215 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25216
25217CMRENNA++
25218 ELSE
25219C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25220 RM10=RM1*SH/PMR**2
25221 RM20=RM2*SH/PMR**2
25222 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25223 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25224 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25225 WFAC=0D0
25226 ELSE
25227 WFAC=WFAC/WFAC0
25228 ENDIF
25229 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25230CMRENNA--
25231 KSGN1=2
25232 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25233 KSGN2=2
25234 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25235 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25236 ENDIF
25237 WDTP(I)=FUDGE*WDTP(I)
25238 WDTP(0)=WDTP(0)+WDTP(I)
25239 IF(MDME(IDC,1).GT.0) THEN
25240 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25241 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25242 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25243 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25244 ENDIF
25245 310 CONTINUE
25246
25247 ELSEIF(KFLA.EQ.41) THEN
25248C...R:
25249 FAC=(AEM/(12D0*XW))*SHR
25250 DO 320 I=1,MDCY(KC,3)
25251 IDC=I+MDCY(KC,2)-1
25252 IF(MDME(IDC,1).LT.0) GOTO 320
25253 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25254 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25255 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25256 WID2=1D0
25257 IF(I.LE.6) THEN
25258C...R -> q + qbar'
25259 FCOF=3D0*RADC
25260 ELSEIF(I.LE.9) THEN
25261C...R -> l+ + l'-
25262 FCOF=1D0
25263 ENDIF
25264 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25265 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25266 IF(KFLR.GT.0) THEN
25267 IF(I.EQ.4) WID2=WIDS(6,3)
25268 IF(I.EQ.5) WID2=WIDS(7,3)
25269 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
25270 IF(I.EQ.9) WID2=WIDS(17,3)
25271 ELSE
25272 IF(I.EQ.4) WID2=WIDS(6,2)
25273 IF(I.EQ.5) WID2=WIDS(7,2)
25274 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
25275 IF(I.EQ.9) WID2=WIDS(17,2)
25276 ENDIF
25277 WDTP(I)=FUDGE*WDTP(I)
25278 WDTP(0)=WDTP(0)+WDTP(I)
25279 IF(MDME(IDC,1).GT.0) THEN
25280 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25281 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25282 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25283 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25284 ENDIF
25285 320 CONTINUE
25286
25287 ELSEIF(KFLA.EQ.42) THEN
25288C...LQ (leptoquark).
25289 FAC=(AEM/4D0)*PARU(151)*SHR
25290 DO 330 I=1,MDCY(KC,3)
25291 IDC=I+MDCY(KC,2)-1
25292 IF(MDME(IDC,1).LT.0) GOTO 330
25293 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25294 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25295 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
25296 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25297 WID2=1D0
25298 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
25299 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
25300 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
25301 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
25302 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
25303 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
25304 WDTP(I)=FUDGE*WDTP(I)
25305 WDTP(0)=WDTP(0)+WDTP(I)
25306 IF(MDME(IDC,1).GT.0) THEN
25307 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25308 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25309 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25310 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25311 ENDIF
25312 330 CONTINUE
25313
25314 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
25315C...Techni-pi0 and techni-pi0':
25316 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25317 DO 340 I=1,MDCY(KC,3)
25318 IDC=I+MDCY(KC,2)-1
25319 IF(MDME(IDC,1).LT.0) GOTO 340
25320 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25321 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25322 RM1=PM1**2/SH
25323 RM2=PM2**2/SH
25324 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
25325 WID2=1D0
25326C...pi_tc -> g + g
25327 IF(I.EQ.8) THEN
25328 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
25329 & /(8D0*PARU(1))*SH*SHR
25330 IF(KFLA.EQ.KTECHN+111) THEN
25331 FACP=FACP*RTCM(9)
25332 ELSE
25333 FACP=FACP*RTCM(10)
25334 ENDIF
25335 WDTP(I)=FACP
25336 ELSE
25337C...pi_tc -> f + fbar.
25338 FCOF=1D0
25339 IKA=IABS(KFDP(IDC,1))
25340 IF(IKA.LT.10) FCOF=3D0*RADC
25341 HM1=PM1
25342 HM2=PM2
25343 IF(IKA.GE.4.AND.IKA.LE.6) THEN
25344 FCOF=FCOF*RTCM(1+IKA)**2
25345 HM1=PYMRUN(KFDP(IDC,1),SH)
25346 HM2=PYMRUN(KFDP(IDC,2),SH)
25347 ELSEIF(IKA.EQ.15) THEN
25348 FCOF=FCOF*RTCM(8)**2
25349 ENDIF
25350 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25351 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25352 ENDIF
25353 WDTP(I)=FUDGE*WDTP(I)
25354 WDTP(0)=WDTP(0)+WDTP(I)
25355 IF(MDME(IDC,1).GT.0) THEN
25356 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25357 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25358 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25359 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25360 ENDIF
25361 340 CONTINUE
25362
25363 ELSEIF(KFLA.EQ.KTECHN+211) THEN
25364C...pi+_tc
25365 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25366 DO 350 I=1,MDCY(KC,3)
25367 IDC=I+MDCY(KC,2)-1
25368 IF(MDME(IDC,1).LT.0) GOTO 350
25369 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25370 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25371 PM3=0D0
25372 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25373 RM1=PM1**2/SH
25374 RM2=PM2**2/SH
25375 RM3=PM3**2/SH
25376 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
25377 WID2=1D0
25378C...pi_tc -> f + f'.
25379 FCOF=1D0
25380 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
25381C...pi_tc+ -> W b b~
25382 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
25383 FCOF=3D0*RADC
25384 XMT2=PMAS(6,1)**2/SH
25385 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
25386 KFC3=PYCOMP(KFDP(IDC,3))
25387 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
25388 CHECK = SQRT(RM1)
25389 T0 = (1D0-CHECK**2)*
25390 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
25391 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
25392 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
25393 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
25394 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
25395 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
25396 & +T3*LOG(CHECK))
25397 IF(KFLR.GT.0) THEN
25398 WID2=WIDS(24,2)
25399 ELSE
25400 WID2=WIDS(24,3)
25401 ENDIF
25402 ELSE
25403 FCOF=1D0
25404 IKA=IABS(KFDP(IDC,1))
25405 IF(IKA.LT.10) FCOF=3D0*RADC
25406 HM1=PM1
25407 HM2=PM2
25408 IF(I.GE.1.AND.I.LE.5) THEN
25409 IF(I.LE.2) THEN
25410 FCOF=FCOF*RTCM(5)**2
25411 ELSEIF(I.LE.4) THEN
25412 FCOF=FCOF*RTCM(6)**2
25413 ELSEIF(I.EQ.5) THEN
25414 FCOF=FCOF*RTCM(7)**2
25415 ENDIF
25416 HM1=PYMRUN(KFDP(IDC,1),SH)
25417 HM2=PYMRUN(KFDP(IDC,2),SH)
25418 ELSEIF(I.EQ.8) THEN
25419 FCOF=FCOF*RTCM(8)**2
25420 ENDIF
25421 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25422 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25423 ENDIF
25424 WDTP(I)=FUDGE*WDTP(I)
25425 WDTP(0)=WDTP(0)+WDTP(I)
25426 IF(MDME(IDC,1).GT.0) THEN
25427 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25428 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25429 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25430 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25431 ENDIF
25432 350 CONTINUE
25433
25434 ELSEIF(KFLA.EQ.KTECHN+331) THEN
25435C...Techni-eta.
25436 FAC=(SH/PARP(46)**2)*SHR
25437 DO 360 I=1,MDCY(KC,3)
25438 IDC=I+MDCY(KC,2)-1
25439 IF(MDME(IDC,1).LT.0) GOTO 360
25440 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25441 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25442 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
25443 WID2=1D0
25444 IF(I.LE.2) THEN
25445 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
25446 IF(I.EQ.2) WID2=WIDS(6,1)
25447 ELSE
25448 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
25449 ENDIF
25450 WDTP(I)=FUDGE*WDTP(I)
25451 WDTP(0)=WDTP(0)+WDTP(I)
25452 IF(MDME(IDC,1).GT.0) THEN
25453 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25454 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25455 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25456 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25457 ENDIF
25458 360 CONTINUE
25459
25460 ELSEIF(KFLA.EQ.KTECHN+113) THEN
25461C...Techni-rho0:
25462 ALPRHT=2.16D0*(3D0/ITCM(1))
25463 FAC=(ALPRHT/12D0)*SHR
25464 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
25465 SQMZ=PMAS(23,1)**2
25466 SQMW=PMAS(24,1)**2
25467 SHP=SH
25468 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25469 GMMZ=SHR*WDTPP(0)
25470 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25471 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25472 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25473 DO 370 I=1,MDCY(KC,3)
25474 IDC=I+MDCY(KC,2)-1
25475 IF(MDME(IDC,1).LT.0) GOTO 370
25476 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25477 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25478 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
25479 WID2=1D0
25480 IF(I.EQ.1) THEN
25481C...rho_tc0 -> W+ + W-.
25482C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25483 WDTP(I)=FAC*RTCM(3)**4*
25484 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25485 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25486 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25487 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
25488 WID2=WIDS(24,1)
25489 ELSEIF(I.EQ.2) THEN
25490C...rho_tc0 -> W+ + pi_tc-.
25491C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
25492 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25493 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25494 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25495 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
25496 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25497 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25498 ELSEIF(I.EQ.3) THEN
25499C...rho_tc0 -> pi_tc+ + W-.
25500 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25501 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25502 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25503 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
25504 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25505 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
25506 ELSEIF(I.EQ.4) THEN
25507C...rho_tc0 -> pi_tc+ + pi_tc-.
25508 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25509 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25510 WID2=WIDS(PYCOMP(KTECHN+211),1)
25511 ELSEIF(I.EQ.5) THEN
25512C...rho_tc0 -> gamma + pi_tc0
25513 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25514 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25515 & SHR**3
25516 WID2=WIDS(PYCOMP(KTECHN+111),2)
25517 ELSEIF(I.EQ.6) THEN
25518C...rho_tc0 -> gamma + pi_tc0'
25519 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25520 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
25521 WID2=WIDS(PYCOMP(KTECHN+221),2)
25522 ELSEIF(I.EQ.7) THEN
25523C...rho_tc0 -> Z0 + pi_tc0
25524 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25525 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25526 & XW/XW1*SHR**3
25527 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25528 ELSEIF(I.EQ.8) THEN
25529C...rho_tc0 -> Z0 + pi_tc0'
25530 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25531 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25532 & XW/XW1*SHR**3
25533 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25534 ELSEIF(I.EQ.9) THEN
25535C...rho_tc0 -> gamma + Z0
25536 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25537 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25538 WID2=WIDS(23,2)
25539 ELSEIF(I.EQ.10) THEN
25540C...rho_tc0 -> Z0 + Z0
25541 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25542 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
25543 & SHR**3
25544 WID2=WIDS(23,1)
25545 ELSE
25546C...rho_tc0 -> f + fbar.
25547 WID2=1D0
25548 IF(I.LE.18) THEN
25549 IA=I-10
25550 FCOF=3D0*RADC
25551 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25552 ELSE
25553 IA=I-6
25554 FCOF=1D0
25555 IF(IA.GE.17) WID2=WIDS(IA,1)
25556 ENDIF
25557 EI=KCHG(IA,1)/3D0
25558 AI=SIGN(1D0,EI+0.1D0)
25559 VI=AI-4D0*EI*XWV
25560 VALI=0.5D0*(VI+AI)
25561 VARI=0.5D0*(VI-AI)
25562 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25563 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25564 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25565 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25566 ENDIF
25567 WDTP(I)=FUDGE*WDTP(I)
25568 WDTP(0)=WDTP(0)+WDTP(I)
25569 IF(MDME(IDC,1).GT.0) THEN
25570 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25571 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25572 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25573 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25574 ENDIF
25575 370 CONTINUE
25576
25577 ELSEIF(KFLA.EQ.KTECHN+213) THEN
25578C...Techni-rho+/-:
25579 ALPRHT=2.16D0*(3D0/ITCM(1))
25580 FAC=(ALPRHT/12D0)*SHR
25581 SQMZ=PMAS(23,1)**2
25582 SQMW=PMAS(24,1)**2
25583 SHP=SH
25584 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
25585 GMMW=SHR*WDTPP(0)
25586 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
25587 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25588 DO 380 I=1,MDCY(KC,3)
25589 IDC=I+MDCY(KC,2)-1
25590 IF(MDME(IDC,1).LT.0) GOTO 380
25591 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25592 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25593 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
25594 WID2=1D0
25595 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25596c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25597c & /3D0*SHR**3
25598 IF(I.EQ.1) THEN
25599C...rho_tc+ -> W+ + Z0.
25600C......Goldstone
25601 WDTP(I)=FAC*RTCM(3)**4*
25602 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25603 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
25604 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
25605C......W_L Z_T
25606 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
25607 & /3D0*SHR**3
25608 VA2=0D0
25609 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
25610C......W_T Z_L
25611 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25612 & /3D0*SHR**3
25613 IF(KFLR.GT.0) THEN
25614 WID2=WIDS(24,2)*WIDS(23,2)
25615 ELSE
25616 WID2=WIDS(24,3)*WIDS(23,2)
25617 ENDIF
25618 ELSEIF(I.EQ.2) THEN
25619C...rho_tc+ -> W+ + pi_tc0.
25620 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25621 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25622 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25623 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25624 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25625 IF(KFLR.GT.0) THEN
25626 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
25627 ELSE
25628 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
25629 ENDIF
25630 ELSEIF(I.EQ.3) THEN
25631C...rho_tc+ -> pi_tc+ + Z0.
25632 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25633 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25634 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25635 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
25636 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
25637 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25638 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25639 & SHR**3*XW/XW1
25640 IF(KFLR.GT.0) THEN
25641 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
25642 ELSE
25643 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
25644 ENDIF
25645 ELSEIF(I.EQ.4) THEN
25646C...rho_tc+ -> pi_tc+ + pi_tc0.
25647 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25648 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25649 IF(KFLR.GT.0) THEN
25650 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25651 ELSE
25652 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25653 ENDIF
25654 ELSEIF(I.EQ.5) THEN
25655C...rho_tc+ -> pi_tc+ + gamma
25656 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25657 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25658 & SHR**3
25659 IF(KFLR.GT.0) THEN
25660 WID2=WIDS(PYCOMP(KTECHN+211),2)
25661 ELSE
25662 WID2=WIDS(PYCOMP(KTECHN+211),3)
25663 ENDIF
25664 ELSEIF(I.EQ.6) THEN
25665C...rho_tc+ -> W+ + pi_tc0'
25666 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25667 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25668 IF(KFLR.GT.0) THEN
25669 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25670 ELSE
25671 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25672 ENDIF
25673 ELSEIF(I.EQ.7) THEN
25674C...rho_tc+ -> W+ + gamma
25675 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25676 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25677 IF(KFLR.GT.0) THEN
25678 WID2=WIDS(24,2)
25679 ELSE
25680 WID2=WIDS(24,3)
25681 ENDIF
25682 ELSE
25683C...rho_tc+ -> f + fbar'.
25684 IA=I-7
25685 WID2=1D0
25686 IF(IA.LE.16) THEN
25687 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25688 IF(KFLR.GT.0) THEN
25689 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25690 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25691 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25692 ELSE
25693 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25694 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25695 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25696 ENDIF
25697 ELSE
25698 FCOF=1D0
25699 IF(KFLR.GT.0) THEN
25700 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25701 ELSE
25702 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25703 ENDIF
25704 ENDIF
25705 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25706 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25707 ENDIF
25708 WDTP(I)=FUDGE*WDTP(I)
25709 WDTP(0)=WDTP(0)+WDTP(I)
25710 IF(MDME(IDC,1).GT.0) THEN
25711 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25712 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25713 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25714 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25715 ENDIF
25716 380 CONTINUE
25717
25718 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25719C...Techni-omega:
25720 ALPRHT=2.16D0*(3D0/ITCM(1))
25721 FAC=(ALPRHT/12D0)*SHR
25722 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25723 SQMZ=PMAS(23,1)**2
25724 SHP=SH
25725 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25726 GMMZ=SHR*WDTPP(0)
25727 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25728 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25729 DO 390 I=1,MDCY(KC,3)
25730 IDC=I+MDCY(KC,2)-1
25731 IF(MDME(IDC,1).LT.0) GOTO 390
25732 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25733 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25734 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25735 WID2=1D0
25736 IF(I.EQ.1) THEN
25737C...omega_tc0 -> gamma + pi_tc0.
25738 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25739 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25740 WID2=WIDS(PYCOMP(KTECHN+111),2)
25741 ELSEIF(I.EQ.2) THEN
25742C...omega_tc0 -> Z0 + pi_tc0
25743 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25744 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25745 & XW/XW1*SHR**3
25746 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25747 ELSEIF(I.EQ.3) THEN
25748C...omega_tc0 -> gamma + pi_tc0'
25749 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25750 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25751 & SHR**3
25752 WID2=WIDS(PYCOMP(KTECHN+221),2)
25753 ELSEIF(I.EQ.4) THEN
25754C...omega_tc0 -> Z0 + pi_tc0'
25755 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25756 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25757 & XW/XW1*SHR**3
25758 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25759 ELSEIF(I.EQ.5) THEN
25760C...omega_tc0 -> W+ + pi_tc-
25761 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25762 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25763 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25764 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25765 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25766 ELSEIF(I.EQ.6) THEN
25767C...omega_tc0 -> pi_tc+ + W-
25768 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25769 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25770 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25771 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25772 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25773 ELSEIF(I.EQ.7) THEN
25774C...omega_tc0 -> W+ + W-.
25775C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25776 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25777 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25778 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25779 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
25780 WID2=WIDS(24,1)
25781 ELSEIF(I.EQ.8) THEN
25782C...omega_tc0 -> pi_tc+ + pi_tc-.
25783 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25784 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25785 WID2=WIDS(PYCOMP(KTECHN+211),1)
25786C...omega_tc0 -> gamma + Z0
25787 ELSEIF(I.EQ.9) THEN
25788 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25789 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25790 WID2=WIDS(23,2)
25791C...omega_tc0 -> Z0 + Z0
25792 ELSEIF(I.EQ.10) THEN
25793 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25794 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
25795 & /24D0/RTCM(12)**2*SHR**3
25796 WID2=WIDS(23,1)
25797 ELSE
25798C...omega_tc0 -> f + fbar.
25799 WID2=1D0
25800 IF(I.LE.18) THEN
25801 IA=I-10
25802 FCOF=3D0*RADC
25803 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25804 ELSE
25805 IA=I-8
25806 FCOF=1D0
25807 IF(IA.GE.17) WID2=WIDS(IA,1)
25808 ENDIF
25809 EI=KCHG(IA,1)/3D0
25810 AI=SIGN(1D0,EI+0.1D0)
25811 VI=AI-4D0*EI*XWV
25812 VALI=-0.5D0*(VI+AI)
25813 VARI=-0.5D0*(VI-AI)
25814 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25815 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25816 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25817 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25818 ENDIF
25819 WDTP(I)=FUDGE*WDTP(I)
25820 WDTP(0)=WDTP(0)+WDTP(I)
25821 IF(MDME(IDC,1).GT.0) THEN
25822 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25823 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25824 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25825 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25826 ENDIF
25827 390 CONTINUE
25828
25829C.....V8 -> quark anti-quark
25830 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25831 FAC=AS/6D0*SHR
25832 TANT3=RTCM(21)
25833 IF(ITCM(2).EQ.0) THEN
25834 IMDL=1
25835 ELSEIF(ITCM(2).EQ.1) THEN
25836 IMDL=2
25837 ENDIF
25838 DO 400 I=1,MDCY(KC,3)
25839 IDC=I+MDCY(KC,2)-1
25840 IF(MDME(IDC,1).LT.0) GOTO 400
25841 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25842 RM1=PM1**2/SH
25843 IF(RM1.GT.0.25D0) GOTO 400
25844 WID2=1D0
25845 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25846 FMIX=1D0/TANT3**2
25847 ELSE
25848 FMIX=TANT3**2
25849 ENDIF
25850 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25851 IF(I.EQ.6) WID2=WIDS(6,1)
25852 WDTP(I)=FUDGE*WDTP(I)
25853 WDTP(0)=WDTP(0)+WDTP(I)
25854 IF(MDME(IDC,1).GT.0) THEN
25855 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25856 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25857 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25858 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25859 ENDIF
25860 400 CONTINUE
25861
25862 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25863 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25864 CLEBF=0D0
25865 DO 410 I=1,MDCY(KC,3)
25866 IDC=I+MDCY(KC,2)-1
25867 IF(MDME(IDC,1).LT.0) GOTO 410
25868 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25869 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25870 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25871 WID2=1D0
25872C...pi_tc -> g + g
25873 IF(I.EQ.7) THEN
25874 IF(KFLA.EQ.KTECHN+100111) THEN
25875 CLEBG=4D0/3D0
25876 ELSE
25877 CLEBG=5D0/3D0
25878 ENDIF
25879 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25880 & /(2D0*PARU(1))*SH*SHR*CLEBG
25881 WDTP(I)=FACP
25882 ELSE
25883C...pi_tc -> f + fbar.
25884 IF(I.EQ.6) WID2=WIDS(6,1)
25885 FCOF=1D0
25886 IKA=IABS(KFDP(IDC,1))
25887 IF(IKA.LT.10) FCOF=3D0*RADC
25888 HM1=PYMRUN(KFDP(IDC,1),SH)
25889 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25890 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25891 ENDIF
25892 WDTP(I)=FUDGE*WDTP(I)
25893 WDTP(0)=WDTP(0)+WDTP(I)
25894 IF(MDME(IDC,1).GT.0) THEN
25895 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25896 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25897 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25898 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25899 ENDIF
25900 410 CONTINUE
25901
25902 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25903 FAC=AS/6D0*SHR
25904 ALPRHT=2.16D0*(3D0/ITCM(1))
25905 TANT3=RTCM(21)
25906 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25907 SINT3=TANT3/SQRT(TANT3**2+1D0)
25908 CSXPP=RTCM(22)
25909 RM82=RTCM(27)**2
25910 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25911 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25912 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25913 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25914 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25915 & SINT3**2)*2D0
25916 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25917 & SINT3**2)*2D0
25918 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25919
25920 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25921 GMV8=SHR*WDTPP(0)
25922 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25923 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25924 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25925 IF(ITCM(2).EQ.0) THEN
25926 IMDL=1
25927 ELSE
25928 IMDL=2
25929 ENDIF
25930 DO 420 I=1,MDCY(KC,3)
25931 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25932 & KFLA.EQ.KTECHN+300113)) GOTO 420
25933 IDC=I+MDCY(KC,2)-1
25934 IF(MDME(IDC,1).LT.0) GOTO 420
25935 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25936 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25937 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25938 WID2=1D0
25939 IF(I.LE.6) THEN
25940 IF(I.EQ.6) WID2=WIDS(6,1)
25941 XIG=1D0
25942 IF(KFLA.EQ.KTECHN+200113) THEN
25943 XIG=0D0
25944 XIJ=X12
25945 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25946 XIG=0D0
25947 XIJ=X21
25948 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25949 XIJ=X11
25950 ELSE
25951 XIJ=X22
25952 ENDIF
25953 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25954 FMIX=1D0/TANT3/SIN2T
25955 ELSE
25956 FMIX=-TANT3/SIN2T
25957 ENDIF
25958 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25959 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25960 ELSEIF(I.EQ.7) THEN
25961 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25962 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25963 PSH=SHR*(1D0-RM1)/2D0
25964 WDTP(I)=AS/9D0*PSH**3/RM82
25965 IF(I.EQ.8) THEN
25966 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25967 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25968 ELSE
25969 WDTP(I)=5D0*WDTP(I)
25970 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25971 ENDIF
25972 ENDIF
25973 WDTP(I)=FUDGE*WDTP(I)
25974 WDTP(0)=WDTP(0)+WDTP(I)
25975 IF(MDME(IDC,1).GT.0) THEN
25976 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25977 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25978 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25979 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25980 ENDIF
25981 420 CONTINUE
25982
25983 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25984C...d* excited quark.
25985 FAC=(SH/RTCM(41)**2)*SHR
25986 DO 430 I=1,MDCY(KC,3)
25987 IDC=I+MDCY(KC,2)-1
25988 IF(MDME(IDC,1).LT.0) GOTO 430
25989 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25990 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25991 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25992 WID2=1D0
25993 IF(I.EQ.1) THEN
25994C...d* -> g + d.
25995 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25996 WID2=1D0
25997 ELSEIF(I.EQ.2) THEN
25998C...d* -> gamma + d.
25999 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26000 WDTP(I)=FAC*AEM*QF**2/4D0
26001 WID2=1D0
26002 ELSEIF(I.EQ.3) THEN
26003C...d* -> Z0 + d.
26004 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26005 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26006 & (1D0-RM1)**2*(2D0+RM1)
26007 WID2=WIDS(23,2)
26008 ELSEIF(I.EQ.4) THEN
26009C...d* -> W- + u.
26010 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26011 & (1D0-RM1)**2*(2D0+RM1)
26012 IF(KFLR.GT.0) WID2=WIDS(24,3)
26013 IF(KFLR.LT.0) WID2=WIDS(24,2)
26014 ENDIF
26015 WDTP(I)=FUDGE*WDTP(I)
26016 WDTP(0)=WDTP(0)+WDTP(I)
26017 IF(MDME(IDC,1).GT.0) THEN
26018 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26019 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26020 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26021 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26022 ENDIF
26023 430 CONTINUE
26024
26025 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26026C...u* excited quark.
26027 FAC=(SH/RTCM(41)**2)*SHR
26028 DO 440 I=1,MDCY(KC,3)
26029 IDC=I+MDCY(KC,2)-1
26030 IF(MDME(IDC,1).LT.0) GOTO 440
26031 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26032 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26033 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26034 WID2=1D0
26035 IF(I.EQ.1) THEN
26036C...u* -> g + u.
26037 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26038 WID2=1D0
26039 ELSEIF(I.EQ.2) THEN
26040C...u* -> gamma + u.
26041 QF=RTCM(43)/2D0+RTCM(44)/6D0
26042 WDTP(I)=FAC*AEM*QF**2/4D0
26043 WID2=1D0
26044 ELSEIF(I.EQ.3) THEN
26045C...u* -> Z0 + u.
26046 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26047 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26048 & (1D0-RM1)**2*(2D0+RM1)
26049 WID2=WIDS(23,2)
26050 ELSEIF(I.EQ.4) THEN
26051C...u* -> W+ + d.
26052 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26053 & (1D0-RM1)**2*(2D0+RM1)
26054 IF(KFLR.GT.0) WID2=WIDS(24,2)
26055 IF(KFLR.LT.0) WID2=WIDS(24,3)
26056 ENDIF
26057 WDTP(I)=FUDGE*WDTP(I)
26058 WDTP(0)=WDTP(0)+WDTP(I)
26059 IF(MDME(IDC,1).GT.0) THEN
26060 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26061 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26062 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26063 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26064 ENDIF
26065 440 CONTINUE
26066
26067 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26068C...e* excited lepton.
26069 FAC=(SH/RTCM(41)**2)*SHR
26070 DO 450 I=1,MDCY(KC,3)
26071 IDC=I+MDCY(KC,2)-1
26072 IF(MDME(IDC,1).LT.0) GOTO 450
26073 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26074 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26075 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26076 WID2=1D0
26077 IF(I.EQ.1) THEN
26078C...e* -> gamma + e.
26079 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26080 WDTP(I)=FAC*AEM*QF**2/4D0
26081 WID2=1D0
26082 ELSEIF(I.EQ.2) THEN
26083C...e* -> Z0 + e.
26084 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26085 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26086 & (1D0-RM1)**2*(2D0+RM1)
26087 WID2=WIDS(23,2)
26088 ELSEIF(I.EQ.3) THEN
26089C...e* -> W- + nu.
26090 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26091 & (1D0-RM1)**2*(2D0+RM1)
26092 IF(KFLR.GT.0) WID2=WIDS(24,3)
26093 IF(KFLR.LT.0) WID2=WIDS(24,2)
26094 ENDIF
26095 WDTP(I)=FUDGE*WDTP(I)
26096 WDTP(0)=WDTP(0)+WDTP(I)
26097 IF(MDME(IDC,1).GT.0) THEN
26098 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26099 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26100 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26101 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26102 ENDIF
26103 450 CONTINUE
26104
26105 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26106C...nu*_e excited neutrino.
26107 FAC=(SH/RTCM(41)**2)*SHR
26108 DO 460 I=1,MDCY(KC,3)
26109 IDC=I+MDCY(KC,2)-1
26110 IF(MDME(IDC,1).LT.0) GOTO 460
26111 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26112 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26113 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26114 WID2=1D0
26115 IF(I.EQ.1) THEN
26116C...nu*_e -> Z0 + nu*_e.
26117 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26118 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26119 & (1D0-RM1)**2*(2D0+RM1)
26120 WID2=WIDS(23,2)
26121 ELSEIF(I.EQ.2) THEN
26122C...nu*_e -> W+ + e.
26123 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26124 & (1D0-RM1)**2*(2D0+RM1)
26125 IF(KFLR.GT.0) WID2=WIDS(24,2)
26126 IF(KFLR.LT.0) WID2=WIDS(24,3)
26127 ENDIF
26128 WDTP(I)=FUDGE*WDTP(I)
26129 WDTP(0)=WDTP(0)+WDTP(I)
26130 IF(MDME(IDC,1).GT.0) THEN
26131 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26132 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26133 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26134 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26135 ENDIF
26136 460 CONTINUE
26137
26138 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26139C...G* (graviton resonance):
26140 FAC=(PARP(50)**2/PARU(1))*SHR
26141 DO 470 I=1,MDCY(KC,3)
26142 IDC=I+MDCY(KC,2)-1
26143 IF(MDME(IDC,1).LT.0) GOTO 470
26144 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26145 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26146 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26147 WID2=1D0
26148 IF(I.LE.8) THEN
26149C...G* -> q + qbar
26150 FCOF=3D0*RADC
26151 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26152 & PYHFTH(SH,SH*RM1,1D0)
26153 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26154 & (1D0+8D0*RM1/3D0)/320D0
26155 IF(I.EQ.6) WID2=WIDS(6,1)
26156 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
26157 ELSEIF(I.LE.16) THEN
26158C...G* -> l+ + l-, nu + nubar
26159 FCOF=1D0
26160 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26161 & (1D0+8D0*RM1/3D0)/320D0
26162 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
26163 ELSEIF(I.EQ.17) THEN
26164C...G* -> g + g.
26165 WDTP(I)=FAC/20D0
26166 ELSEIF(I.EQ.18) THEN
26167C...G* -> gamma + gamma.
26168 WDTP(I)=FAC/160D0
26169 ELSEIF(I.EQ.19) THEN
26170C...G* -> Z0 + Z0.
26171 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26172 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
26173 WID2=WIDS(23,1)
26174 ELSEIF(I.EQ.20) THEN
26175C...G* -> W+ + W-.
26176 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26177 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
26178 WID2=WIDS(24,1)
26179 ENDIF
26180 WDTP(I)=FUDGE*WDTP(I)
26181 WDTP(0)=WDTP(0)+WDTP(I)
26182 IF(MDME(IDC,1).GT.0) THEN
26183 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26184 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26185 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26186 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26187 ENDIF
26188 470 CONTINUE
26189
26190 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
26191C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26192 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
26193 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
26194 DO 480 I=1,MDCY(KC,3)
26195 IDC=I+MDCY(KC,2)-1
26196 IF(MDME(IDC,1).LT.0) GOTO 480
26197 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26198 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26199 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26200 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
26201 WID2=1D0
26202 IF(I.LE.9) THEN
26203C...nu_lR -> l- qbar q'
26204 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26205 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26206 ELSEIF(I.LE.18) THEN
26207C...nu_lR -> l+ q qbar'
26208 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
26209 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
26210 ELSE
26211C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26212 FCOF=1D0
26213 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
26214 ENDIF
26215 X=(PM1+PM2+PM3)/SHR
26216 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
26217 Y=(SHR/PMWR)**2
26218 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
26219 WDTP(I)=FAC*FCOF*FX*FY
26220 WDTP(I)=FUDGE*WDTP(I)
26221 WDTP(0)=WDTP(0)+WDTP(I)
26222 IF(MDME(IDC,1).GT.0) THEN
26223 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26224 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26225 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26226 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26227 ENDIF
26228 480 CONTINUE
26229
26230 ELSEIF(KFLA.EQ.9900023) THEN
26231C...Z_R0:
26232 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
26233 DO 490 I=1,MDCY(KC,3)
26234 IDC=I+MDCY(KC,2)-1
26235 IF(MDME(IDC,1).LT.0) GOTO 490
26236 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26237 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26238 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
26239 WID2=1D0
26240 SYMMET=1D0
26241 IF(I.LE.6) THEN
26242C...Z_R0 -> q + qbar
26243 EF=KCHG(I,1)/3D0
26244 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
26245 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
26246 FCOF=3D0*RADC
26247 IF(I.EQ.6) WID2=WIDS(6,1)
26248 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
26249C...Z_R0 -> l+ + l-
26250 AF=-(1D0-2D0*XW)
26251 VF=-1D0+4D0*XW
26252 FCOF=1D0
26253 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
26254C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
26255 AF=-2D0*XW
26256 VF=0D0
26257 FCOF=1D0
26258 SYMMET=0.5D0
26259 ELSEIF(I.LE.15) THEN
26260C...Z0 -> nu_R + nu_R, assumed Majorana.
26261 AF=2D0*XW1
26262 VF=0D0
26263 FCOF=1D0
26264 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
26265 SYMMET=0.5D0
26266 ENDIF
26267 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
26268 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
26269 WDTP(I)=FUDGE*WDTP(I)
26270 WDTP(0)=WDTP(0)+WDTP(I)
26271 IF(MDME(IDC,1).GT.0) THEN
26272 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26273 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26274 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26275 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26276 ENDIF
26277 490 CONTINUE
26278
26279 ELSEIF(KFLA.EQ.9900024) THEN
26280C...W_R+/-:
26281 FAC=(AEM/(24D0*XW))*SHR
26282 DO 500 I=1,MDCY(KC,3)
26283 IDC=I+MDCY(KC,2)-1
26284 IF(MDME(IDC,1).LT.0) GOTO 500
26285 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26286 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26287 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
26288 WID2=1D0
26289 IF(I.LE.9) THEN
26290C...W_R+/- -> q + qbar'
26291 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26292 IF(KFLR.GT.0) THEN
26293 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26294 ELSE
26295 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
26296 ENDIF
26297 ELSEIF(I.LE.12) THEN
26298C...W_R+/- -> l+/- + nu_R
26299 FCOF=1D0
26300 ENDIF
26301 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26302 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26303 WDTP(I)=FUDGE*WDTP(I)
26304 WDTP(0)=WDTP(0)+WDTP(I)
26305 IF(MDME(IDC,1).GT.0) THEN
26306 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26307 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26308 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26309 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26310 ENDIF
26311 500 CONTINUE
26312
26313 ELSEIF(KFLA.EQ.9900041) THEN
26314C...H_L++/--:
26315 FAC=(1D0/(8D0*PARU(1)))*SHR
26316 DO 510 I=1,MDCY(KC,3)
26317 IDC=I+MDCY(KC,2)-1
26318 IF(MDME(IDC,1).LT.0) GOTO 510
26319 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26320 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26321 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
26322 WID2=1D0
26323 IF(I.LE.6) THEN
26324C...H_L++/-- -> l+/- + l'+/-
26325 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26326 & (IABS(KFDP(IDC,2))-9)/2)**2
26327 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26328 ELSEIF(I.EQ.7) THEN
26329C...H_L++/-- -> W_L+/- + W_L+/-
26330 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
26331 & (3D0*RM1+0.25D0/RM1-1D0)
26332 WID2=WIDS(24,4+(1-KFLS)/2)
26333 ENDIF
26334 WDTP(I)=FAC*FCOF*
26335 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26336 WDTP(I)=FUDGE*WDTP(I)
26337 WDTP(0)=WDTP(0)+WDTP(I)
26338 IF(MDME(IDC,1).GT.0) THEN
26339 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26340 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26341 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26342 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26343 ENDIF
26344 510 CONTINUE
26345
26346 ELSEIF(KFLA.EQ.9900042) THEN
26347C...H_R++/--:
26348 FAC=(1D0/(8D0*PARU(1)))*SHR
26349 DO 520 I=1,MDCY(KC,3)
26350 IDC=I+MDCY(KC,2)-1
26351 IF(MDME(IDC,1).LT.0) GOTO 520
26352 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26353 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26354 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
26355 WID2=1D0
26356 IF(I.LE.6) THEN
26357C...H_R++/-- -> l+/- + l'+/-
26358 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26359 & (IABS(KFDP(IDC,2))-9)/2)**2
26360 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26361 ELSEIF(I.EQ.7) THEN
26362C...H_R++/-- -> W_R+/- + W_R+/-
26363 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
26364 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
26365 ENDIF
26366 WDTP(I)=FAC*FCOF*
26367 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26368 WDTP(I)=FUDGE*WDTP(I)
26369 WDTP(0)=WDTP(0)+WDTP(I)
26370 IF(MDME(IDC,1).GT.0) THEN
26371 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26372 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26373 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26374 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26375 ENDIF
26376 520 CONTINUE
26377
26378 ELSEIF(KFLA.EQ.KTECHN+115) THEN
26379C...Techni-a2:
26380C...Need to update to alpha_rho
26381 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26382 FAC=(ALPRHT/12D0)*SHR
26383 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26384 SQMZ=PMAS(23,1)**2
26385 SQMW=PMAS(24,1)**2
26386 SHP=SH
26387 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26388 GMMZ=SHR*WDTPP(0)
26389 XWRHT=1D0/(4D0*XW*(1D0-XW))
26390 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26391 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26392 DO 530 I=1,MDCY(KC,3)
26393 IDC=I+MDCY(KC,2)-1
26394 IF(MDME(IDC,1).LT.0) GOTO 530
26395 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26396 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26397 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
26398 WID2=1D0
26399 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26400 IF(I.LE.4) THEN
26401 FACPV=PCM**2
26402 FACPA=PCM**2+1.5D0*RM1
26403 VA2=0D0
26404 AA2=0D0
26405C...a2_tc0 -> W+ + W-
26406 IF(I.EQ.1) THEN
26407 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
26408C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
26409 WID2=WIDS(24,1)
26410C...a2_tc0 -> W+ + pi_tc- + c.c.
26411 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
26412 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26413 IF(I.EQ.6) THEN
26414 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26415 ELSE
26416 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26417 ENDIF
26418 ELSEIF(I.EQ.4) THEN
26419C...a2_tc0 -> Z0 + pi_tc0'
26420 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
26421 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26422 ENDIF
26423 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
26424 ELSEIF(I.GE.5.AND.I.LE.10) THEN
26425 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26426 FACPA=PCM**2*(1D0+RM1+RM2)
26427 VA2=0D0
26428 AA2=0D0
26429 IF(I.EQ.5) THEN
26430C...a_T^0 -> gamma rho_T^0
26431 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26432 WID2=WIDS(PYCOMP(KTECHN+113),2)
26433 ELSEIF(I.EQ.6) THEN
26434C...a_T^0 -> gamma omega_T
26435 VA2=1D0/RTCM(50)**4
26436 WID2=WIDS(PYCOMP(KTECHN+223),2)
26437 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
26438C...a_T^0 -> W^+- rho_T^-+
26439 AA2=.25D0/XW/RTCM(51)**4
26440 IF(I.EQ.7) THEN
26441 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
26442 ELSE
26443 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
26444 ENDIF
26445 ELSEIF(I.EQ.9) THEN
26446C...a_T^0 -> Z^0 rho_T^0
26447 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26448 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
26449 ELSEIF(I.EQ.10) THEN
26450C...a_T^0 -> Z^0 omega_T
26451 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
26452 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
26453 ENDIF
26454 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26455 ELSE
26456C...a2_tc0 -> f + fbar.
26457 WID2=1D0
26458 IF(I.LE.18) THEN
26459 IA=I-10
26460 FCOF=3D0*RADC
26461 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26462 ELSE
26463 IA=I-8
26464 FCOF=1D0
26465 IF(IA.GE.17) WID2=WIDS(IA,1)
26466 ENDIF
26467 EI=KCHG(IA,1)/3D0
26468 AI=SIGN(1D0,EI+0.1D0)
26469 VI=AI-4D0*EI*XWV
26470 VALI=0.5D0*(VI+AI)
26471 VARI=0.5D0*(VI-AI)
26472 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26473 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
26474 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26475 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
26476 ENDIF
26477 WDTP(I)=FUDGE*WDTP(I)
26478 WDTP(0)=WDTP(0)+WDTP(I)
26479 IF(MDME(IDC,1).GT.0) THEN
26480 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26481 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26482 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26483 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26484 ENDIF
26485 530 CONTINUE
26486
26487 ELSEIF(KFLA.EQ.KTECHN+215) THEN
26488C...Techni-a2+/-:
26489 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26490 FAC=(ALPRHT/12D0)*SHR
26491 SQMZ=PMAS(23,1)**2
26492 SQMW=PMAS(24,1)**2
26493 SHP=SH
26494 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26495 GMMW=SHR*WDTPP(0)
26496 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26497 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26498 DO 540 I=1,MDCY(KC,3)
26499 IDC=I+MDCY(KC,2)-1
26500 IF(MDME(IDC,1).LT.0) GOTO 540
26501 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26502 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
26504 WID2=1D0
26505 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26506 IF(KFLR.GT.0) THEN
26507 ICHANN=2
26508 ELSE
26509 ICHANN=3
26510 ENDIF
26511 IF(I.LE.7) THEN
26512 AA2=0
26513 VA2=0
26514C...a2_tc+ -> gamma + W+.
26515 IF(I.EQ.1) THEN
26516 AA2=RTCM(3)**2/RTCM(49)**2
26517 WID2=WIDS(24,ICHANN)
26518C...a2_tc+ -> gamma + pi_tc+.
26519 ELSEIF(I.EQ.2) THEN
26520 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
26521 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
26522C...a2_tc+ -> W+ + Z
26523 ELSEIF(I.EQ.3) THEN
26524 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
26525 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
26526 WID2=WIDS(24,ICHANN)*WIDS(23,2)
26527C...a2_tc+ -> W+ + pi_tc0.
26528 ELSEIF(I.EQ.4) THEN
26529 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26530 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
26531C...a2_tc+ -> W+ + pi_tc'0.
26532 ELSEIF(I.EQ.5) THEN
26533 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
26534 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
26535C...a2_tc+ -> Z0 + pi_tc+.
26536 ELSEIF(I.EQ.6) THEN
26537 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
26538 & RTCM(49)**2
26539 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
26540 ENDIF
26541 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26542 & /3D0*SHR**3
26543 ELSEIF(I.LE.10) THEN
26544 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26545 FACPA=PCM**2*(1D0+RM1+RM2)
26546 VA2=0D0
26547 AA2=0D0
26548C...a2_tc+ -> gamma + rho_tc+
26549 IF(I.EQ.7) THEN
26550 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26551 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
26552C...a2_tc+ -> W+ + rho_T^0
26553 ELSEIF(I.EQ.8) THEN
26554 AA2=1D0/(4D0*XW)/RTCM(51)**4
26555 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
26556C...a2_tc+ -> W+ + omega_T
26557 ELSEIF(I.EQ.9) THEN
26558 VA2=.25D0/XW/RTCM(50)**4
26559 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
26560C...a2_tc+ -> Z^0 + rho_T^+
26561 ELSEIF(I.EQ.10) THEN
26562 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26563 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
26564 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
26565 ENDIF
26566 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26567 ELSE
26568C...a2_tc+ -> f + fbar'.
26569 IA=I-10
26570 WID2=1D0
26571 IF(IA.LE.16) THEN
26572 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26573 IF(KFLR.GT.0) THEN
26574 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26575 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26576 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26577 ELSE
26578 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26579 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26580 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26581 ENDIF
26582 ELSE
26583 FCOF=1D0
26584 IF(KFLR.GT.0) THEN
26585 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26586 ELSE
26587 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26588 ENDIF
26589 ENDIF
26590 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26591 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26592 ENDIF
26593 WDTP(I)=FUDGE*WDTP(I)
26594 WDTP(0)=WDTP(0)+WDTP(I)
26595 IF(MDME(IDC,1).GT.0) THEN
26596 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26597 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26598 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26599 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26600 ENDIF
26601 540 CONTINUE
26602
26603 ENDIF
26604 MINT(61)=0
26605 MINT(62)=0
26606 MINT(63)=0
26607 RETURN
26608 END
26609
26610C***********************************************************************
26611
26612C...PYOFSH
26613C...Calculates partial width and differential cross-section maxima
26614C...of channels/processes not allowed on mass-shell, and selects
26615C...masses in such channels/processes.
26616
26617 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
26618
26619C...Double precision and integer declarations.
26620 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26621 IMPLICIT INTEGER(I-N)
26622 INTEGER PYK,PYCHGE,PYCOMP
26623C...Commonblocks.
26624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26625 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26626 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26627 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26628 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26629 COMMON/PYINT1/MINT(400),VINT(400)
26630 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26631 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
26632 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
26633 &/PYINT2/,/PYINT5/
26634C...Local arrays.
26635 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
26636 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
26637 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
26638 &WDTE(0:400,0:5)
26639
26640C...Find if particles equal, maximum mass, matrix elements, etc.
26641 MINT(51)=0
26642 ISUB=MINT(1)
26643 KFD(1)=IABS(KFD1)
26644 KFD(2)=IABS(KFD2)
26645 MEQL=0
26646 IF(KFD(1).EQ.KFD(2)) MEQL=1
26647 MLM=0
26648 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
26649 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
26650 NOFF=44
26651 PMMX=PMMO
26652 ELSE
26653 NOFF=40
26654 PMMX=VINT(1)
26655 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
26656 ENDIF
26657 MMED=0
26658 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
26659 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
26660 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
26661 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
26662 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
26663 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
26664 LOOP=1
26665
26666C...Find where Breit-Wigners are required, else select discrete masses.
26667 100 DO 110 I=1,2
26668 KFCA=PYCOMP(KFD(I))
26669 IF(KFCA.GT.0) THEN
26670 PMD(I)=PMAS(KFCA,1)
26671 PGD(I)=PMAS(KFCA,2)
26672 ELSE
26673 PMD(I)=0D0
26674 PGD(I)=0D0
26675 ENDIF
26676 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
26677 MBW(I)=0
26678 PMG(I)=PMD(I)
26679 RMG(I)=(PMG(I)/PMMX)**2
26680 ELSE
26681 MBW(I)=1
26682 ENDIF
26683 110 CONTINUE
26684
26685C...Find allowed mass range and Breit-Wigner parameters.
26686 DO 120 I=1,2
26687 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
26688 PML(I)=PARP(42)
26689 PMU(I)=PMMX-PARP(42)
26690 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26691 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26692 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
26693 ILM=I
26694 IF(MLM.EQ.2) ILM=3-I
26695 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
26696 IF(MBW(3-I).EQ.0) THEN
26697 PMU(I)=PMMX-PMD(3-I)
26698 ELSE
26699 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
26700 ENDIF
26701 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
26702 & MIN(PMU(I),CKIN(NOFF+2*ILM))
26703 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26704 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26705 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26706 IF(MBW(I).EQ.1) THEN
26707 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26708 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26709 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26710 & PGD(I)))
26711 ENDIF
26712 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
26713 ILM=I
26714 IF(MLM.EQ.2) ILM=3-I
26715 PML(I)=MAX(CKIN(48+I),PARP(42))
26716 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
26717 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26718 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26719 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26720 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26721 IF(MBW(I).EQ.1) THEN
26722 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26723 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26724 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26725 & PGD(I)))
26726 ENDIF
26727 ENDIF
26728 120 CONTINUE
26729 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
26730 &THEN
26731 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
26732 MINT(51)=1
26733 RETURN
26734 ENDIF
26735
26736C...Calculation of partial width of resonance.
26737 IF(MOFSH.EQ.1) THEN
26738
26739C..If only one integration, pick that to be the inner.
26740 IF(MBW(1).EQ.0) THEN
26741 PM2=PMD(1)
26742 PMD(1)=PMD(2)
26743 PGD(1)=PGD(2)
26744 PML(1)=PML(2)
26745 PMU(1)=PMU(2)
26746 ELSEIF(MBW(2).EQ.0) THEN
26747 PM2=PMD(2)
26748 ENDIF
26749
26750C...Start outer loop of integration.
26751 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26752 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26753 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26754 NPT2=1
26755 XPT2(1)=1D0
26756 INX2(1)=0
26757 FMAX2=0D0
26758 ENDIF
26759 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26760 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
26761 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
26762 ENDIF
26763 RM2=(PM2/PMMX)**2
26764
26765C...Start inner loop of integration.
26766 PML1=PML(1)
26767 PMU1=MIN(PMU(1),PMMX-PM2)
26768 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
26769 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26770 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26771 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
26772 FUNC2=0D0
26773 GOTO 180
26774 ENDIF
26775 NPT1=1
26776 XPT1(1)=1D0
26777 INX1(1)=0
26778 FMAX1=0D0
26779 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
26780 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
26781 RM1=(PM1/PMMX)**2
26782
26783C...Evaluate function value - inner loop.
26784 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26785 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
26786 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
26787 & RM2**2+10D0*RM1*RM2)
26788 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
26789 FPT1(NPT1)=FUNC1
26790
26791C...Go to next position in inner loop.
26792 IF(NPT1.EQ.1) THEN
26793 NPT1=NPT1+1
26794 XPT1(NPT1)=0D0
26795 INX1(NPT1)=1
26796 GOTO 140
26797 ELSEIF(NPT1.LE.8) THEN
26798 NPT1=NPT1+1
26799 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
26800 ISH1=ISH1+1
26801 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26802 INX1(NPT1)=INX1(ISH1)
26803 INX1(ISH1)=NPT1
26804 GOTO 140
26805 ELSEIF(NPT1.LT.100) THEN
26806 ISN1=ISH1
26807 150 ISH1=ISH1+1
26808 IF(ISH1.GT.NPT1) ISH1=2
26809 IF(ISH1.EQ.ISN1) GOTO 160
26810 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
26811 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
26812 NPT1=NPT1+1
26813 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26814 INX1(NPT1)=INX1(ISH1)
26815 INX1(ISH1)=NPT1
26816 GOTO 140
26817 ENDIF
26818
26819C...Calculate integral over inner loop.
26820 160 FSUM1=0D0
26821 DO 170 IPT1=2,NPT1
26822 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
26823 & (XPT1(INX1(IPT1))-XPT1(IPT1))
26824 170 CONTINUE
26825 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
26826 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26827 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
26828 FPT2(NPT2)=FUNC2
26829
26830C...Go to next position in outer loop.
26831 IF(NPT2.EQ.1) THEN
26832 NPT2=NPT2+1
26833 XPT2(NPT2)=0D0
26834 INX2(NPT2)=1
26835 GOTO 130
26836 ELSEIF(NPT2.LE.8) THEN
26837 NPT2=NPT2+1
26838 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
26839 ISH2=ISH2+1
26840 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26841 INX2(NPT2)=INX2(ISH2)
26842 INX2(ISH2)=NPT2
26843 GOTO 130
26844 ELSEIF(NPT2.LT.100) THEN
26845 ISN2=ISH2
26846 190 ISH2=ISH2+1
26847 IF(ISH2.GT.NPT2) ISH2=2
26848 IF(ISH2.EQ.ISN2) GOTO 200
26849 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
26850 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
26851 NPT2=NPT2+1
26852 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26853 INX2(NPT2)=INX2(ISH2)
26854 INX2(ISH2)=NPT2
26855 GOTO 130
26856 ENDIF
26857
26858C...Calculate integral over outer loop.
26859 200 FSUM2=0D0
26860 DO 210 IPT2=2,NPT2
26861 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
26862 & (XPT2(INX2(IPT2))-XPT2(IPT2))
26863 210 CONTINUE
26864 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
26865 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
26866 ELSE
26867 FSUM2=FUNC2
26868 ENDIF
26869
26870C...Save result; second integration for user-selected mass range.
26871 IF(LOOP.EQ.1) WIDW=FSUM2
26872 WID2=FSUM2
26873 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
26874 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
26875 LOOP=2
26876 GOTO 100
26877 ENDIF
26878 RET1=WIDW
26879 RET2=WID2/WIDW
26880
26881C...Select two decay product masses of a resonance.
26882 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
26883 220 DO 230 I=1,2
26884 IF(MBW(I).EQ.0) GOTO 230
26885 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
26886 & (ATU(I)-ATL(I)))
26887 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
26888 RMG(I)=(PMG(I)/PMMX)**2
26889 230 CONTINUE
26890 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26891 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
26892
26893C...Weight with matrix element (if none known, use beta factor).
26894 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26895 IF(MMED.EQ.1) THEN
26896 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26897 ELSEIF(MMED.EQ.2) THEN
26898 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26899 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26900 ELSEIF(MMED.EQ.3) THEN
26901 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26902 ELSE
26903 WTBE=FLAM
26904 ENDIF
26905 IF(WTBE.LT.PYR(0)) GOTO 220
26906 RET1=PMG(1)
26907 RET2=PMG(2)
26908
26909C...Find suitable set of masses for initialization of 2 -> 2 processes.
26910 ELSEIF(MOFSH.EQ.3) THEN
26911 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26912 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26913 PMG(2)=PMD(2)
26914 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26915 PMG(1)=PMD(1)
26916 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26917 ELSE
26918 IDIV=-1
26919 240 IDIV=IDIV+1
26920 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26921 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26922 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26923 ENDIF
26924 RET1=PMG(1)
26925 RET2=PMG(2)
26926
26927C...Evaluate importance of excluded tails of Breit-Wigners.
26928 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26929 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26930 IF(MEQL.LE.1) THEN
26931 VINT(80)=1D0
26932 DO 250 I=1,2
26933 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26934 & PARU(1)
26935 250 CONTINUE
26936 ELSE
26937 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26938 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26939 ENDIF
26940 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26941 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26942 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26943 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26944
26945C...Pick one particle to be the lighter (if improves efficiency).
26946 ELSEIF(MOFSH.EQ.4) THEN
26947 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26948 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26949 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26950
26951C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26952 DO 270 I=1,2
26953 IF(MBW(I).EQ.0) GOTO 270
26954 PMV=PMU(I)
26955 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26956 ATV=ATU(I)
26957 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26958 RBR=PYR(0)
26959 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26960 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26961 IF(RBR.LT.0.8D0) THEN
26962 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26963 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26964 ELSEIF(RBR.LT.0.9D0) THEN
26965 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26966 ELSEIF(RBR.LT.1.5D0) THEN
26967 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26968 ELSE
26969 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26970 & (PMV**2-PML(I)**2))))
26971 ENDIF
26972 270 CONTINUE
26973 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26974 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26975 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26976 NGEN(0,1)=NGEN(0,1)+1
26977 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26978 GOTO 260
26979 ELSE
26980 MINT(51)=1
26981 RETURN
26982 ENDIF
26983 ENDIF
26984 RET1=PMG(1)
26985 RET2=PMG(2)
26986
26987C...Give weight for selected mass distribution.
26988 VINT(80)=1D0
26989 DO 280 I=1,2
26990 IF(MBW(I).EQ.0) GOTO 280
26991 PMV=PMU(I)
26992 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26993 ATV=ATU(I)
26994 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26995 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26996 & (PMD(I)*PGD(I))**2)/PARU(1)
26997 F1=1D0
26998 F2=1D0/PMG(I)**2
26999 F3=1D0/PMG(I)**4
27000 FI0=(ATV-ATL(I))/PARU(1)
27001 FI1=PMV**2-PML(I)**2
27002 FI2=2D0*LOG(PMV/PML(I))
27003 FI3=1D0/PML(I)**2-1D0/PMV**2
27004 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27005 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27006 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27007 & 5D0*F3/FI3))
27008 ELSE
27009 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27010 ENDIF
27011 VINT(80)=VINT(80)*FI0
27012 280 CONTINUE
27013 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27014 ENDIF
27015
27016 RETURN
27017 END
27018
27019C***********************************************************************
27020
27021C...PYRECO
27022C...Handles the possibility of colour reconnection in W+W- events,
27023C...Based on the main scenarios of the Sjostrand and Khoze study:
27024C...I, II, II', intermediate and instantaneous; plus one model
27025C...along the lines of the Gustafson and Hakkinen: GH.
27026C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27027C...is as if first resonance is W+ and second W-.
27028
27029 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27030
27031C...Double precision and integer declarations.
27032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27033 IMPLICIT INTEGER(I-N)
27034 INTEGER PYK,PYCHGE,PYCOMP
27035C...Parameter value; number of points in MC integration.
27036 PARAMETER (NPT=100)
27037C...Commonblocks.
27038 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27039 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27040 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27041 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27042 COMMON/PYINT1/MINT(400),VINT(400)
27043 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27044C...Local arrays.
27045 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27046 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27047 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27048 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27049 &TMC(20),IJOIN(100)
27050
27051C...Functions to give four-product and to do determinants.
27052 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)
27053 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27054 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27055 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27056
27057C...Only allow fraction of recoupling for GH, intermediate and
27058C...instantaneous.
27059 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27060 IF(PYR(0).GT.PARP(120)) RETURN
27061 ENDIF
27062 ISUB=MINT(1)
27063
27064C...Common part for scenarios I, II, II', and GH.
27065 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27066 &MSTP(115).EQ.5) THEN
27067
27068C...Read out frequently-used parameters.
27069 PI=PARU(1)
27070 HBAR=PARU(3)
27071 PMW=PMAS(24,1)
27072 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27073 PGW=PMAS(24,2)
27074 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27075 TFRAG=PARP(115)
27076 RHAD=PARP(116)
27077 FACT=PARP(117)
27078 BLOWR=PARP(118)
27079 BLOWT=PARP(119)
27080
27081C...Find range of decay products of the W's.
27082C...Background: the W's are stored in IW1 and IW2.
27083C...Their direct decay products in NSD1+1 through NSD1+4.
27084C...Products after shower (if any) in NSD1+5 through NAFT1
27085C...for first W and in NAFT1+1 through N for the second.
27086 IF(NAFT1.GT.NSD1+4) THEN
27087 NBEG(1)=NSD1+5
27088 NEND(1)=NAFT1
27089 ELSE
27090 NBEG(1)=NSD1+1
27091 NEND(1)=NSD1+2
27092 ENDIF
27093 IF(N.GT.NAFT1) THEN
27094 NBEG(2)=NAFT1+1
27095 NEND(2)=N
27096 ELSE
27097 NBEG(2)=NSD1+3
27098 NEND(2)=NSD1+4
27099 ENDIF
27100
27101C...Rearrange parton shower products along strings.
27102 NOLD=N
27103 CALL PYPREP(NSD1+1)
27104 IF(MINT(51).NE.0) RETURN
27105
27106C...Find partons pointing back to W+ and W-; store them with quark
27107C...end of string first.
27108 NNP=0
27109 NNM=0
27110 ISGP=0
27111 ISGM=0
27112 DO 120 I=NOLD+1,N
27113 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27114 IF(IABS(K(I,2)).GE.22) GOTO 120
27115 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27116 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27117 NNP=NNP+1
27118 IF(ISGP.EQ.1) THEN
27119 INP(NNP)=I
27120 ELSE
27121 DO 100 I1=NNP,2,-1
27122 INP(I1)=INP(I1-1)
27123 100 CONTINUE
27124 INP(1)=I
27125 ENDIF
27126 IF(K(I,1).EQ.1) ISGP=0
27127 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27128 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27129 NNM=NNM+1
27130 IF(ISGM.EQ.1) THEN
27131 INM(NNM)=I
27132 ELSE
27133 DO 110 I1=NNM,2,-1
27134 INM(I1)=INM(I1-1)
27135 110 CONTINUE
27136 INM(1)=I
27137 ENDIF
27138 IF(K(I,1).EQ.1) ISGM=0
27139 ENDIF
27140 120 CONTINUE
27141
27142C...Boost to W+W- rest frame (not strictly needed).
27143 DO 130 J=1,3
27144 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27145 130 CONTINUE
27146 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27147 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27148 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27149
27150C...Select decay vertices of W+ and W-.
27151 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27152 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27153 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27154 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
27155 GTMAX=MAX(TP,TM)
27156 DO 140 J=1,3
27157 XP(J)=TP*P(IW1,J)/P(IW1,4)
27158 XM(J)=TM*P(IW2,J)/P(IW2,4)
27159 140 CONTINUE
27160
27161C...Begin scenario I specifics.
27162 IF(MSTP(115).EQ.1) THEN
27163
27164C...Reconstruct velocity and direction of W+ string pieces.
27165 DO 170 IIP=1,NNP-1
27166 IF(K(INP(IIP),2).LT.0) GOTO 170
27167 I1=INP(IIP)
27168 I2=INP(IIP+1)
27169 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27170 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27171 DO 150 J=1,3
27172 V1(J)=P(I1,J)/P1A
27173 V2(J)=P(I2,J)/P2A
27174 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
27175 DIRP(IIP,J)=V1(J)-V2(J)
27176 150 CONTINUE
27177 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
27178 & BETP(IIP,3)**2)
27179 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
27180 DO 160 J=1,3
27181 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
27182 160 CONTINUE
27183 170 CONTINUE
27184
27185C...Reconstruct velocity and direction of W- string pieces.
27186 DO 200 IIM=1,NNM-1
27187 IF(K(INM(IIM),2).LT.0) GOTO 200
27188 I1=INM(IIM)
27189 I2=INM(IIM+1)
27190 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27191 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27192 DO 180 J=1,3
27193 V1(J)=P(I1,J)/P1A
27194 V2(J)=P(I2,J)/P2A
27195 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
27196 DIRM(IIM,J)=V1(J)-V2(J)
27197 180 CONTINUE
27198 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
27199 & BETM(IIM,3)**2)
27200 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
27201 DO 190 J=1,3
27202 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
27203 190 CONTINUE
27204 200 CONTINUE
27205
27206C...Loop over number of space-time points.
27207 NACC=0
27208 SUM=0D0
27209 DO 250 IPT=1,NPT
27210
27211C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27212 R=SQRT(-LOG(PYR(0)))
27213 PHI=2D0*PI*PYR(0)
27214 X=BLOWR*RHAD*R*COS(PHI)
27215 Y=BLOWR*RHAD*R*SIN(PHI)
27216 R=SQRT(-LOG(PYR(0)))
27217 PHI=2D0*PI*PYR(0)
27218 Z=BLOWR*RHAD*R*COS(PHI)
27219 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
27220
27221C...Reject impossible points. Weight for sample distribution.
27222 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
27223 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
27224 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
27225
27226C...Loop over W+ string pieces and find one with largest weight.
27227 IMAXP=0
27228 WTMAXP=1D-10
27229 XD(1)=X-XP(1)
27230 XD(2)=Y-XP(2)
27231 XD(3)=Z-XP(3)
27232 XD(4)=T-TP
27233 DO 220 IIP=1,NNP-1
27234 IF(K(INP(IIP),2).LT.0) GOTO 220
27235 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
27236 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
27237 DO 210 J=1,3
27238 XB(J)=XD(J)+BEDG*BETP(IIP,J)
27239 210 CONTINUE
27240 XB(4)=BETP(IIP,4)*(XD(4)-BED)
27241 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27242 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
27243 & DIRP(IIP,3)*XB(3))**2
27244 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27245 & TFRAG**2)
27246 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
27247 IF(WTP.GT.WTMAXP) THEN
27248 IMAXP=IIP
27249 WTMAXP=WTP
27250 ENDIF
27251 220 CONTINUE
27252
27253C...Loop over W- string pieces and find one with largest weight.
27254 IMAXM=0
27255 WTMAXM=1D-10
27256 XD(1)=X-XM(1)
27257 XD(2)=Y-XM(2)
27258 XD(3)=Z-XM(3)
27259 XD(4)=T-TM
27260 DO 240 IIM=1,NNM-1
27261 IF(K(INM(IIM),2).LT.0) GOTO 240
27262 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
27263 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
27264 DO 230 J=1,3
27265 XB(J)=XD(J)+BEDG*BETM(IIM,J)
27266 230 CONTINUE
27267 XB(4)=BETM(IIM,4)*(XD(4)-BED)
27268 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27269 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
27270 & DIRM(IIM,3)*XB(3))**2
27271 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27272 & TFRAG**2)
27273 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
27274 IF(WTM.GT.WTMAXM) THEN
27275 IMAXM=IIM
27276 WTMAXM=WTM
27277 ENDIF
27278 240 CONTINUE
27279
27280C...Result of integration.
27281 WT=0D0
27282 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
27283 WT=WTMAXP*WTMAXM/WTSMP
27284 SUM=SUM+WT
27285 NACC=NACC+1
27286 IAP(NACC)=IMAXP
27287 IAM(NACC)=IMAXM
27288 WTA(NACC)=WT
27289 ENDIF
27290 250 CONTINUE
27291 RES=BLOWR**3*BLOWT*SUM/NPT
27292
27293C...Decide whether to reconnect and, if so, where.
27294 IACC=0
27295 PREC=1D0-EXP(-FACT*RES)
27296 IF(PREC.GT.PYR(0)) THEN
27297 RSUM=PYR(0)*SUM
27298 DO 260 IA=1,NACC
27299 IACC=IA
27300 RSUM=RSUM-WTA(IA)
27301 IF(RSUM.LE.0D0) GOTO 270
27302 260 CONTINUE
27303 270 IIP=IAP(IACC)
27304 IIM=IAM(IACC)
27305 ENDIF
27306
27307C...Begin scenario II and II' specifics.
27308 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
27309
27310C...Loop through all string pieces, one from W+ and one from W-.
27311 NCROSS=0
27312 TC(0)=0D0
27313 DO 340 IIP=1,NNP-1
27314 IF(K(INP(IIP),2).LT.0) GOTO 340
27315 I1P=INP(IIP)
27316 I2P=INP(IIP+1)
27317 DO 330 IIM=1,NNM-1
27318 IF(K(INM(IIM),2).LT.0) GOTO 330
27319 I1M=INM(IIM)
27320 I2M=INM(IIM+1)
27321
27322C...Find endpoint velocity vectors.
27323 DO 280 J=1,3
27324 V1P(J)=P(I1P,J)/P(I1P,4)
27325 V2P(J)=P(I2P,J)/P(I2P,4)
27326 V1M(J)=P(I1M,J)/P(I1M,4)
27327 V2M(J)=P(I2M,J)/P(I2M,4)
27328 280 CONTINUE
27329
27330C...Define q matrix and find t.
27331 DO 290 J=1,3
27332 Q(1,J)=V2P(J)-V1P(J)
27333 Q(2,J)=-(V2M(J)-V1M(J))
27334 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
27335 Q(4,J)=V1P(J)-V1M(J)
27336 290 CONTINUE
27337 T=-DETER(1,2,3)/DETER(1,2,4)
27338
27339C...Find alpha and beta; i.e. coordinates of crossing point.
27340 S11=Q(1,1)*(T-TP)
27341 S12=Q(2,1)*(T-TM)
27342 S13=Q(3,1)+Q(4,1)*T
27343 S21=Q(1,2)*(T-TP)
27344 S22=Q(2,2)*(T-TM)
27345 S23=Q(3,2)+Q(4,2)*T
27346 DEN=S11*S22-S12*S21
27347 ALP=(S12*S23-S22*S13)/DEN
27348 BET=(S21*S13-S11*S23)/DEN
27349
27350C...Check if solution acceptable.
27351 IANSW=1
27352 IF(T.LT.GTMAX) IANSW=0
27353 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
27354 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
27355
27356C...Find point of crossing and check that not inconsistent.
27357 DO 300 J=1,3
27358 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
27359 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
27360 300 CONTINUE
27361 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
27362 & (XPP(3)-XMM(3))**2
27363 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
27364 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
27365 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
27366
27367C...Find string eigentimes at crossing.
27368 IF(IANSW.EQ.1) THEN
27369 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
27370 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
27371 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
27372 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
27373 ELSE
27374 TAUP=0D0
27375 TAUM=0D0
27376 ENDIF
27377
27378C...Order crossings by time. End loop over crossings.
27379 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
27380 NCROSS=NCROSS+1
27381 DO 310 I1=NCROSS,1,-1
27382 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
27383 IPC(I1)=IIP
27384 IMC(I1)=IIM
27385 TC(I1)=T
27386 TPC(I1)=TAUP
27387 TMC(I1)=TAUM
27388 GOTO 320
27389 ELSE
27390 IPC(I1)=IPC(I1-1)
27391 IMC(I1)=IMC(I1-1)
27392 TC(I1)=TC(I1-1)
27393 TPC(I1)=TPC(I1-1)
27394 TMC(I1)=TMC(I1-1)
27395 ENDIF
27396 310 CONTINUE
27397 320 CONTINUE
27398 ENDIF
27399 330 CONTINUE
27400 340 CONTINUE
27401
27402C...Loop over crossings; find first (if any) acceptable one.
27403 IACC=0
27404 IF(NCROSS.GE.1) THEN
27405 DO 350 IC=1,NCROSS
27406 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
27407 IF(PNFRAG.GT.PYR(0)) THEN
27408C...Scenario II: only compare with fragmentation time.
27409 IF(MSTP(115).EQ.2) THEN
27410 IACC=IC
27411 IIP=IPC(IACC)
27412 IIM=IMC(IACC)
27413 GOTO 360
27414C...Scenario II': also require that string length decreases.
27415 ELSE
27416 IIP=IPC(IC)
27417 IIM=IMC(IC)
27418 I1P=INP(IIP)
27419 I2P=INP(IIP+1)
27420 I1M=INM(IIM)
27421 I2M=INM(IIM+1)
27422 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27423 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27424 IF(ELNEW.LT.ELOLD) THEN
27425 IACC=IC
27426 IIP=IPC(IACC)
27427 IIM=IMC(IACC)
27428 GOTO 360
27429 ENDIF
27430 ENDIF
27431 ENDIF
27432 350 CONTINUE
27433 360 CONTINUE
27434 ENDIF
27435
27436C...Begin scenario GH specifics.
27437 ELSEIF(MSTP(115).EQ.5) THEN
27438
27439C...Loop through all string pieces, one from W+ and one from W-.
27440 IACC=0
27441 ELMIN=1D0
27442 DO 380 IIP=1,NNP-1
27443 IF(K(INP(IIP),2).LT.0) GOTO 380
27444 I1P=INP(IIP)
27445 I2P=INP(IIP+1)
27446 DO 370 IIM=1,NNM-1
27447 IF(K(INM(IIM),2).LT.0) GOTO 370
27448 I1M=INM(IIM)
27449 I2M=INM(IIM+1)
27450
27451C...Look for largest decrease of (exponent of) Lambda measure.
27452 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27453 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27454 ELDIF=ELNEW/MAX(1D-10,ELOLD)
27455 IF(ELDIF.LT.ELMIN) THEN
27456 IACC=IIP+IIM
27457 ELMIN=ELDIF
27458 IPC(1)=IIP
27459 IMC(1)=IIM
27460 ENDIF
27461 370 CONTINUE
27462 380 CONTINUE
27463 IIP=IPC(1)
27464 IIM=IMC(1)
27465 ENDIF
27466
27467C...Common for scenarios I, II, II' and GH: reconnect strings.
27468 IF(IACC.NE.0) THEN
27469 MINT(32)=1
27470 NJOIN=0
27471 DO 390 IS=1,NNP+NNM
27472 NJOIN=NJOIN+1
27473 IF(IS.LE.IIP) THEN
27474 I=INP(IS)
27475 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
27476 I=INM(IS-IIP+IIM)
27477 ELSEIF(IS.LE.IIP+NNM) THEN
27478 I=INM(IS-IIP-NNM+IIM)
27479 ELSE
27480 I=INP(IS-NNM)
27481 ENDIF
27482 IJOIN(NJOIN)=I
27483 IF(K(I,2).LT.0) THEN
27484 CALL PYJOIN(NJOIN,IJOIN)
27485 NJOIN=0
27486 ENDIF
27487 390 CONTINUE
27488
27489C...Restore original event record if no reconnection.
27490 ELSE
27491 DO 400 I=NSD1+1,NOLD
27492 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
27493 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27494 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27495 ENDIF
27496 400 CONTINUE
27497 DO 410 I=NOLD+1,N
27498 K(K(I,3),1)=3
27499 410 CONTINUE
27500 N=NOLD
27501 ENDIF
27502
27503C...Boost back system.
27504 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27505 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27506 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
27507 & BEWW(1),BEWW(2),BEWW(3))
27508
27509C...Common part for intermediate and instantaneous scenarios.
27510 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27511 MINT(32)=1
27512
27513C...Remove old shower products and reset showering ones.
27514 N=NSD1+4
27515 DO 420 I=NSD1+1,NSD1+4
27516 K(I,1)=3
27517 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27518 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27519 420 CONTINUE
27520
27521C...Identify quark-antiquark pairs.
27522 IQ1=NSD1+1
27523 IQ2=NSD1+2
27524 IQ3=NSD1+3
27525 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
27526 IQ4=2*NSD1+7-IQ3
27527
27528C...Reconnect strings.
27529 IJOIN(1)=IQ1
27530 IJOIN(2)=IQ4
27531 CALL PYJOIN(2,IJOIN)
27532 IJOIN(1)=IQ3
27533 IJOIN(2)=IQ2
27534 CALL PYJOIN(2,IJOIN)
27535
27536C...Do new parton showers in intermediate scenario.
27537 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
27538 MSTJ50=MSTJ(50)
27539 MSTJ(50)=0
27540 if(parj(200).ne.1.) CALL PYSHOW(IQ1,IQ2,P(IW1,5))
27541 if(parj(200).eq.1.) CALL PYSHOWQ(IQ1,IQ2,P(IW1,5))
27542 if(parj(200).ne.1.) CALL PYSHOW(IQ3,IQ4,P(IW2,5))
27543 if(parj(200).eq.1.) CALL PYSHOWQ(IQ3,IQ4,P(IW2,5))
27544 MSTJ(50)=MSTJ50
27545
27546C...Do new parton showers in instantaneous scenario.
27547 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
27548 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
27549 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
27550 PPM=SQRT(MAX(0D0,PPM2))
27551 if(parj(200).ne.1.) CALL PYSHOW(IQ1,IQ4,PPM)
27552 if(parj(200).eq.1.) CALL PYSHOWQ(IQ1,IQ4,PPM)
27553 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
27554 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
27555 PPM=SQRT(MAX(0D0,PPM2))
27556 if(parj(200).ne.1.) CALL PYSHOW(IQ3,IQ2,PPM)
27557 if(parj(200).eq.1.) CALL PYSHOWQ(IQ3,IQ2,PPM)
27558 ENDIF
27559 ENDIF
27560
27561 RETURN
27562 END
27563
27564C***********************************************************************
27565
27566C...PYKLIM
27567C...Checks generated variables against pre-set kinematical limits;
27568C...also calculates limits on variables used in generation.
27569
27570 SUBROUTINE PYKLIM(ILIM)
27571
27572C...Double precision and integer declarations.
27573 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27574 IMPLICIT INTEGER(I-N)
27575 INTEGER PYK,PYCHGE,PYCOMP
27576C...Commonblocks.
27577 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27578 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27579 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27580 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27581 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27582 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27583 COMMON/PYINT1/MINT(400),VINT(400)
27584 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27585 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27586 &/PYINT1/,/PYINT2/
27587
27588C...Common kinematical expressions.
27589 MINT(51)=0
27590 ISUB=MINT(1)
27591 ISTSB=ISET(ISUB)
27592 IF(ISUB.EQ.96) GOTO 100
27593 SQM3=VINT(63)
27594 SQM4=VINT(64)
27595 IF(ILIM.NE.0) THEN
27596 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
27597 CKIN09=MAX(CKIN(9),CKIN(13))
27598 CKIN10=MIN(CKIN(10),CKIN(14))
27599 CKIN11=MAX(CKIN(11),CKIN(15))
27600 CKIN12=MIN(CKIN(12),CKIN(16))
27601 ELSE
27602 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
27603 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
27604 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
27605 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
27606 ENDIF
27607 ENDIF
27608 IF(ILIM.NE.1) THEN
27609 TAU=VINT(21)
27610 RM3=SQM3/(TAU*VINT(2))
27611 RM4=SQM4/(TAU*VINT(2))
27612 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27613 ENDIF
27614 PTHMIN=CKIN(3)
27615 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
27616 &PTHMIN=MAX(CKIN(3),CKIN(5))
27617
27618 IF(ILIM.EQ.0) THEN
27619C...Check generated values of tau, y*, cos(theta-hat), and tau' against
27620C...pre-set kinematical limits.
27621 YST=VINT(22)
27622 CTH=VINT(23)
27623 TAUP=VINT(26)
27624 TAUE=TAU
27625 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27626 X1=SQRT(TAUE)*EXP(YST)
27627 X2=SQRT(TAUE)*EXP(-YST)
27628 XF=X1-X2
27629 IF(MINT(47).NE.1) THEN
27630 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
27631 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
27632 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
27633 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
27634 ENDIF
27635 IF(MINT(45).NE.1) THEN
27636 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
27637 ENDIF
27638 IF(MINT(46).NE.1) THEN
27639 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
27640 ENDIF
27641 IF(MINT(45).EQ.2) THEN
27642 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27643 ENDIF
27644 IF(MINT(46).EQ.2) THEN
27645 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27646 ENDIF
27647 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
27648 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
27649 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
27650 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
27651 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
27652 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
27653 Y3=YST+0.5D0*LOG(EXPY3)
27654 Y4=YST+0.5D0*LOG(EXPY4)
27655 YLARGE=MAX(Y3,Y4)
27656 YSMALL=MIN(Y3,Y4)
27657 ETALAR=20D0
27658 ETASMA=-20D0
27659 STH=SQRT(MAX(0D0,1D0-CTH**2))
27660 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
27661 & CTH)**2-4D0*RM3))
27662 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
27663 & CTH)**2-4D0*RM4))
27664 IF(STH.GE.1D-10) THEN
27665 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
27666 & (BE34*STH)
27667 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
27668 & (BE34*STH)
27669 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
27670 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
27671 ETALAR=MAX(ETA3,ETA4)
27672 ETASMA=MIN(ETA3,ETA4)
27673 ENDIF
27674 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
27675 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
27676 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
27677 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
27678 SH=TAU*VINT(2)
27679 RPTS=4D0*VINT(71)**2/SH
27680 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27681 RM34=MAX(1D-20,2D0*RM3*RM4)
27682 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27683 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27684 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27685 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
27686 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27687 IF(PTH.LT.PTHMIN) MINT(51)=1
27688 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
27689 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
27690 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
27691 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
27692 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
27693 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
27694 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
27695 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
27696 IF(THA.LT.CKIN(35)) MINT(51)=1
27697 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
27698 IF(UHA.LT.CKIN(37)) MINT(51)=1
27699 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
27700 ENDIF
27701 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27702 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
27703 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
27704 ENDIF
27705
27706C...Additional cuts on W2 (approximately) in DIS.
27707 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
27708 XBJ=X2
27709 IF(IABS(MINT(12)).LT.20) XBJ=X1
27710 Q2BJ=THA
27711 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
27712 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
27713 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
27714 ENDIF
27715
27716 ELSEIF(ILIM.EQ.1) THEN
27717C...Calculate limits on tau
27718C...0) due to definition
27719 TAUMN0=0D0
27720 TAUMX0=1D0
27721C...1) due to limits on subsystem mass
27722 TAUMN1=CKIN(1)**2/VINT(2)
27723 TAUMX1=1D0
27724 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
27725C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
27726 TM3=SQRT(SQM3+PTHMIN**2)
27727 TM4=SQRT(SQM4+PTHMIN**2)
27728 YDCOSH=1D0
27729 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
27730 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
27731 TAUMX2=1D0
27732C...3) due to limits on pT-hat and cos(theta-hat)
27733 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
27734 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
27735 TAUMN3=0D0
27736 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
27737 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
27738 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
27739 TAUMX3=1D0
27740 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
27741 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
27742 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
27743C...4) due to limits on x1 and x2
27744 TAUMN4=CKIN(21)*CKIN(23)
27745 TAUMX4=CKIN(22)*CKIN(24)
27746C...5) due to limits on xF
27747 TAUMN5=0D0
27748 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
27749C...6) due to limits on that and uhat
27750 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
27751 TAUMX6=1D0
27752 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
27753 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
27754
27755C...Net effect of all separate limits.
27756 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
27757 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
27758 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27759 VINT(11)=1D0-1D-9
27760 VINT(31)=1D0+1D-9
27761 ELSEIF(MINT(47).EQ.5) THEN
27762 VINT(31)=MIN(VINT(31),1D0-2D-10)
27763 ELSEIF(MINT(47).GE.6) THEN
27764 VINT(31)=MIN(VINT(31),1D0-1D-10)
27765 ENDIF
27766 IF(VINT(31).LE.VINT(11)) MINT(51)=1
27767
27768 ELSEIF(ILIM.EQ.2) THEN
27769C...Calculate limits on y*
27770 TAUE=TAU
27771 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27772 TAURT=SQRT(TAUE)
27773C...0) due to kinematics
27774 YSTMN0=LOG(TAURT)
27775 YSTMX0=-YSTMN0
27776C...1) due to explicit limits
27777 YSTMN1=CKIN(7)
27778 YSTMX1=CKIN(8)
27779C...2) due to limits on x1
27780 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
27781 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
27782C...3) due to limits on x2
27783 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
27784 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
27785C...4) due to limits on xF
27786 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
27787 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
27788 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
27789 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
27790C...5) due to simultaneous limits on y-large and y-small
27791 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
27792 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
27793 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
27794 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
27795 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
27796 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
27797C...6) due to simultaneous limits on cos(theta-hat) and y-large or
27798C... y-small
27799 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
27800 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
27801 RZMX=BE34*MIN(CKIN(28),CTHLIM)
27802 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
27803 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
27804 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
27805 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
27806 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
27807 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
27808
27809C...Net effect of all separate limits.
27810 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
27811 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
27812 IF(MINT(47).EQ.1) THEN
27813 VINT(12)=-1D-9
27814 VINT(32)=1D-9
27815 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27816 VINT(12)=(1D0-1D-9)*YSTMX0
27817 VINT(32)=(1D0+1D-9)*YSTMX0
27818 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27819 VINT(12)=-(1D0+1D-9)*YSTMX0
27820 VINT(32)=-(1D0-1D-9)*YSTMX0
27821 ELSEIF(MINT(47).EQ.5) THEN
27822 YSTEE=LOG((1D0-1D-10)/TAURT)
27823 VINT(12)=MAX(VINT(12),-YSTEE)
27824 VINT(32)=MIN(VINT(32),YSTEE)
27825 ENDIF
27826 IF(VINT(32).LE.VINT(12)) MINT(51)=1
27827
27828 ELSEIF(ILIM.EQ.3) THEN
27829C...Calculate limits on cos(theta-hat)
27830 YST=VINT(22)
27831C...0) due to definition
27832 CTNMN0=-1D0
27833 CTNMX0=0D0
27834 CTPMN0=0D0
27835 CTPMX0=1D0
27836C...1) due to explicit limits
27837 CTNMN1=MIN(0D0,CKIN(27))
27838 CTNMX1=MIN(0D0,CKIN(28))
27839 CTPMN1=MAX(0D0,CKIN(27))
27840 CTPMX1=MAX(0D0,CKIN(28))
27841C...2) due to limits on pT-hat
27842 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
27843 CTPMX2=-CTNMN2
27844 CTNMX2=0D0
27845 CTPMN2=0D0
27846 IF(CKIN(4).GE.0D0) THEN
27847 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
27848 & (BE34**2*TAU*VINT(2))))
27849 CTPMN2=-CTNMX2
27850 ENDIF
27851C...3) due to limits on y-large and y-small
27852 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
27853 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
27854 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
27855 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
27856 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
27857 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
27858 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
27859 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
27860C...4) due to limits on that
27861 CTNMN4=-1D0
27862 CTNMX4=0D0
27863 CTPMN4=0D0
27864 CTPMX4=1D0
27865 SH=TAU*VINT(2)
27866 IF(CKIN(35).GT.0D0) THEN
27867 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
27868 IF(CTLIM.GT.0D0) THEN
27869 CTPMX4=CTLIM
27870 ELSE
27871 CTPMX4=0D0
27872 CTNMX4=CTLIM
27873 ENDIF
27874 ENDIF
27875 IF(CKIN(36).GT.0D0) THEN
27876 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
27877 IF(CTLIM.LT.0D0) THEN
27878 CTNMN4=CTLIM
27879 ELSE
27880 CTNMN4=0D0
27881 CTPMN4=CTLIM
27882 ENDIF
27883 ENDIF
27884C...5) due to limits on uhat
27885 CTNMN5=-1D0
27886 CTNMX5=0D0
27887 CTPMN5=0D0
27888 CTPMX5=1D0
27889 IF(CKIN(37).GT.0D0) THEN
27890 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
27891 IF(CTLIM.LT.0D0) THEN
27892 CTNMN5=CTLIM
27893 ELSE
27894 CTNMN5=0D0
27895 CTPMN5=CTLIM
27896 ENDIF
27897 ENDIF
27898 IF(CKIN(38).GT.0D0) THEN
27899 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27900 IF(CTLIM.GT.0D0) THEN
27901 CTPMX5=CTLIM
27902 ELSE
27903 CTPMX5=0D0
27904 CTNMX5=CTLIM
27905 ENDIF
27906 ENDIF
27907
27908C...Net effect of all separate limits.
27909 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27910 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27911 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27912 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27913 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27914
27915 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
27916 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
27917
27918 ELSEIF(ILIM.EQ.4) THEN
27919C...Calculate limits on tau'
27920C...0) due to kinematics
27921 TAPMN0=TAU
27922 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27923 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27924 TAPMN0=(SQRT(TAU)+PQRAT)**2
27925 ENDIF
27926 TAPMX0=1D0
27927C...1) due to explicit limits
27928 TAPMN1=CKIN(31)**2/VINT(2)
27929 TAPMX1=1D0
27930 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27931
27932C...Net effect of all separate limits.
27933 VINT(16)=MAX(TAPMN0,TAPMN1)
27934 VINT(36)=MIN(TAPMX0,TAPMX1)
27935 IF(MINT(47).EQ.1) THEN
27936 VINT(16)=1D0-1D-9
27937 VINT(36)=1D0+1D-9
27938 ELSEIF(MINT(47).EQ.5) THEN
27939 VINT(36)=MIN(VINT(36),1D0-2D-10)
27940 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27941 VINT(36)=MIN(VINT(36),1D0-1D-10)
27942 ENDIF
27943 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27944
27945 ENDIF
27946 RETURN
27947
27948C...Special case for low-pT and multiple interactions:
27949C...effective kinematical limits for tau, y*, cos(theta-hat).
27950 100 IF(ILIM.EQ.0) THEN
27951 ELSEIF(ILIM.EQ.1) THEN
27952 IF(MSTP(82).LE.1) THEN
27953 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27954 & VINT(2)
27955 ELSE
27956 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27957 ENDIF
27958 VINT(31)=1D0
27959 ELSEIF(ILIM.EQ.2) THEN
27960 VINT(12)=0.5D0*LOG(VINT(21))
27961 VINT(32)=-VINT(12)
27962 ELSEIF(ILIM.EQ.3) THEN
27963 IF(MSTP(82).LE.1) THEN
27964 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27965 & (VINT(21)*VINT(2))
27966 ELSE
27967 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27968 & (VINT(21)*VINT(2))
27969 ENDIF
27970 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27971 VINT(33)=0D0
27972 VINT(14)=0D0
27973 VINT(34)=-VINT(13)
27974 ENDIF
27975
27976 RETURN
27977 END
27978
27979C*********************************************************************
27980
27981C...PYKMAP
27982C...Maps a uniform distribution into a distribution of a kinematical
27983C...variable according to one of the possibilities allowed. It is
27984C...assumed that kinematical limits have been set by a PYKLIM call.
27985
27986 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27987
27988C...Double precision and integer declarations.
27989 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27990 IMPLICIT INTEGER(I-N)
27991 INTEGER PYK,PYCHGE,PYCOMP
27992C...Commonblocks.
27993 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27994 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27995 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27996 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27997 COMMON/PYINT1/MINT(400),VINT(400)
27998 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27999 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28000
28001C...Convert VVAR to tau variable.
28002 ISUB=MINT(1)
28003 ISTSB=ISET(ISUB)
28004 IF(IVAR.EQ.1) THEN
28005 TAUMIN=VINT(11)
28006 TAUMAX=VINT(31)
28007 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28008 TAURE=VINT(73)
28009 GAMRE=VINT(74)
28010 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28011 TAURE=VINT(75)
28012 GAMRE=VINT(76)
28013 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28014 TAURE=VINT(77)
28015 GAMRE=VINT(78)
28016 ENDIF
28017 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28018 TAU=1D0
28019 ELSEIF(MVAR.EQ.1) THEN
28020 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28021 ELSEIF(MVAR.EQ.2) THEN
28022 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28023 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28024 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28025 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28026 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28027 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28028 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28029 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28030 ELSEIF(MINT(47).EQ.5) THEN
28031 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28032 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28033 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28034 ELSE
28035 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28036 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28037 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28038 ENDIF
28039 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28040
28041C...Convert VVAR to y* variable.
28042 ELSEIF(IVAR.EQ.2) THEN
28043 YSTMIN=VINT(12)
28044 YSTMAX=VINT(32)
28045 TAUE=VINT(21)
28046 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28047 IF(MINT(47).EQ.1) THEN
28048 YST=0D0
28049 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28050 YST=-0.5D0*LOG(TAUE)
28051 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28052 YST=0.5D0*LOG(TAUE)
28053 ELSEIF(MVAR.EQ.1) THEN
28054 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28055 ELSEIF(MVAR.EQ.2) THEN
28056 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28057 ELSEIF(MVAR.EQ.3) THEN
28058 AUPP=ATAN(EXP(YSTMAX))
28059 ALOW=ATAN(EXP(YSTMIN))
28060 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28061 ELSEIF(MVAR.EQ.4) THEN
28062 YST0=-0.5D0*LOG(TAUE)
28063 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28064 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28065 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28066 ELSE
28067 YST0=-0.5D0*LOG(TAUE)
28068 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28069 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28070 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28071 ENDIF
28072 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28073
28074C...Convert VVAR to cos(theta-hat) variable.
28075 ELSEIF(IVAR.EQ.3) THEN
28076 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28077 RSQM=1D0+RM34
28078 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28079 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28080 CTNMIN=VINT(13)
28081 CTNMAX=VINT(33)
28082 CTPMIN=VINT(14)
28083 CTPMAX=VINT(34)
28084 IF(MVAR.EQ.1) THEN
28085 ANEG=CTNMAX-CTNMIN
28086 APOS=CTPMAX-CTPMIN
28087 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28088 VCTN=VVAR*(ANEG+APOS)/ANEG
28089 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28090 ELSE
28091 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28092 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28093 ENDIF
28094 ELSEIF(MVAR.EQ.2) THEN
28095 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28096 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28097 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28098 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28099 ANEG=LOG(RMNMIN/RMNMAX)
28100 APOS=LOG(RMPMIN/RMPMAX)
28101 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28102 VCTN=VVAR*(ANEG+APOS)/ANEG
28103 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28104 ELSE
28105 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28106 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28107 ENDIF
28108 ELSEIF(MVAR.EQ.3) THEN
28109 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28110 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28111 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28112 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28113 ANEG=LOG(RMNMAX/RMNMIN)
28114 APOS=LOG(RMPMAX/RMPMIN)
28115 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28116 VCTN=VVAR*(ANEG+APOS)/ANEG
28117 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28118 ELSE
28119 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28120 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28121 ENDIF
28122 ELSEIF(MVAR.EQ.4) THEN
28123 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28124 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28125 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28126 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28127 ANEG=1D0/RMNMAX-1D0/RMNMIN
28128 APOS=1D0/RMPMAX-1D0/RMPMIN
28129 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28130 VCTN=VVAR*(ANEG+APOS)/ANEG
28131 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28132 ELSE
28133 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28134 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28135 ENDIF
28136 ELSEIF(MVAR.EQ.5) THEN
28137 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28138 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28139 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28140 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28141 ANEG=1D0/RMNMIN-1D0/RMNMAX
28142 APOS=1D0/RMPMIN-1D0/RMPMAX
28143 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28144 VCTN=VVAR*(ANEG+APOS)/ANEG
28145 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28146 ELSE
28147 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28148 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28149 ENDIF
28150 ENDIF
28151 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28152 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28153 VINT(23)=CTH
28154
28155C...Convert VVAR to tau' variable.
28156 ELSEIF(IVAR.EQ.4) THEN
28157 TAU=VINT(21)
28158 TAUPMN=VINT(16)
28159 TAUPMX=VINT(36)
28160 IF(MINT(47).EQ.1) THEN
28161 TAUP=1D0
28162 ELSEIF(MVAR.EQ.1) THEN
28163 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
28164 ELSEIF(MVAR.EQ.2) THEN
28165 AUPP=(1D0-TAU/TAUPMX)**4
28166 ALOW=(1D0-TAU/TAUPMN)**4
28167 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
28168 ELSEIF(MINT(47).EQ.5) THEN
28169 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
28170 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
28171 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28172 ELSE
28173 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
28174 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
28175 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28176 ENDIF
28177 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
28178
28179C...Selection of extra variables needed in 2 -> 3 process:
28180C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28181C...Since no options are available, the functions of PYKLIM
28182C...and PYKMAP are joint for these choices.
28183 ELSEIF(IVAR.EQ.5) THEN
28184
28185C...Read out total energy and particle masses.
28186 MINT(51)=0
28187 MPTPK=1
28188 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
28189 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
28190 & MPTPK=2
28191 SHP=VINT(26)*VINT(2)
28192 SHPR=SQRT(SHP)
28193 PM1=VINT(201)
28194 PM2=VINT(206)
28195 PM3=SQRT(VINT(21))*VINT(1)
28196 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
28197 MINT(51)=1
28198 RETURN
28199 ENDIF
28200 PMRS1=VINT(204)**2
28201 PMRS2=VINT(209)**2
28202
28203C...Specify coefficients of pT choice; upper and lower limits.
28204 IF(MPTPK.EQ.1) THEN
28205 HWT1=0.4D0
28206 HWT2=0.4D0
28207 ELSE
28208 HWT1=0.05D0
28209 HWT2=0.05D0
28210 ENDIF
28211 HWT3=1D0-HWT1-HWT2
28212 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
28213 & (4D0*SHP)
28214 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
28215 PTSMN1=CKIN(51)**2
28216 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
28217 & (4D0*SHP)
28218 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
28219 PTSMN2=CKIN(53)**2
28220
28221C...Select transverse momenta according to
28222C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28223 HMX=PMRS1+PTSMX1
28224 HMN=PMRS1+PTSMN1
28225 IF(HMX.LT.1.0001D0*HMN) THEN
28226 MINT(51)=1
28227 RETURN
28228 ENDIF
28229 HDE=PTSMX1-PTSMN1
28230 RPT=PYR(0)
28231 IF(RPT.LT.HWT1) THEN
28232 PTS1=PTSMN1+PYR(0)*HDE
28233 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28234 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
28235 ELSE
28236 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
28237 ENDIF
28238 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
28239 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
28240 HMX=PMRS2+PTSMX2
28241 HMN=PMRS2+PTSMN2
28242 IF(HMX.LT.1.0001D0*HMN) THEN
28243 MINT(51)=1
28244 RETURN
28245 ENDIF
28246 HDE=PTSMX2-PTSMN2
28247 RPT=PYR(0)
28248 IF(RPT.LT.HWT1) THEN
28249 PTS2=PTSMN2+PYR(0)*HDE
28250 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28251 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
28252 ELSE
28253 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
28254 ENDIF
28255 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
28256 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
28257
28258C...Select azimuthal angles and check pT choice.
28259 PHI1=PARU(2)*PYR(0)
28260 PHI2=PARU(2)*PYR(0)
28261 PHIR=PHI2-PHI1
28262 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
28263 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
28264 & CKIN(56)**2)) THEN
28265 MINT(51)=1
28266 RETURN
28267 ENDIF
28268
28269C...Calculate transverse masses and check phase space not closed.
28270 PMS1=PM1**2+PTS1
28271 PMS2=PM2**2+PTS2
28272 PMS3=PM3**2+PTS3
28273 PMT1=SQRT(PMS1)
28274 PMT2=SQRT(PMS2)
28275 PMT3=SQRT(PMS3)
28276 PM12=(PMT1+PMT2)**2
28277 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
28278 MINT(51)=1
28279 RETURN
28280 ENDIF
28281
28282C...Select rapidity for particle 3 and check phase space not closed.
28283 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
28284 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
28285 IF(Y3MAX.LT.1D-6) THEN
28286 MINT(51)=1
28287 RETURN
28288 ENDIF
28289 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
28290 PZ3=PMT3*SINH(Y3)
28291 PE3=PMT3*COSH(Y3)
28292
28293C...Find momentum transfers in two mirror solutions (in 1-2 frame).
28294 PZ12=-PZ3
28295 PE12=SHPR-PE3
28296 PMS12=PE12**2-PZ12**2
28297 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
28298 IF(SQL12.LT.1D-6*SHP) THEN
28299 MINT(51)=1
28300 RETURN
28301 ENDIF
28302 PMM1=PMS12+PMS1-PMS2
28303 PMM2=PMS12+PMS2-PMS1
28304 TFAC=-SHPR/(2D0*PMS12)
28305 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
28306 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
28307 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
28308 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
28309
28310C...Construct relative mirror weights and make choice.
28311 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
28312 WTPU=1D0
28313 WTNU=1D0
28314 ELSE
28315 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
28316 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
28317 ENDIF
28318 WTP=WTPU/(WTPU+WTNU)
28319 WTN=WTNU/(WTPU+WTNU)
28320 EPS=1D0
28321 IF(WTN.GT.PYR(0)) EPS=-1D0
28322
28323C...Store result of variable choice and associated weights.
28324 VINT(202)=PTS1
28325 VINT(207)=PTS2
28326 VINT(203)=PHI1
28327 VINT(208)=PHI2
28328 VINT(205)=WTPTS1
28329 VINT(210)=WTPTS2
28330 VINT(211)=Y3
28331 VINT(212)=Y3MAX
28332 VINT(213)=EPS
28333 IF(EPS.GT.0D0) THEN
28334 VINT(214)=1D0/WTP
28335 VINT(215)=T1P
28336 VINT(216)=T2P
28337 ELSE
28338 VINT(214)=1D0/WTN
28339 VINT(215)=T1N
28340 VINT(216)=T2N
28341 ENDIF
28342 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
28343 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
28344 VINT(219)=0.5D0*(PMS12-PTS3)
28345 VINT(220)=SQL12
28346 ENDIF
28347
28348 RETURN
28349 END
28350
28351C***********************************************************************
28352
28353C...PYSIGH
28354C...Differential matrix elements for all included subprocesses
28355C...Note that what is coded is (disregarding the COMFAC factor)
28356C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
28357C...when d(sigma-hat) is given in the zero-width limit, the delta
28358C...function in tau is replaced by a (modified) Breit-Wigner:
28359C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
28360C...where H_res = s-hat/m_res*Gamma_res(s-hat);
28361C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
28362C...i.e., dimensionless quantities
28363C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
28364C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
28365C...(2pi)^4 delta^4(P - sum p_i)
28366C...COMFAC contains the factor pi/s (or equivalent) and
28367C...the conversion factor from GeV^-2 to mb
28368
28369 SUBROUTINE PYSIGH(NCHN,SIGS)
28370
28371C...Double precision and integer declarations
28372 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28373 IMPLICIT INTEGER(I-N)
28374 INTEGER PYK,PYCHGE,PYCOMP
28375C...Parameter statement to help give large particle numbers.
28376 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28377 &KEXCIT=4000000,KDIMEN=5000000)
28378C...Commonblocks
28379 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28380 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28381 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28382 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28383 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28384 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28385 COMMON/PYINT1/MINT(400),VINT(400)
28386 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28387 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28388 COMMON/PYINT4/MWID(500),WIDS(500,5)
28389 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28390 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28391 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28392 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28393 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
28394 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
28395 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28396 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28397 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28398 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28399 COMMON/PYTCCO/COEFX(194:380,2)
28400 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28401 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
28402 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/,/PYTCCO/
28403C...Local arrays and complex variables
28404 DIMENSION XPQ(-25:25)
28405
28406C...Map of processes onto which routine to call
28407C...in order to evaluate cross section:
28408C...0 = not implemented;
28409C...1 = standard QCD (including photons);
28410C...2 = heavy flavours;
28411C...3 = W/Z;
28412C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
28413C...5 = SUSY;
28414C...6 = Technicolor;
28415C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28416 DIMENSION MAPPR(500)
28417 DATA (MAPPR(I),I=1,180)/
28418 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
28419 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
28420 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
28421 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
28422 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28423 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
28424 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
28425 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
28426 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28427 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
28428 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
28429 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
28430 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
28431 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
28432 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
28433 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
28434 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
28435 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
28436 DATA (MAPPR(I),I=181,500)/
28437 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
28438 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
28439 & 100*5,
28440 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28441 1 30*0,
28442 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
28443 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
28444 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
28445 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
28446 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
28447 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
28448 & 4, 4, 18*0,
28449 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28450 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28451 4 20*0,
28452 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28453 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28454 8 20*0/
28455
28456C...Reset number of channels and cross-section
28457 NCHN=0
28458 SIGS=0D0
28459
28460C...Read process to consider.
28461 ISUB=MINT(1)
28462 ISUBSV=ISUB
28463 MAP=MAPPR(ISUB)
28464
28465C...Read kinematical variables and limits
28466 ISTSB=ISET(ISUBSV)
28467 TAUMIN=VINT(11)
28468 YSTMIN=VINT(12)
28469 CTNMIN=VINT(13)
28470 CTPMIN=VINT(14)
28471 TAUPMN=VINT(16)
28472 TAU=VINT(21)
28473 YST=VINT(22)
28474 CTH=VINT(23)
28475 XT2=VINT(25)
28476 TAUP=VINT(26)
28477 TAUMAX=VINT(31)
28478 YSTMAX=VINT(32)
28479 CTNMAX=VINT(33)
28480 CTPMAX=VINT(34)
28481 TAUPMX=VINT(36)
28482
28483C...Derive kinematical quantities
28484 TAUE=TAU
28485 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28486 X(1)=SQRT(TAUE)*EXP(YST)
28487 X(2)=SQRT(TAUE)*EXP(-YST)
28488 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
28489 IF(X(1).GT.1D0-1D-7) RETURN
28490 ELSEIF(MINT(45).EQ.3) THEN
28491 X(1)=MIN(1D0-1.1D-10,X(1))
28492 ENDIF
28493 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
28494 IF(X(2).GT.1D0-1D-7) RETURN
28495 ELSEIF(MINT(46).EQ.3) THEN
28496 X(2)=MIN(1D0-1.1D-10,X(2))
28497 ENDIF
28498 SH=MAX(1D0,TAU*VINT(2))
28499 SQM3=VINT(63)
28500 SQM4=VINT(64)
28501 RM3=SQM3/SH
28502 RM4=SQM4/SH
28503 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28504 RPTS=4D0*VINT(71)**2/SH
28505 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28506 RM34=MAX(1D-20,2D0*RM3*RM4)
28507 RSQM=1D0+RM34
28508 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
28509 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
28510 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28511 IF(ISTSB.EQ.0) THEN
28512 TH=VINT(45)
28513 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28514 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
28515 ELSE
28516C...Kinematics with incoming masses tricky: now depends on how
28517C...subprocess has been set up w.r.t. order of incoming partons.
28518 RM1=0D0
28519 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
28520 RM2=0D0
28521 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
28522 IF(ISUB.EQ.35) THEN
28523 RM2=MIN(RM1,RM2)
28524 RM1=0D0
28525 ENDIF
28526 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28527 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
28528 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
28529 & BE12*BE34*CTH)
28530 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
28531 & BE12*BE34*CTH)
28532 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
28533 ENDIF
28534 SHR=SQRT(SH)
28535 SH2=SH**2
28536 TH2=TH**2
28537 UH2=UH**2
28538
28539C...Choice of Q2 scale for hard process (e.g. alpha_s).
28540 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
28541 Q2=SH
28542 ELSEIF(ISTSB.EQ.8) THEN
28543 IF(MINT(107).EQ.4) Q2=VINT(307)
28544 IF(MINT(108).EQ.4) Q2=VINT(308)
28545 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
28546 Q2IN1=0D0
28547 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
28548 Q2IN2=0D0
28549 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
28550 IF(MSTP(32).EQ.1) THEN
28551 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
28552 ELSEIF(MSTP(32).EQ.2) THEN
28553 Q2=SQPTH+0.5D0*(SQM3+SQM4)
28554 ELSEIF(MSTP(32).EQ.3) THEN
28555 Q2=MIN(-TH,-UH)
28556 ELSEIF(MSTP(32).EQ.4) THEN
28557 Q2=SH
28558 ELSEIF(MSTP(32).EQ.5) THEN
28559 Q2=-TH
28560 ELSEIF(MSTP(32).EQ.6) THEN
28561 XSF1=X(1)
28562 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
28563 XSF2=X(2)
28564 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
28565 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
28566 & (SQPTH+0.5D0*(SQM3+SQM4))
28567 ELSEIF(MSTP(32).EQ.7) THEN
28568 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
28569 ELSEIF(MSTP(32).EQ.8) THEN
28570 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
28571 ELSEIF(MSTP(32).EQ.9) THEN
28572 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
28573 ELSEIF(MSTP(32).EQ.10) THEN
28574 Q2=VINT(2)
28575C..Begin JA 040914
28576 ELSEIF(MSTP(32).EQ.11) THEN
28577 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
28578 ELSEIF(MSTP(32).EQ.12) THEN
28579 Q2=PARP(193)
28580C..End JA
28581 ELSEIF(MSTP(32).EQ.13) THEN
28582 Q2=SQPTH
28583 ENDIF
28584 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
28585 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
28586 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
28587 ENDIF
28588
28589C...Choice of Q2 scale for parton densities.
28590 Q2SF=Q2
28591C..Begin JA 040914
28592 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
28593 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
28594 & Q2=PARP(194)
28595C..End JA
28596 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28597 Q2SF=PMAS(23,1)**2
28598 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
28599 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
28600 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
28601 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
28602 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
28603 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
28604 IF(MSTP(39).EQ.2) Q2SF=
28605 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
28606 IF(MSTP(39).EQ.3) Q2SF=SH
28607 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
28608 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
28609C..Begin JA 040914
28610 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
28611 IF(MSTP(39).EQ.7) Q2SF=
28612 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
28613 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
28614C..End JA
28615 ENDIF
28616 ENDIF
28617 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
28618
28619 Q2PS=Q2SF
28620 Q2SF=Q2SF*PARP(34)
28621 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
28622 IF(MSTP(69).GE.2) Q2SF=VINT(2)
28623
28624C...Identify to which class(es) subprocess belongs
28625 ISMECR=0
28626 ISQCD=0
28627 ISJETS=0
28628 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
28629 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
28630 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
28631 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
28632 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
28633 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
28634 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
28635 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
28636 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
28637 IF (ISTSB.EQ.9) ISQCD=1
28638 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
28639 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
28640 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
28641 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
28642 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
28643 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
28644 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
28645 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
28646C...WBF is special case of ISJETS
28647 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
28648 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
28649 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
28650 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
28651 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
28652 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
28653 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
28654 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
28655 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
28656C...Some processes with photons also belong here.
28657 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
28658 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
28659 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
28660 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
28661 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
28662 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
28663
28664C...Choice of Q2 scale for parton-shower activity.
28665 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
28666 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
28667 XBJ=X(2)
28668 IF(MINT(43).EQ.3) XBJ=X(1)
28669 IF(MSTP(22).EQ.1) THEN
28670 Q2PS=-TH
28671 ELSEIF(MSTP(22).EQ.2) THEN
28672 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
28673 ELSEIF(MSTP(22).EQ.3) THEN
28674 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
28675 ELSE
28676 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
28677 ENDIF
28678 ENDIF
28679C...For multiple interactions, start from scale defined above
28680C...For all other QCD or "+jets"-type events, start shower from pThard.
28681 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
28682 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
28683C...Max shower scale = s for ME corrected processes.
28684C...(pT-ordering: max pT2 is s/4)
28685 Q2PS=VINT(2)
28686 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28687 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
28688C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
28689C...(pT-ordering: max pT2 is s/4)
28690 Q2PS=VINT(2)
28691 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28692 ENDIF
28693 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
28694
28695C...Elastic and diffractive events not associated with scales so set 0.
28696 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
28697 Q2SF=0D0
28698 Q2PS=0D0
28699 ENDIF
28700
28701C...Store derived kinematical quantities
28702 VINT(41)=X(1)
28703 VINT(42)=X(2)
28704 VINT(44)=SH
28705 VINT(43)=SQRT(SH)
28706 VINT(45)=TH
28707 VINT(46)=UH
28708 IF(ISTSB.NE.8) VINT(48)=SQPTH
28709 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
28710 VINT(50)=TAUP*VINT(2)
28711 VINT(49)=SQRT(MAX(0D0,VINT(50)))
28712 VINT(52)=Q2
28713 VINT(51)=SQRT(Q2)
28714 VINT(54)=Q2SF
28715 VINT(53)=SQRT(Q2SF)
28716 VINT(56)=Q2PS
28717 VINT(55)=SQRT(Q2PS)
28718
28719C...Set starting scale for multiple interactions
28720 IF (ISUBSV.EQ.95) THEN
28721 XT2GMX=0D0
28722 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
28723 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
28724 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
28725 & ISUBSV.NE.96)) THEN
28726C...All accessible phase space allowed.
28727 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
28728 ELSE
28729C...Scale of hard process sets limit.
28730C...2 -> 1. Limit is tau = x1*x2.
28731C...2 -> 2. Limit is XT2 for hard process + FS masses.
28732C...2 -> n > 2. Limit is tau' = tau of outer process.
28733 XT2GMX=VINT(25)
28734 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
28735 IF(ISTSB.EQ.2)
28736 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
28737 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
28738 ENDIF
28739 VINT(62)=0.25D0*XT2GMX*VINT(2)
28740 VINT(61)=SQRT(MAX(0D0,VINT(62)))
28741
28742C...Calculate parton distributions
28743 IF(ISTSB.LE.0) GOTO 160
28744 IF(MINT(47).GE.2) THEN
28745 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
28746 XSF=X(I)
28747 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
28748 IF(ISUB.EQ.99) THEN
28749 IF(MINT(140+I).EQ.0) THEN
28750 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
28751 ELSE
28752 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
28753 ENDIF
28754 VINT(40+I)=XSF
28755 Q2SF=VINT(309-I)
28756 ENDIF
28757 MINT(105)=MINT(102+I)
28758 MINT(109)=MINT(106+I)
28759 VINT(120)=VINT(2+I)
28760C.... ALICE
28761C.... Store side in MINT(124)
28762 MINT(124)=I
28763C....
28764 IF(MSTP(57).LE.1) THEN
28765 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
28766 ELSE
28767 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
28768 ENDIF
28769C...Safety margin against heavy flavour very close to threshold,
28770C...e.g. caused by mismatch in c and b masses.
28771 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
28772 XPQ(4)=0D0
28773 XPQ(-4)=0D0
28774 ENDIF
28775 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
28776 XPQ(5)=0D0
28777 XPQ(-5)=0D0
28778 ENDIF
28779 DO 100 KFL=-25,25
28780 XSFX(I,KFL)=XPQ(KFL)
28781 100 CONTINUE
28782 110 CONTINUE
28783 ENDIF
28784
28785C...Calculate alpha_em, alpha_strong and K-factor
28786 XW=PARU(102)
28787 XWV=XW
28788 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
28789 &1D0-(PMAS(24,1)/PMAS(23,1))**2
28790 XW1=1D0-XW
28791 XWC=1D0/(16D0*XW*XW1)
28792 AEM=PYALEM(Q2)
28793 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
28794 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
28795 FACK=1D0
28796 FACA=1D0
28797 IF(MSTP(33).EQ.1) THEN
28798 FACK=PARP(31)
28799 ELSEIF(MSTP(33).EQ.2) THEN
28800 FACK=PARP(31)
28801 FACA=PARP(32)/PARP(31)
28802 ELSEIF(MSTP(33).EQ.3) THEN
28803 Q2AS=PARP(33)*Q2
28804 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
28805 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
28806 AS=PYALPS(Q2AS)
28807 ENDIF
28808 VINT(138)=1D0
28809 VINT(57)=AEM
28810 VINT(58)=AS
28811
28812C...Set flags for allowed reacting partons/leptons
28813 DO 140 I=1,2
28814 DO 120 J=-25,25
28815 KFAC(I,J)=0
28816 120 CONTINUE
28817 IF(MINT(44+I).EQ.1) THEN
28818 KFAC(I,MINT(10+I))=1
28819 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
28820 KFAC(I,MINT(10+I))=1
28821 KFAC(I,22)=1
28822 KFAC(I,24)=1
28823 KFAC(I,-24)=1
28824 ELSE
28825 DO 130 J=-25,25
28826 KFAC(I,J)=KFIN(I,J)
28827 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
28828 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
28829 130 CONTINUE
28830 ENDIF
28831 140 CONTINUE
28832
28833C...Lower and upper limit for fermion flavour loops
28834 MMIN1=0
28835 MMAX1=0
28836 MMIN2=0
28837 MMAX2=0
28838 DO 150 J=-20,20
28839 IF(KFAC(1,-J).EQ.1) MMIN1=-J
28840 IF(KFAC(1,J).EQ.1) MMAX1=J
28841 IF(KFAC(2,-J).EQ.1) MMIN2=-J
28842 IF(KFAC(2,J).EQ.1) MMAX2=J
28843 150 CONTINUE
28844 MMINA=MIN(MMIN1,MMIN2)
28845 MMAXA=MAX(MMAX1,MMAX2)
28846
28847C...Common resonance mass and width combinations
28848 SQMZ=PMAS(23,1)**2
28849 SQMW=PMAS(24,1)**2
28850 GMMZ=PMAS(23,1)*PMAS(23,2)
28851 GMMW=PMAS(24,1)*PMAS(24,2)
28852
28853C...Polarization factors...implemented so far for W+W-(25)
28854 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
28855 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
28856 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
28857 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
28858
28859C...Phase space integral in tau
28860 COMFAC=PARU(1)*PARU(5)/VINT(2)
28861 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
28862 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
28863 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
28864 ATAU1=LOG(TAUMAX/TAUMIN)
28865 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
28866 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
28867 IF(MINT(72).GE.1) THEN
28868 TAUR1=VINT(73)
28869 GAMR1=VINT(74)
28870 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
28871 ATAU3=ATAUD/TAUR1
28872 IF(ATAUD.GT.1D-10) H1=H1+
28873 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
28874 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
28875 ATAU4=ATAUD/GAMR1
28876 IF(ATAUD.GT.1D-10) H1=H1+
28877 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
28878 ENDIF
28879 IF(MINT(72).GE.2) THEN
28880 TAUR2=VINT(75)
28881 GAMR2=VINT(76)
28882 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
28883 ATAU5=ATAUD/TAUR2
28884 IF(ATAUD.GT.1D-10) H1=H1+
28885 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
28886 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
28887 ATAU6=ATAUD/GAMR2
28888 IF(ATAUD.GT.1D-10) H1=H1+
28889 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
28890 ENDIF
28891 IF(MINT(72).EQ.3) THEN
28892 TAUR3=VINT(77)
28893 GAMR3=VINT(78)
28894 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
28895 ATAU50=ATAUD/TAUR3
28896 IF(ATAUD.GT.1D-10) H1=H1+
28897 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
28898 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
28899 ATAU60=ATAUD/GAMR3
28900 IF(ATAUD.GT.1D-10) H1=H1+
28901 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
28902 ENDIF
28903 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28904 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
28905 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28906 & MAX(2D-10,1D0-TAU)
28907 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28908 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
28909 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28910 & MAX(1D-10,1D0-TAU)
28911 ENDIF
28912 COMFAC=COMFAC*ATAU1/(TAU*H1)
28913 ENDIF
28914
28915C...Phase space integral in y*
28916 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
28917 &THEN
28918 AYST0=YSTMAX-YSTMIN
28919 IF(AYST0.LT.1D-10) THEN
28920 COMFAC=0D0
28921 ELSE
28922 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28923 AYST2=AYST1
28924 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28925 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28926 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28927 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28928 IF(MINT(45).EQ.3) THEN
28929 YST0=-0.5D0*LOG(TAUE)
28930 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28931 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28932 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28933 & MAX(1D-10,1D0-EXP(YST-YST0))
28934 ENDIF
28935 IF(MINT(46).EQ.3) THEN
28936 YST0=-0.5D0*LOG(TAUE)
28937 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28938 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28939 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28940 & MAX(1D-10,1D0-EXP(-YST-YST0))
28941 ENDIF
28942 COMFAC=COMFAC*AYST0/H2
28943 ENDIF
28944 ENDIF
28945
28946C...2 -> 1 processes: reduction in angular part of phase space integral
28947C...for case of decaying resonance
28948 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28949 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28950 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28951 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28952 & KFPR(ISUB,1).EQ.39) THEN
28953 COMFAC=COMFAC*0.5D0*ACTH0
28954 ELSE
28955 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28956 & CTPMAX**3-CTPMIN**3)
28957 ENDIF
28958 ENDIF
28959
28960C...2 -> 2 processes: angular part of phase space integral
28961 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28962 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28963 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28964 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28965 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28966 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28967 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28968 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28969 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28970 H3=COEF(ISUBSV,13)+
28971 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28972 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28973 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28974 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28975 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28976
28977C...2 -> 2 processes: take into account final state Breit-Wigners
28978 COMFAC=COMFAC*VINT(80)
28979 ENDIF
28980
28981C...2 -> 3, 4 processes: phace space integral in tau'
28982 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28983 ATAUP1=LOG(TAUPMX/TAUPMN)
28984 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28985 H4=COEF(ISUBSV,18)+
28986 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28987 IF(MINT(47).EQ.5) THEN
28988 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28989 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28990 ELSEIF(MINT(47).GE.6) THEN
28991 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28992 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28993 ENDIF
28994 COMFAC=COMFAC*ATAUP1/H4
28995 ENDIF
28996
28997C...2 -> 3, 4 processes: effective W/Z parton distributions
28998 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28999 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29000 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29001 ELSE
29002 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29003 ENDIF
29004 COMFAC=COMFAC*FZW
29005 ENDIF
29006
29007C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29008 IF(ISTSB.EQ.5) THEN
29009 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29010 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29011 ENDIF
29012
29013C...Phase space integral for low-pT and multiple interactions
29014 IF(ISTSB.EQ.9) THEN
29015 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29016 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29017 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29018 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29019 COMFAC=COMFAC*ATAU1/H1
29020 AYST0=YSTMAX-YSTMIN
29021 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29022 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29023 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29024 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29025 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29026 COMFAC=COMFAC*AYST0/H2
29027 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29028C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29029C...introduced to make cross-section finite for xT2 -> 0
29030 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29031 & (1D0+VINT(149)))
29032 ENDIF
29033
29034C...Real gamma + gamma: include factor 2 when different nature
29035 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29036 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29037
29038C...Extra factors to include the effects of
29039C...longitudinal resolved photons (but not direct or DIS ones).
29040 DO 170 ISDE=1,2
29041 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29042 & MINT(106+ISDE).LE.3) THEN
29043 VINT(314+ISDE)=1D0
29044 XY=PARP(166+ISDE)
29045 IF(MSTP(16).EQ.0) THEN
29046 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29047 & XY=VINT(304+ISDE)
29048 ELSE
29049 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29050 & XY=VINT(308+ISDE)
29051 ENDIF
29052 Q2GA=VINT(306+ISDE)
29053 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29054 & Q2GA.GT.0D0) THEN
29055 REDUCE=0D0
29056 IF(MSTP(17).EQ.1) THEN
29057 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29058 ELSEIF(MSTP(17).EQ.2) THEN
29059 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29060 ELSEIF(MSTP(17).EQ.3) THEN
29061 PMVIRT=PMAS(PYCOMP(113),1)
29062 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29063 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29064 PMVIRT=PMAS(PYCOMP(113),1)
29065 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29066 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29067 PMVIRT=PMAS(PYCOMP(113),1)
29068 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29069 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29070 PMVSMN=4D0*PARP(15)**2
29071 PMVSMX=4D0*VINT(154)**2
29072 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29073 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29074 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29075 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29076 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29077 PMVIRT=PMAS(PYCOMP(113),1)
29078 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29079 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29080 PMVIRT=PMAS(PYCOMP(113),1)
29081 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29082 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29083 PMVSMN=4D0*PARP(15)**2
29084 PMVSMX=4D0*VINT(154)**2
29085 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29086 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29087 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29088 ENDIF
29089 BEAMAS=PYMASS(11)
29090 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29091 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29092 & (1D0-2D0*BEAMAS**2/Q2GA))
29093 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29094 ENDIF
29095 ELSE
29096 VINT(314+ISDE)=1D0
29097 ENDIF
29098 COMFAC=COMFAC*VINT(314+ISDE)
29099 170 CONTINUE
29100
29101C...Evaluate cross sections - done in separate routines by kind
29102C...of physics, to keep PYSIGH of sensible size.
29103 IF(MAP.EQ.1) THEN
29104C...Standard QCD (including photons).
29105 CALL PYSGQC(NCHN,SIGS)
29106 ELSEIF(MAP.EQ.2) THEN
29107C...Heavy flavours.
29108 CALL PYSGHF(NCHN,SIGS)
29109 ELSEIF(MAP.EQ.3) THEN
29110C...W/Z.
29111 CALL PYSGWZ(NCHN,SIGS)
29112 ELSEIF(MAP.EQ.4) THEN
29113C...Higgs (2 doublets; including longitudinal W/Z scattering).
29114 CALL PYSGHG(NCHN,SIGS)
29115 ELSEIF(MAP.EQ.5) THEN
29116C...SUSY.
29117 CALL PYSGSU(NCHN,SIGS)
29118 ELSEIF(MAP.EQ.6) THEN
29119C...Technicolor.
29120 CALL PYSGTC(NCHN,SIGS)
29121 ELSEIF(MAP.EQ.7) THEN
29122C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29123 CALL PYSGEX(NCHN,SIGS)
29124 ENDIF
29125
29126C...Multiply with parton distributions
29127 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29128 DO 180 ICHN=1,NCHN
29129 IF(MINT(45).GE.2) THEN
29130 KFL1=ISIG(ICHN,1)
29131 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29132 ENDIF
29133 IF(MINT(46).GE.2) THEN
29134 KFL2=ISIG(ICHN,2)
29135 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29136 ENDIF
29137 SIGS=SIGS+SIGH(ICHN)
29138 180 CONTINUE
29139 ENDIF
29140
29141 RETURN
29142 END
29143
29144C*********************************************************************
29145
29146C...PYSGQC
29147C...Subprocess cross sections for QCD processes,
29148C...including photons.
29149C...Auxiliary to PYSIGH.
29150
29151 SUBROUTINE PYSGQC(NCHN,SIGS)
29152
29153C...Double precision and integer declarations
29154 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29155 IMPLICIT INTEGER(I-N)
29156 INTEGER PYK,PYCHGE,PYCOMP
29157C...Parameter statement to help give large particle numbers.
29158 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29159 &KEXCIT=4000000,KDIMEN=5000000)
29160C...Commonblocks
29161 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29162 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29163 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29164 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29165 COMMON/PYINT1/MINT(400),VINT(400)
29166 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29167 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29168 COMMON/PYINT4/MWID(500),WIDS(500,5)
29169 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29170 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29171 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29172 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29173 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29174 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
29175 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
29176C...Local arrays
29177 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29178
29179C...Differential cross section expressions.
29180
29181 IF(ISUB.LE.20) THEN
29182 IF(ISUB.EQ.10) THEN
29183C...f + f' -> f + f' (gamma/Z/W exchange)
29184 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
29185 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
29186 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
29187 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
29188 DO 110 I=MMIN1,MMAX1
29189 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
29190 IA=IABS(I)
29191 DO 100 J=MMIN2,MMAX2
29192 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
29193 JA=IABS(J)
29194C...Electroweak couplings
29195 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
29196 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
29197 VI=AI-4D0*EI*XWV
29198 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
29199 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
29200 VJ=AJ-4D0*EJ*XWV
29201 EPSIJ=ISIGN(1,I*J)
29202C...gamma/Z exchange, only gamma exchange, or only Z exchange
29203 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
29204 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
29205 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
29206 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
29207 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
29208 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29209 ELSEIF(MSTP(21).EQ.2) THEN
29210 FACNCF=FACGGF*EI**2*EJ**2
29211 ELSE
29212 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
29213 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29214 ENDIF
29215C...Extrafactor 2 for only one incoming neutrino spin state.
29216 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
29217 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
29218 NCHN=NCHN+1
29219 ISIG(NCHN,1)=I
29220 ISIG(NCHN,2)=J
29221 ISIG(NCHN,3)=1
29222 SIGH(NCHN)=FACNCF
29223 ENDIF
29224C...W exchange
29225 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
29226 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
29227 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
29228 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
29229 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
29230 NCHN=NCHN+1
29231 ISIG(NCHN,1)=I
29232 ISIG(NCHN,2)=J
29233 ISIG(NCHN,3)=2
29234 SIGH(NCHN)=FACCCF
29235 ENDIF
29236 100 CONTINUE
29237 110 CONTINUE
29238
29239 ELSEIF(ISUB.EQ.11) THEN
29240C...f + f' -> f + f' (g exchange)
29241 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29242 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29243 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29244 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
29245 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
29246 DO 130 I=MMIN1,MMAX1
29247 IA=IABS(I)
29248 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
29249 DO 120 J=MMIN2,MMAX2
29250 JA=IABS(J)
29251 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
29252 NCHN=NCHN+1
29253 ISIG(NCHN,1)=I
29254 ISIG(NCHN,2)=J
29255 ISIG(NCHN,3)=1
29256 SIGH(NCHN)=FACQQ1
29257 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29258 IF(I.EQ.J) THEN
29259 SIGH(NCHN)=0.5D0*SIGH(NCHN)
29260 NCHN=NCHN+1
29261 ISIG(NCHN,1)=I
29262 ISIG(NCHN,2)=J
29263 ISIG(NCHN,3)=2
29264 SIGH(NCHN)=0.5D0*FACQQ2
29265 ENDIF
29266 120 CONTINUE
29267 130 CONTINUE
29268
29269 ELSEIF(ISUB.EQ.12) THEN
29270C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
29271 CALL PYWIDT(21,SH,WDTP,WDTE)
29272 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29273 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
29274 DO 140 I=MMINA,MMAXA
29275 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29276 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
29277 NCHN=NCHN+1
29278 ISIG(NCHN,1)=I
29279 ISIG(NCHN,2)=-I
29280 ISIG(NCHN,3)=1
29281 SIGH(NCHN)=FACQQB
29282 140 CONTINUE
29283
29284 ELSEIF(ISUB.EQ.13) THEN
29285C...f + fbar -> g + g (q + qbar -> g + g only)
29286 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29287 & UH2/SH2)
29288 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29289 & TH2/SH2)
29290 DO 150 I=MMINA,MMAXA
29291 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29292 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
29293 NCHN=NCHN+1
29294 ISIG(NCHN,1)=I
29295 ISIG(NCHN,2)=-I
29296 ISIG(NCHN,3)=1
29297 SIGH(NCHN)=0.5D0*FACGG1
29298 NCHN=NCHN+1
29299 ISIG(NCHN,1)=I
29300 ISIG(NCHN,2)=-I
29301 ISIG(NCHN,3)=2
29302 SIGH(NCHN)=0.5D0*FACGG2
29303 150 CONTINUE
29304
29305 ELSEIF(ISUB.EQ.14) THEN
29306C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
29307 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
29308 DO 160 I=MMINA,MMAXA
29309 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29310 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
29311 EI=KCHG(IABS(I),1)/3D0
29312 NCHN=NCHN+1
29313 ISIG(NCHN,1)=I
29314 ISIG(NCHN,2)=-I
29315 ISIG(NCHN,3)=1
29316 SIGH(NCHN)=FACGG*EI**2
29317 160 CONTINUE
29318
29319 ELSEIF(ISUB.EQ.18) THEN
29320C...f + fbar -> gamma + gamma
29321 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
29322 DO 170 I=MMINA,MMAXA
29323 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
29324 EI=KCHG(IABS(I),1)/3D0
29325 FCOI=1D0
29326 IF(IABS(I).LE.10) FCOI=FACA/3D0
29327 NCHN=NCHN+1
29328 ISIG(NCHN,1)=I
29329 ISIG(NCHN,2)=-I
29330 ISIG(NCHN,3)=1
29331 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
29332 170 CONTINUE
29333 ENDIF
29334
29335 ELSEIF(ISUB.LE.40) THEN
29336 IF(ISUB.EQ.28) THEN
29337C...f + g -> f + g (q + g -> q + g only)
29338 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29339 & UH/SH)*FACA
29340 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29341 & SH/UH)
29342 DO 190 I=MMINA,MMAXA
29343 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
29344 DO 180 ISDE=1,2
29345 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
29346 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
29347 NCHN=NCHN+1
29348 ISIG(NCHN,ISDE)=I
29349 ISIG(NCHN,3-ISDE)=21
29350 ISIG(NCHN,3)=1
29351 SIGH(NCHN)=FACQG1
29352 NCHN=NCHN+1
29353 ISIG(NCHN,ISDE)=I
29354 ISIG(NCHN,3-ISDE)=21
29355 ISIG(NCHN,3)=2
29356 SIGH(NCHN)=FACQG2
29357 180 CONTINUE
29358 190 CONTINUE
29359
29360 ELSEIF(ISUB.EQ.29) THEN
29361C...f + g -> f + gamma (q + g -> q + gamma only)
29362 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
29363 DO 210 I=MMINA,MMAXA
29364 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
29365 EI=KCHG(IABS(I),1)/3D0
29366 FACGQ=FGQ*EI**2
29367 DO 200 ISDE=1,2
29368 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
29369 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
29370 NCHN=NCHN+1
29371 ISIG(NCHN,ISDE)=I
29372 ISIG(NCHN,3-ISDE)=21
29373 ISIG(NCHN,3)=1
29374 SIGH(NCHN)=FACGQ
29375 200 CONTINUE
29376 210 CONTINUE
29377
29378 ELSEIF(ISUB.EQ.33) THEN
29379C...f + gamma -> f + g (q + gamma -> q + g only)
29380 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
29381 DO 230 I=MMINA,MMAXA
29382 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
29383 EI=KCHG(IABS(I),1)/3D0
29384 FACGQ=FGQ*EI**2
29385 DO 220 ISDE=1,2
29386 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
29387 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
29388 NCHN=NCHN+1
29389 ISIG(NCHN,ISDE)=I
29390 ISIG(NCHN,3-ISDE)=22
29391 ISIG(NCHN,3)=1
29392 SIGH(NCHN)=FACGQ
29393 220 CONTINUE
29394 230 CONTINUE
29395
29396 ELSEIF(ISUB.EQ.34) THEN
29397C...f + gamma -> f + gamma
29398 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
29399 DO 250 I=MMINA,MMAXA
29400 IF(I.EQ.0) GOTO 250
29401 EI=KCHG(IABS(I),1)/3D0
29402 FACGQ=FGQ*EI**4
29403 DO 240 ISDE=1,2
29404 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
29405 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
29406 NCHN=NCHN+1
29407 ISIG(NCHN,ISDE)=I
29408 ISIG(NCHN,3-ISDE)=22
29409 ISIG(NCHN,3)=1
29410 SIGH(NCHN)=FACGQ
29411 240 CONTINUE
29412 250 CONTINUE
29413 ENDIF
29414
29415 ELSEIF(ISUB.LE.80) THEN
29416 IF(ISUB.EQ.53) THEN
29417C...g + g -> f + fbar (g + g -> q + qbar only)
29418 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
29419 IDC0=MDCY(21,2)-1
29420C...Begin by d, u, s flavours.
29421 FLAVWT=0D0
29422 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29423 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29424 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29425 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29426 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29427 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29428 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29429 & UH2/SH2)*FLAVWT*FACA
29430 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29431 & TH2/SH2)*FLAVWT*FACA
29432 NCHN=NCHN+1
29433 ISIG(NCHN,1)=21
29434 ISIG(NCHN,2)=21
29435 ISIG(NCHN,3)=1
29436 SIGH(NCHN)=FACQQ1
29437 NCHN=NCHN+1
29438 ISIG(NCHN,1)=21
29439 ISIG(NCHN,2)=21
29440 ISIG(NCHN,3)=2
29441 SIGH(NCHN)=FACQQ2
29442C...Next c and b flavours: modified that and uhat for fixed
29443C...cos(theta-hat).
29444 DO 260 IFL=4,5
29445 SQMAVG=PMAS(IFL,1)**2
29446 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29447 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29448 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29449 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29450 THUHQ=THQ*UHQ-SQMAVG*SH
29451 IF(MSTP(34).EQ.0) THEN
29452 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29453 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29454 ELSE
29455 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29456 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29457 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29458 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29459 ENDIF
29460 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29461 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29462 NCHN=NCHN+1
29463 ISIG(NCHN,1)=21
29464 ISIG(NCHN,2)=21
29465 ISIG(NCHN,3)=1+2*(IFL-3)
29466 SIGH(NCHN)=FACQQ1
29467 NCHN=NCHN+1
29468 ISIG(NCHN,1)=21
29469 ISIG(NCHN,2)=21
29470 ISIG(NCHN,3)=2+2*(IFL-3)
29471 SIGH(NCHN)=FACQQ2
29472 ENDIF
29473 260 CONTINUE
29474 270 CONTINUE
29475
29476 ELSEIF(ISUB.EQ.54) THEN
29477C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
29478 CALL PYWIDT(21,SH,WDTP,WDTE)
29479 WDTESU=0D0
29480 DO 280 I=1,MIN(8,MDCY(21,3))
29481 EF=KCHG(I,1)/3D0
29482 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29483 & WDTE(I,4))
29484 280 CONTINUE
29485 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
29486 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29487 NCHN=NCHN+1
29488 ISIG(NCHN,1)=21
29489 ISIG(NCHN,2)=22
29490 ISIG(NCHN,3)=1
29491 SIGH(NCHN)=FACQQ
29492 ENDIF
29493 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29494 NCHN=NCHN+1
29495 ISIG(NCHN,1)=22
29496 ISIG(NCHN,2)=21
29497 ISIG(NCHN,3)=1
29498 SIGH(NCHN)=FACQQ
29499 ENDIF
29500
29501 ELSEIF(ISUB.EQ.58) THEN
29502C...gamma + gamma -> f + fbar
29503 CALL PYWIDT(22,SH,WDTP,WDTE)
29504 WDTESU=0D0
29505 DO 290 I=1,MIN(12,MDCY(22,3))
29506 IF(I.LE.8) EF= KCHG(I,1)/3D0
29507 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29508 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29509 & WDTE(I,4))
29510 290 CONTINUE
29511 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
29512 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29513 NCHN=NCHN+1
29514 ISIG(NCHN,1)=22
29515 ISIG(NCHN,2)=22
29516 ISIG(NCHN,3)=1
29517 SIGH(NCHN)=FACFF
29518 ENDIF
29519
29520 ELSEIF(ISUB.EQ.68) THEN
29521C...g + g -> g + g
29522 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
29523 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
29524 & TH2/SH2)*FACA
29525 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
29526 & SH2/UH2)*FACA
29527 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
29528 & UH2/TH2)
29529 NCHN=NCHN+1
29530 ISIG(NCHN,1)=21
29531 ISIG(NCHN,2)=21
29532 ISIG(NCHN,3)=1
29533 SIGH(NCHN)=0.5D0*FACGG1
29534 NCHN=NCHN+1
29535 ISIG(NCHN,1)=21
29536 ISIG(NCHN,2)=21
29537 ISIG(NCHN,3)=2
29538 SIGH(NCHN)=0.5D0*FACGG2
29539 NCHN=NCHN+1
29540 ISIG(NCHN,1)=21
29541 ISIG(NCHN,2)=21
29542 ISIG(NCHN,3)=3
29543 SIGH(NCHN)=0.5D0*FACGG3
29544 300 CONTINUE
29545
29546 ELSEIF(ISUB.EQ.80) THEN
29547C...q + gamma -> q' + pi+/-
29548 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
29549 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
29550 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
29551 DELSH=UH*SQRT(ASSH*Q2FPSH)
29552 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
29553 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
29554 DELUH=SH*SQRT(ASUH*Q2FPUH)
29555 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
29556 IF(I.EQ.0) GOTO 320
29557 EI=KCHG(IABS(I),1)/3D0
29558 EJ=SIGN(1D0-ABS(EI),EI)
29559 DO 310 ISDE=1,2
29560 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
29561 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
29562 NCHN=NCHN+1
29563 ISIG(NCHN,ISDE)=I
29564 ISIG(NCHN,3-ISDE)=22
29565 ISIG(NCHN,3)=1
29566 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
29567 310 CONTINUE
29568 320 CONTINUE
29569 ENDIF
29570
29571 ELSEIF(ISUB.LE.100) THEN
29572 IF(ISUB.EQ.91) THEN
29573C...Elastic scattering
29574 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
29575
29576 ELSEIF(ISUB.EQ.92) THEN
29577C...Single diffractive scattering (first side, i.e. XB)
29578 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
29579
29580 ELSEIF(ISUB.EQ.93) THEN
29581C...Single diffractive scattering (second side, i.e. AX)
29582 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
29583
29584 ELSEIF(ISUB.EQ.94) THEN
29585C...Double diffractive scattering
29586 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
29587
29588 ELSEIF(ISUB.EQ.95) THEN
29589C...Low-pT scattering
29590 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
29591
29592 ELSEIF(ISUB.EQ.96) THEN
29593C...Multiple interactions: sum of QCD processes
29594 CALL PYWIDT(21,SH,WDTP,WDTE)
29595
29596C...q + q' -> q + q'
29597 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29598 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29599 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29600 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
29601 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
29602 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
29603 DO 340 I=-5,5
29604 IF(I.EQ.0) GOTO 340
29605 DO 330 J=-5,5
29606 IF(J.EQ.0) GOTO 330
29607 NCHN=NCHN+1
29608 ISIG(NCHN,1)=I
29609 ISIG(NCHN,2)=J
29610 ISIG(NCHN,3)=111
29611 SIGH(NCHN)=FACQQ1
29612 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29613 IF(I.EQ.J) THEN
29614 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
29615 NCHN=NCHN+1
29616 ISIG(NCHN,1)=I
29617 ISIG(NCHN,2)=J
29618 ISIG(NCHN,3)=112
29619 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
29620 ENDIF
29621 330 CONTINUE
29622 340 CONTINUE
29623
29624C...q + qbar -> q' + qbar' or g + g
29625 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29626 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
29627 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29628 & UH2/SH2)
29629 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29630 & TH2/SH2)
29631 DO 350 I=-5,5
29632 IF(I.EQ.0) GOTO 350
29633 NCHN=NCHN+1
29634 ISIG(NCHN,1)=I
29635 ISIG(NCHN,2)=-I
29636 ISIG(NCHN,3)=121
29637 SIGH(NCHN)=FACQQB
29638 NCHN=NCHN+1
29639 ISIG(NCHN,1)=I
29640 ISIG(NCHN,2)=-I
29641 ISIG(NCHN,3)=131
29642 SIGH(NCHN)=0.5D0*FACGG1
29643 NCHN=NCHN+1
29644 ISIG(NCHN,1)=I
29645 ISIG(NCHN,2)=-I
29646 ISIG(NCHN,3)=132
29647 SIGH(NCHN)=0.5D0*FACGG2
29648 350 CONTINUE
29649
29650C...q + g -> q + g
29651 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29652 & UH/SH)*FACA
29653 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29654 & SH/UH)
29655 DO 370 I=-5,5
29656 IF(I.EQ.0) GOTO 370
29657 DO 360 ISDE=1,2
29658 NCHN=NCHN+1
29659 ISIG(NCHN,ISDE)=I
29660 ISIG(NCHN,3-ISDE)=21
29661 ISIG(NCHN,3)=281
29662 SIGH(NCHN)=FACQG1
29663 NCHN=NCHN+1
29664 ISIG(NCHN,ISDE)=I
29665 ISIG(NCHN,3-ISDE)=21
29666 ISIG(NCHN,3)=282
29667 SIGH(NCHN)=FACQG2
29668 360 CONTINUE
29669 370 CONTINUE
29670
29671C...g + g -> q + qbar (only d, u, s)
29672 IDC0=MDCY(21,2)-1
29673 FLAVWT=0D0
29674 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29675 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29676 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29677 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29678 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29679 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29680 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29681 & UH2/SH2)*FLAVWT*FACA
29682 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29683 & TH2/SH2)*FLAVWT*FACA
29684 NCHN=NCHN+1
29685 ISIG(NCHN,1)=21
29686 ISIG(NCHN,2)=21
29687 ISIG(NCHN,3)=531
29688 SIGH(NCHN)=FACQQ1
29689 NCHN=NCHN+1
29690 ISIG(NCHN,1)=21
29691 ISIG(NCHN,2)=21
29692 ISIG(NCHN,3)=532
29693 SIGH(NCHN)=FACQQ2
29694
29695C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
29696C...cos(theta-hat)
29697 DO 380 IFL=4,5
29698 SQMAVG=PMAS(IFL,1)**2
29699 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29700 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29701 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29702 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29703 THUHQ=THQ*UHQ-SQMAVG*SH
29704 IF(MSTP(34).EQ.0) THEN
29705 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29706 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29707 ELSE
29708 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29709 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29710 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29711 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29712 ENDIF
29713 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29714 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29715 NCHN=NCHN+1
29716 ISIG(NCHN,1)=21
29717 ISIG(NCHN,2)=21
29718 ISIG(NCHN,3)=531+2*(IFL-3)
29719 SIGH(NCHN)=FACQQ1
29720 NCHN=NCHN+1
29721 ISIG(NCHN,1)=21
29722 ISIG(NCHN,2)=21
29723 ISIG(NCHN,3)=532+2*(IFL-3)
29724 SIGH(NCHN)=FACQQ2
29725 ENDIF
29726 380 CONTINUE
29727
29728C...g + g -> g + g
29729 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
29730 & 2D0*TH/SH+TH2/SH2)*FACA
29731 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
29732 & 2D0*SH/UH+SH2/UH2)*FACA
29733 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
29734 & 2D0*UH/TH+UH2/TH2)
29735 NCHN=NCHN+1
29736 ISIG(NCHN,1)=21
29737 ISIG(NCHN,2)=21
29738 ISIG(NCHN,3)=681
29739 SIGH(NCHN)=0.5D0*FACGG1
29740 NCHN=NCHN+1
29741 ISIG(NCHN,1)=21
29742 ISIG(NCHN,2)=21
29743 ISIG(NCHN,3)=682
29744 SIGH(NCHN)=0.5D0*FACGG2
29745 NCHN=NCHN+1
29746 ISIG(NCHN,1)=21
29747 ISIG(NCHN,2)=21
29748 ISIG(NCHN,3)=683
29749 SIGH(NCHN)=0.5D0*FACGG3
29750
29751 ELSEIF(ISUB.EQ.99) THEN
29752C...f + gamma* -> f.
29753 IF(MINT(107).EQ.4) THEN
29754 Q2GA=VINT(307)
29755 P2GA=VINT(308)
29756 ISDE=2
29757 ELSE
29758 Q2GA=VINT(308)
29759 P2GA=VINT(307)
29760 ISDE=1
29761 ENDIF
29762 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
29763 PM2RHO=PMAS(PYCOMP(113),1)**2
29764 IF(MSTP(19).EQ.0) THEN
29765 COMFAC=COMFAC/Q2GA
29766 ELSEIF(MSTP(19).EQ.1) THEN
29767 COMFAC=COMFAC/(Q2GA+PM2RHO)
29768 ELSEIF(MSTP(19).EQ.2) THEN
29769 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29770 ELSE
29771 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29772 W2GA=VINT(2)
29773 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
29774 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
29775 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
29776 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
29777 ELSE
29778 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
29779 & Q2GA**0.57D0)
29780 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
29781 ENDIF
29782 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
29783 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
29784 ENDIF
29785 DO 390 I=MMINA,MMAXA
29786 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
29787 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
29788 EI=KCHG(IABS(I),1)/3D0
29789 NCHN=NCHN+1
29790 ISIG(NCHN,ISDE)=I
29791 ISIG(NCHN,3-ISDE)=22
29792 ISIG(NCHN,3)=1
29793 SIGH(NCHN)=COMFAC*EI**2
29794 390 CONTINUE
29795 ENDIF
29796
29797 ELSE
29798 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
29799C...g + g -> gamma + gamma or g + g -> g + gamma
29800 A0STUR=0D0
29801 A0STUI=0D0
29802 A0TSUR=0D0
29803 A0TSUI=0D0
29804 A0UTSR=0D0
29805 A0UTSI=0D0
29806 A1STUR=0D0
29807 A1STUI=0D0
29808 A2STUR=0D0
29809 A2STUI=0D0
29810 ALST=LOG(-SH/TH)
29811 ALSU=LOG(-SH/UH)
29812 ALTU=LOG(TH/UH)
29813 IMAX=2*MSTP(1)
29814 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
29815 DO 400 I=1,IMAX
29816 EI=KCHG(IABS(I),1)/3D0
29817 EIWT=EI**2
29818 IF(ISUB.EQ.115) EIWT=EI
29819 SQMQ=PMAS(I,1)**2
29820 EPSS=4D0*SQMQ/SH
29821 EPST=4D0*SQMQ/TH
29822 EPSU=4D0*SQMQ/UH
29823 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
29824 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
29825 & PARU(1)**2)
29826 B0STUI=0D0
29827 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
29828 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
29829 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
29830 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
29831 B1STUR=-1D0
29832 B1STUI=0D0
29833 B2STUR=-1D0
29834 B2STUI=0D0
29835 ELSE
29836 CALL PYWAUX(1,EPSS,W1SR,W1SI)
29837 CALL PYWAUX(1,EPST,W1TR,W1TI)
29838 CALL PYWAUX(1,EPSU,W1UR,W1UI)
29839 CALL PYWAUX(2,EPSS,W2SR,W2SI)
29840 CALL PYWAUX(2,EPST,W2TR,W2TI)
29841 CALL PYWAUX(2,EPSU,W2UR,W2UI)
29842 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
29843 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
29844 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
29845 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
29846 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
29847 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
29848 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
29849 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
29850 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
29851 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
29852 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29853 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29854 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
29855 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
29856 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
29857 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
29858 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29859 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29860 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
29861 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
29862 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
29863 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
29864 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29865 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
29866 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
29867 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
29868 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
29869 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
29870 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29871 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
29872 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
29873 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
29874 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
29875 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
29876 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29877 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
29878 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
29879 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
29880 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
29881 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
29882 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29883 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
29884 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
29885 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
29886 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
29887 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29888 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
29889 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
29890 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
29891 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29892 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
29893 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
29894 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
29895 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
29896 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
29897 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
29898 ENDIF
29899 A0STUR=A0STUR+EIWT*B0STUR
29900 A0STUI=A0STUI+EIWT*B0STUI
29901 A0TSUR=A0TSUR+EIWT*B0TSUR
29902 A0TSUI=A0TSUI+EIWT*B0TSUI
29903 A0UTSR=A0UTSR+EIWT*B0UTSR
29904 A0UTSI=A0UTSI+EIWT*B0UTSI
29905 A1STUR=A1STUR+EIWT*B1STUR
29906 A1STUI=A1STUI+EIWT*B1STUI
29907 A2STUR=A2STUR+EIWT*B2STUR
29908 A2STUI=A2STUI+EIWT*B2STUI
29909 400 CONTINUE
29910 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
29911 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
29912 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
29913 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
29914 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
29915 NCHN=NCHN+1
29916 ISIG(NCHN,1)=21
29917 ISIG(NCHN,2)=21
29918 ISIG(NCHN,3)=1
29919 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
29920 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29921 410 CONTINUE
29922
29923 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29924C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29925 PH=0D0
29926 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29927 & PH=VINT(3)**2
29928 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29929 & PH=VINT(4)**2
29930 IF(ISUB.EQ.131) THEN
29931 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29932 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29933 ELSE
29934 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29935 ENDIF
29936 DO 430 I=MMINA,MMAXA
29937 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29938 EI=KCHG(IABS(I),1)/3D0
29939 FACGQ=FGQ*EI**2
29940 DO 420 ISDE=1,2
29941 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29942 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29943 NCHN=NCHN+1
29944 ISIG(NCHN,ISDE)=I
29945 ISIG(NCHN,3-ISDE)=22
29946 ISIG(NCHN,3)=1
29947 SIGH(NCHN)=FACGQ
29948 420 CONTINUE
29949 430 CONTINUE
29950
29951 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29952C...f + gamma*_(T,L) -> f + gamma
29953 PH=0D0
29954 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29955 & PH=VINT(3)**2
29956 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29957 & PH=VINT(4)**2
29958 IF(ISUB.EQ.133) THEN
29959 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29960 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29961 ELSE
29962 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29963 ENDIF
29964 DO 450 I=MMINA,MMAXA
29965 IF(I.EQ.0) GOTO 450
29966 EI=KCHG(IABS(I),1)/3D0
29967 FACGQ=FGQ*EI**4
29968 DO 440 ISDE=1,2
29969 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29970 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29971 NCHN=NCHN+1
29972 ISIG(NCHN,ISDE)=I
29973 ISIG(NCHN,3-ISDE)=22
29974 ISIG(NCHN,3)=1
29975 SIGH(NCHN)=FACGQ
29976 440 CONTINUE
29977 450 CONTINUE
29978
29979 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29980C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29981 PH=0D0
29982 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29983 & PH=VINT(3)**2
29984 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29985 & PH=VINT(4)**2
29986 CALL PYWIDT(21,SH,WDTP,WDTE)
29987 WDTESU=0D0
29988 DO 460 I=1,MIN(8,MDCY(21,3))
29989 EF=KCHG(I,1)/3D0
29990 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29991 & WDTE(I,4))
29992 460 CONTINUE
29993 IF(ISUB.EQ.135) THEN
29994 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29995 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29996 ELSE
29997 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29998 ENDIF
29999 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30000 NCHN=NCHN+1
30001 ISIG(NCHN,1)=21
30002 ISIG(NCHN,2)=22
30003 ISIG(NCHN,3)=1
30004 SIGH(NCHN)=FACQQ
30005 ENDIF
30006 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30007 NCHN=NCHN+1
30008 ISIG(NCHN,1)=22
30009 ISIG(NCHN,2)=21
30010 ISIG(NCHN,3)=1
30011 SIGH(NCHN)=FACQQ
30012 ENDIF
30013
30014 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30015C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30016 PH1=0D0
30017 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30018 PH2=0D0
30019 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30020 CALL PYWIDT(22,SH,WDTP,WDTE)
30021 WDTESU=0D0
30022 DO 470 I=1,MIN(12,MDCY(22,3))
30023 IF(I.LE.8) EF= KCHG(I,1)/3D0
30024 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30025 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30026 & WDTE(I,4))
30027 470 CONTINUE
30028 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30029 IF(ISUB.EQ.137) THEN
30030 FPARAM=-SH*(TH+UH)/DLAMB2
30031 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30032 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30033 & 2D0*PH1*PH2*FPARAM**2)
30034 ELSEIF(ISUB.EQ.138) THEN
30035 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30036 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30037 & 2D0*PH1**2*(TH-UH)**2)
30038 ELSEIF(ISUB.EQ.139) THEN
30039 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30040 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30041 & 2D0*PH2**2*(TH-UH)**2)
30042 ELSE
30043 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30044 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30045 ENDIF
30046 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30047 NCHN=NCHN+1
30048 ISIG(NCHN,1)=22
30049 ISIG(NCHN,2)=22
30050 ISIG(NCHN,3)=1
30051 SIGH(NCHN)=FACFF
30052 ENDIF
30053
30054 ENDIF
30055 ENDIF
30056
30057 RETURN
30058 END
30059
30060C*********************************************************************
30061
30062C...PYSGHF
30063C...Subprocess cross sections for heavy flavour production,
30064C...open and closed.
30065C...Auxiliary to PYSIGH.
30066
30067 SUBROUTINE PYSGHF(NCHN,SIGS)
30068
30069C...Double precision and integer declarations
30070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30071 IMPLICIT INTEGER(I-N)
30072 INTEGER PYK,PYCHGE,PYCOMP
30073C...Parameter statement to help give large particle numbers.
30074 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30075 &KEXCIT=4000000,KDIMEN=5000000)
30076C...Commonblocks
30077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30079 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30080 COMMON/PYINT1/MINT(400),VINT(400)
30081 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30082 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30083 COMMON/PYINT4/MWID(500),WIDS(500,5)
30084 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30085 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30086 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30087 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30088 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30089 &/PYINT4/,/PYSGCM/
30090C...Local arrays
30091 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30092
30093C...Determine where are charmonium/bottomonium wave function parameters.
30094 IONIUM=140
30095 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30096
30097C...Convert bottomonium process into equivalent charmonium ones.
30098 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30099
30100C...Differential cross section expressions.
30101
30102 IF(ISUB.LE.100) THEN
30103 IF(ISUB.EQ.81) THEN
30104C...q + qbar -> Q + Qbar
30105 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30106 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30107 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30108 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30109 & 2D0*SQMAVG/SH)
30110 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30111 WID2=1D0
30112 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30113 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30114 FACQQB=FACQQB*WID2
30115 DO 100 I=MMINA,MMAXA
30116 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30117 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30118 NCHN=NCHN+1
30119 ISIG(NCHN,1)=I
30120 ISIG(NCHN,2)=-I
30121 ISIG(NCHN,3)=1
30122 SIGH(NCHN)=FACQQB
30123 100 CONTINUE
30124
30125 ELSEIF(ISUB.EQ.82) THEN
30126C...g + g -> Q + Qbar
30127 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30128 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30129 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30130 THUHQ=THQ*UHQ-SQMAVG*SH
30131 IF(MSTP(34).EQ.0) THEN
30132 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30133 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30134 ELSE
30135 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30136 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30137 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30138 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30139 ENDIF
30140 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30141 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30142 IF(MSTP(35).GE.1) THEN
30143 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30144 FACQQ1=FACQQ1*FATRE
30145 FACQQ2=FACQQ2*FATRE
30146 ENDIF
30147 WID2=1D0
30148 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30149 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30150 FACQQ1=FACQQ1*WID2
30151 FACQQ2=FACQQ2*WID2
30152 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
30153 NCHN=NCHN+1
30154 ISIG(NCHN,1)=21
30155 ISIG(NCHN,2)=21
30156 ISIG(NCHN,3)=1
30157 SIGH(NCHN)=FACQQ1
30158 NCHN=NCHN+1
30159 ISIG(NCHN,1)=21
30160 ISIG(NCHN,2)=21
30161 ISIG(NCHN,3)=2
30162 SIGH(NCHN)=FACQQ2
30163 110 CONTINUE
30164
30165 ELSEIF(ISUB.EQ.83) THEN
30166C...f + q -> f' + Q
30167 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
30168 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
30169 DO 130 I=MMIN1,MMAX1
30170 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
30171 DO 120 J=MMIN2,MMAX2
30172 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
30173 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
30174 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
30175 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
30176 & THEN
30177 NCHN=NCHN+1
30178 ISIG(NCHN,1)=I
30179 ISIG(NCHN,2)=J
30180 ISIG(NCHN,3)=1
30181 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30182 & (IABS(I)+1)/2)*VINT(180+J)
30183 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
30184 & (MINT(55)+1)/2)*VINT(180+J)
30185 WID2=1D0
30186 IF(I.GT.0) THEN
30187 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30188 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30189 & WIDS(MINT(55),2)
30190 ELSE
30191 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30192 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30193 & WIDS(MINT(55),3)
30194 ENDIF
30195 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30196 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30197 ENDIF
30198 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
30199 & THEN
30200 NCHN=NCHN+1
30201 ISIG(NCHN,1)=I
30202 ISIG(NCHN,2)=J
30203 ISIG(NCHN,3)=2
30204 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30205 & (IABS(J)+1)/2)*VINT(180+I)
30206 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
30207 & (MINT(55)+1)/2)*VINT(180+I)
30208 IF(J.GT.0) THEN
30209 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30210 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30211 & WIDS(MINT(55),2)
30212 ELSE
30213 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30214 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30215 & WIDS(MINT(55),3)
30216 ENDIF
30217 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30218 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30219 ENDIF
30220 120 CONTINUE
30221 130 CONTINUE
30222
30223 ELSEIF(ISUB.EQ.84) THEN
30224C...g + gamma -> Q + Qbar
30225 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30226 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30227 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30228 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
30229 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
30230 & (THQ*UHQ)
30231 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
30232 WID2=1D0
30233 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30234 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30235 FACQQ=FACQQ*WID2
30236 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30237 NCHN=NCHN+1
30238 ISIG(NCHN,1)=21
30239 ISIG(NCHN,2)=22
30240 ISIG(NCHN,3)=1
30241 SIGH(NCHN)=FACQQ
30242 ENDIF
30243 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30244 NCHN=NCHN+1
30245 ISIG(NCHN,1)=22
30246 ISIG(NCHN,2)=21
30247 ISIG(NCHN,3)=1
30248 SIGH(NCHN)=FACQQ
30249 ENDIF
30250
30251 ELSEIF(ISUB.EQ.85) THEN
30252C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
30253 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30254 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30255 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30256 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
30257 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
30258 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
30259 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
30260 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
30261 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
30262 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
30263 WID2=1D0
30264 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
30265 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
30266 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
30267 FACFF=FACFF*WID2
30268 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30269 NCHN=NCHN+1
30270 ISIG(NCHN,1)=22
30271 ISIG(NCHN,2)=22
30272 ISIG(NCHN,3)=1
30273 SIGH(NCHN)=FACFF
30274 ENDIF
30275
30276 ELSEIF(ISUB.EQ.86) THEN
30277C...g + g -> J/Psi + g
30278 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
30279 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30280 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30281 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30282 NCHN=NCHN+1
30283 ISIG(NCHN,1)=21
30284 ISIG(NCHN,2)=21
30285 ISIG(NCHN,3)=1
30286 SIGH(NCHN)=FACQQG
30287 ENDIF
30288
30289 ELSEIF(ISUB.EQ.87) THEN
30290C...g + g -> chi_0c + g
30291 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30292 QGTW=(SH*TH*UH)/SH**3
30293 RGTW=SQM3/SH
30294 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30295 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30296 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
30297 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
30298 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
30299 & (QGTW*(QGTW-RGTW*PGTW)**4)
30300 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30301 NCHN=NCHN+1
30302 ISIG(NCHN,1)=21
30303 ISIG(NCHN,2)=21
30304 ISIG(NCHN,3)=1
30305 SIGH(NCHN)=FACQQG
30306 ENDIF
30307
30308 ELSEIF(ISUB.EQ.88) THEN
30309C...g + g -> chi_1c + g
30310 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30311 QGTW=(SH*TH*UH)/SH**3
30312 RGTW=SQM3/SH
30313 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30314 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
30315 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
30316 & (QGTW-RGTW*PGTW)**4
30317 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30318 NCHN=NCHN+1
30319 ISIG(NCHN,1)=21
30320 ISIG(NCHN,2)=21
30321 ISIG(NCHN,3)=1
30322 SIGH(NCHN)=FACQQG
30323 ENDIF
30324
30325 ELSEIF(ISUB.EQ.89) THEN
30326C...g + g -> chi_2c + g
30327 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30328 QGTW=(SH*TH*UH)/SH**3
30329 RGTW=SQM3/SH
30330 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30331 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30332 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
30333 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
30334 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
30335 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30336 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30337 NCHN=NCHN+1
30338 ISIG(NCHN,1)=21
30339 ISIG(NCHN,2)=21
30340 ISIG(NCHN,3)=1
30341 SIGH(NCHN)=FACQQG
30342 ENDIF
30343 ENDIF
30344
30345 ELSEIF(ISUB.LE.200) THEN
30346 IF(ISUB.EQ.104) THEN
30347C...g + g -> chi_c0.
30348 KC=PYCOMP(10441)
30349 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
30350 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30351 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30352 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30353 NCHN=NCHN+1
30354 ISIG(NCHN,1)=21
30355 ISIG(NCHN,2)=21
30356 ISIG(NCHN,3)=1
30357 SIGH(NCHN)=FACBW
30358 ENDIF
30359
30360 ELSEIF(ISUB.EQ.105) THEN
30361C...g + g -> chi_c2.
30362 KC=PYCOMP(445)
30363 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
30364 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30365 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30366 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30367 NCHN=NCHN+1
30368 ISIG(NCHN,1)=21
30369 ISIG(NCHN,2)=21
30370 ISIG(NCHN,3)=1
30371 SIGH(NCHN)=FACBW
30372 ENDIF
30373
30374 ELSEIF(ISUB.EQ.106) THEN
30375C...g + g -> J/Psi + gamma.
30376 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30377 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
30378 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30379 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30380 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30381 NCHN=NCHN+1
30382 ISIG(NCHN,1)=21
30383 ISIG(NCHN,2)=21
30384 ISIG(NCHN,3)=1
30385 SIGH(NCHN)=FACQQG
30386 ENDIF
30387
30388 ELSEIF(ISUB.EQ.107) THEN
30389C...g + gamma -> J/Psi + g.
30390 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30391 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
30392 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30393 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30394 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30395 NCHN=NCHN+1
30396 ISIG(NCHN,1)=21
30397 ISIG(NCHN,2)=22
30398 ISIG(NCHN,3)=1
30399 SIGH(NCHN)=FACQQG
30400 ENDIF
30401 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30402 NCHN=NCHN+1
30403 ISIG(NCHN,1)=22
30404 ISIG(NCHN,2)=21
30405 ISIG(NCHN,3)=1
30406 SIGH(NCHN)=FACQQG
30407 ENDIF
30408
30409 ELSEIF(ISUB.EQ.108) THEN
30410C...gamma + gamma -> J/Psi + gamma.
30411 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30412 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
30413 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30414 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30415 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30416 NCHN=NCHN+1
30417 ISIG(NCHN,1)=22
30418 ISIG(NCHN,2)=22
30419 ISIG(NCHN,3)=1
30420 SIGH(NCHN)=FACQQG
30421 ENDIF
30422 ENDIF
30423
30424C...QUARKONIA+++
30425C...Additional code by Stefan Wolf
30426 ELSE
30427
30428C...Common code for quarkonium production.
30429 SHTH=SH+TH
30430 THUH=TH+UH
30431 UHSH=UH+SH
30432 SHTH2=SHTH**2
30433 THUH2=THUH**2
30434 UHSH2=UHSH**2
30435 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
30436 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
30437 SQMQQ=SQM3
30438 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
30439 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
30440 SQMQQ=SQM4
30441 ENDIF
30442 SQMQQR=SQRT(SQMQQ)
30443 IF(MSTP(145).EQ.1) THEN
30444 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
30445 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
30446 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
30447 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
30448 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30449 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30450 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30451 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30452 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
30453 & ISUB.GE.437) THEN
30454 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
30455 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
30456 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30457 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30458 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30459 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30460 ENDIF
30461 AQ2=AQ**2
30462 BQ2=BQ**2
30463 SMQQ2=SQMQQ*VINT(2)
30464C...Polarisation frames
30465 IF(MSTP(146).EQ.1) THEN
30466C...Recoil frame
30467 POLH1=SQRT(AQ2-SMQQ2)
30468 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30469 AZ=-SQMQQR/POLH1
30470 BZ=0D0
30471 AX=AQ*BQ/(POLH1*POLH2)
30472 BX=-POLH1/POLH2
30473 ELSEIF(MSTP(146).EQ.2) THEN
30474C...Gottfried Jackson frame
30475 POLH1=AQ+BQ
30476 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30477 AZ=SQMQQR/POLH1
30478 BZ=AZ
30479 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
30480 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
30481 ELSEIF(MSTP(146).EQ.3) THEN
30482C...Target frame
30483 POLH1=AQ-BQ
30484 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30485 AZ=-SQMQQR/POLH1
30486 BZ=-AZ
30487 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
30488 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
30489 ELSEIF(MSTP(146).EQ.4) THEN
30490C...Collins Soper frame
30491 POLH1=AQ2-BQ2
30492 POLH2=SQRT(VINT(2)*POLH1)
30493 AZ=-BQ/POLH2
30494 BZ=AQ/POLH2
30495 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
30496 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
30497 ENDIF
30498C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
30499 EL1K10=AZ*ATILK1+BZ*BTILK1
30500 EL1K20=AZ*ATILK2+BZ*BTILK2
30501 EL2K10=EL1K10
30502 EL2K20=EL1K20
30503 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
30504 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
30505 EL2K11=EL1K11
30506 EL2K21=EL1K21
30507 ENDIF
30508
30509 IF(ISUB.EQ.421) THEN
30510C...g + g -> QQ~[3S11] + g
30511 IF(MSTP(145).EQ.0) THEN
30512* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30513* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
30514 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30515 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
30516* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30517* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
30518 ELSE
30519 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
30520 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30521 BB=2D0*(SH2+TH2)
30522 CC=2D0*(SH2+UH2)
30523 DD=2D0*SH2
30524 IF(MSTP(147).EQ.0) THEN
30525 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30526 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30527 ELSEIF(MSTP(147).EQ.1) THEN
30528 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30529 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30530 ELSEIF(MSTP(147).EQ.3) THEN
30531 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30532 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30533 ELSEIF(MSTP(147).EQ.4) THEN
30534 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30535 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30536 ELSEIF(MSTP(147).EQ.5) THEN
30537 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30538 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30539 ELSEIF(MSTP(147).EQ.6) THEN
30540 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30541 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30542 ENDIF
30543 FACQQG=COMFAC*FF*FACQQG
30544 ENDIF
30545 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30546 NCHN=NCHN+1
30547 ISIG(NCHN,1)=21
30548 ISIG(NCHN,2)=21
30549 ISIG(NCHN,3)=1
30550 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
30551 ENDIF
30552
30553 ELSEIF(ISUB.EQ.422) THEN
30554C...g + g -> QQ~[3S18] + g
30555 IF(MSTP(145).EQ.0) THEN
30556 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
30557 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30558 & (SQMQQ*SQMQQR)*
30559 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
30560 ELSE
30561 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30562 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
30563 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30564 BB=2D0*(SH2+TH2)
30565 CC=2D0*(SH2+UH2)
30566 DD=2D0*SH2
30567 IF(MSTP(147).EQ.0) THEN
30568 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30569 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30570 ELSEIF(MSTP(147).EQ.1) THEN
30571 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30572 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30573 ELSEIF(MSTP(147).EQ.3) THEN
30574 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30575 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30576 ELSEIF(MSTP(147).EQ.4) THEN
30577 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30578 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30579 ELSEIF(MSTP(147).EQ.5) THEN
30580 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30581 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30582 ELSEIF(MSTP(147).EQ.6) THEN
30583 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30584 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30585 ENDIF
30586 FACQQG=COMFAC*FF*FACQQG
30587 ENDIF
30588C...Split total contribution into different colour flows just like
30589C...in g g -> g g (recalculate kinematics for massless partons).
30590 THP=-0.5D0*SH*(1D0-CTH)
30591 UHP=-0.5D0*SH*(1D0+CTH)
30592 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30593 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30594 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30595 FACGGS=FACGG1+FACGG2+FACGG3
30596 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30597 NCHN=NCHN+1
30598 ISIG(NCHN,1)=21
30599 ISIG(NCHN,2)=21
30600 ISIG(NCHN,3)=1
30601 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30602 NCHN=NCHN+1
30603 ISIG(NCHN,1)=21
30604 ISIG(NCHN,2)=21
30605 ISIG(NCHN,3)=2
30606 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30607 NCHN=NCHN+1
30608 ISIG(NCHN,1)=21
30609 ISIG(NCHN,2)=21
30610 ISIG(NCHN,3)=3
30611 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
30612 ENDIF
30613
30614 ELSEIF(ISUB.EQ.423) THEN
30615C...g + g -> QQ~[1S08] + g
30616 IF(MSTP(145).EQ.0) THEN
30617* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
30618* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
30619* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
30620* & (SHTH2*THUH2*UHSH2)
30621 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
30622 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30623 & TH2/(SHTH2*THUH2))*
30624 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30625 ELSE
30626 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
30627 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30628 & TH2/(SHTH2*THUH2))*
30629 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30630 IF(MSTP(147).EQ.0) THEN
30631 FACQQG=COMFAC*FA
30632 ELSEIF(MSTP(147).EQ.1) THEN
30633 FACQQG=COMFAC*2D0*FA
30634 ELSEIF(MSTP(147).EQ.3) THEN
30635 FACQQG=COMFAC*FA
30636 ELSEIF(MSTP(147).EQ.4) THEN
30637 FACQQG=COMFAC*FA
30638 ELSEIF(MSTP(147).EQ.5) THEN
30639 FACQQG=0D0
30640 ELSEIF(MSTP(147).EQ.6) THEN
30641 FACQQG=0D0
30642 ENDIF
30643 ENDIF
30644C...Split total contribution into different colour flows just like
30645C...in g g -> g g (recalculate kinematics for massless partons).
30646 THP=-0.5D0*SH*(1D0-CTH)
30647 UHP=-0.5D0*SH*(1D0+CTH)
30648 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30649 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30650 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30651 FACGGS=FACGG1+FACGG2+FACGG3
30652 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30653 NCHN=NCHN+1
30654 ISIG(NCHN,1)=21
30655 ISIG(NCHN,2)=21
30656 ISIG(NCHN,3)=1
30657 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30658 NCHN=NCHN+1
30659 ISIG(NCHN,1)=21
30660 ISIG(NCHN,2)=21
30661 ISIG(NCHN,3)=2
30662 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30663 NCHN=NCHN+1
30664 ISIG(NCHN,1)=21
30665 ISIG(NCHN,2)=21
30666 ISIG(NCHN,3)=3
30667 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
30668 ENDIF
30669
30670 ELSEIF(ISUB.EQ.424) THEN
30671C...g + g -> QQ~[3PJ8] + g
30672 POLY=SH2+SH*TH+TH2
30673 IF(MSTP(145).EQ.0) THEN
30674 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
30675 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
30676 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
30677 & +7D0*TH**6)
30678 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
30679 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
30680 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
30681 & +35D0*TH**8)
30682 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
30683 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
30684 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
30685 & +84D0*TH**8)
30686 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
30687 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
30688 & +451D0*SH*TH**5+126D0*TH**6)
30689 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
30690 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
30691 & +171D0*SH*TH**5+42D0*TH**6)
30692 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
30693 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
30694 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
30695 & +99D0*SH*TH**3+35D0*TH**4)
30696 & +7D0*SQMQQ**8*SHTH*POLY)/
30697 & (SH*TH*UH*SQMQQR*SQMQQ*
30698 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30699 ELSE
30700 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
30701 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30702 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
30703 & -SQMQQ*SHTH2*POLY**2*
30704 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
30705 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
30706 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
30707 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
30708 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
30709 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
30710 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
30711 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
30712 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
30713 & +145D0*SH*TH**5+34D0*TH**6)
30714 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
30715 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
30716 & +44D0*TH**6)
30717 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
30718 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
30719 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
30720 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
30721 & +3D0*SQMQQ**8*SHTH*POLY)
30722 BB=4D0*SHTH2*POLY**3
30723 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
30724 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
30725 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
30726 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
30727 & +84D0*SH*TH**9+20D0*TH**10)
30728 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
30729 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
30730 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
30731 & +40D0*TH**8)
30732 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
30733 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
30734 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
30735 & +40D0*TH**8)
30736 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
30737 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
30738 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
30739 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
30740 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
30741 & +4D0*TH**6)
30742 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
30743 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
30744 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
30745 CC=4D0*TH2*POLY**3
30746 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
30747 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
30748 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
30749 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
30750 & +28D0*TH**9)
30751 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
30752 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
30753 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
30754 & +394D0*SH*TH**9+84D0*TH**10)
30755 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
30756 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
30757 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
30758 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
30759 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
30760 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
30761 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
30762 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
30763 & +266D0*SH*TH**6+84D0*TH**7)
30764 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
30765 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
30766 & +28D0*TH**6)
30767 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
30768 & +7D0*SH*TH**3+4*TH**4)
30769 & +SQMQQ**8*SH*(SH-TH)**2*TH
30770 DD=2D0*TH2*SHTH2*POLY**3
30771 & *(-SH2+2*SH*TH+2*TH2)
30772 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
30773 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
30774 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
30775 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
30776 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
30777 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
30778 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
30779 & -210D0*SH*TH**8-60D0*TH**9)
30780 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
30781 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
30782 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
30783 & -80D0*TH**8)
30784 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
30785 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
30786 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
30787 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
30788 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
30789 & -30D0*SH*TH**6-24D0*TH**7)
30790 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
30791 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
30792 & -4D0*TH**6)
30793 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
30794 IF(MSTP(147).EQ.0) THEN
30795 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30796 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30797 ELSEIF(MSTP(147).EQ.1) THEN
30798 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30799 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30800 ELSEIF(MSTP(147).EQ.3) THEN
30801 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30802 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30803 ELSEIF(MSTP(147).EQ.4) THEN
30804 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30805 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30806 ELSEIF(MSTP(147).EQ.5) THEN
30807 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30808 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30809 ELSEIF(MSTP(147).EQ.6) THEN
30810 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30811 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30812 ENDIF
30813 FACQQG=COMFAC*FF*FACQQG
30814 ENDIF
30815C...Split total contribution into different colour flows just like
30816C...in g g -> g g (recalculate kinematics for massless partons).
30817 THP=-0.5D0*SH*(1D0-CTH)
30818 UHP=-0.5D0*SH*(1D0+CTH)
30819 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30820 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30821 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30822 FACGGS=FACGG1+FACGG2+FACGG3
30823 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30824 NCHN=NCHN+1
30825 ISIG(NCHN,1)=21
30826 ISIG(NCHN,2)=21
30827 ISIG(NCHN,3)=1
30828 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30829 NCHN=NCHN+1
30830 ISIG(NCHN,1)=21
30831 ISIG(NCHN,2)=21
30832 ISIG(NCHN,3)=2
30833 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30834 NCHN=NCHN+1
30835 ISIG(NCHN,1)=21
30836 ISIG(NCHN,2)=21
30837 ISIG(NCHN,3)=3
30838 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
30839 ENDIF
30840
30841 ELSEIF(ISUB.EQ.425) THEN
30842C...q + g -> q + QQ~[3S18]
30843 IF(MSTP(145).EQ.0) THEN
30844 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
30845 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
30846 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
30847 ELSE
30848 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
30849 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
30850 AA=SHTH2+THUH2
30851 BB=4D0
30852 CC=8D0
30853 DD=4D0
30854 IF(MSTP(147).EQ.0) THEN
30855 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30856 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30857 ELSEIF(MSTP(147).EQ.1) THEN
30858 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30859 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30860 ELSEIF(MSTP(147).EQ.3) THEN
30861 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30862 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30863 ELSEIF(MSTP(147).EQ.4) THEN
30864 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30865 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30866 ELSEIF(MSTP(147).EQ.5) THEN
30867 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30868 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30869 ELSEIF(MSTP(147).EQ.6) THEN
30870 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30871 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30872 ENDIF
30873 FACQQG=COMFAC*FF*FACQQG
30874 ENDIF
30875C...Split total contribution into different colour flows just like
30876C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30877C...(recalculate kinematics for massless partons).
30878 THP=-0.5D0*SH*(1D0-CTH)
30879 UHP=-0.5D0*SH*(1D0+CTH)
30880 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30881 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30882 FACQGS=FACQG1+FACQG2
30883 DO 2442 I=MMINA,MMAXA
30884 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
30885 DO 2441 ISDE=1,2
30886 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
30887 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
30888 NCHN=NCHN+1
30889 ISIG(NCHN,ISDE)=I
30890 ISIG(NCHN,3-ISDE)=21
30891 ISIG(NCHN,3)=1
30892 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
30893 NCHN=NCHN+1
30894 ISIG(NCHN,ISDE)=I
30895 ISIG(NCHN,3-ISDE)=21
30896 ISIG(NCHN,3)=2
30897 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
30898 2441 CONTINUE
30899 2442 CONTINUE
30900
30901 ELSEIF(ISUB.EQ.426) THEN
30902C...q + g -> q + QQ~[1S08]
30903 IF(MSTP(145).EQ.0) THEN
30904 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
30905 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
30906 ELSE
30907 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
30908 IF(MSTP(147).EQ.0) THEN
30909 FACQQG=COMFAC*FA
30910 ELSEIF(MSTP(147).EQ.1) THEN
30911 FACQQG=COMFAC*2D0*FA
30912 ELSEIF(MSTP(147).EQ.3) THEN
30913 FACQQG=COMFAC*FA
30914 ELSEIF(MSTP(147).EQ.4) THEN
30915 FACQQG=COMFAC*FA
30916 ELSEIF(MSTP(147).EQ.5) THEN
30917 FACQQG=0D0
30918 ELSEIF(MSTP(147).EQ.6) THEN
30919 FACQQG=0D0
30920 ENDIF
30921 ENDIF
30922C...Split total contribution into different colour flows just like
30923C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30924C...(recalculate kinematics for massless partons).
30925 THP=-0.5D0*SH*(1D0-CTH)
30926 UHP=-0.5D0*SH*(1D0+CTH)
30927 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30928 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30929 FACQGS=FACQG1+FACQG2
30930 DO 2444 I=MMINA,MMAXA
30931 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30932 DO 2443 ISDE=1,2
30933 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30934 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30935 NCHN=NCHN+1
30936 ISIG(NCHN,ISDE)=I
30937 ISIG(NCHN,3-ISDE)=21
30938 ISIG(NCHN,3)=1
30939 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30940 NCHN=NCHN+1
30941 ISIG(NCHN,ISDE)=I
30942 ISIG(NCHN,3-ISDE)=21
30943 ISIG(NCHN,3)=2
30944 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30945 2443 CONTINUE
30946 2444 CONTINUE
30947
30948 ELSEIF(ISUB.EQ.427) THEN
30949C...q + g -> q + QQ~[3PJ8]
30950 IF(MSTP(145).EQ.0) THEN
30951 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30952 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30953 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30954 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30955 ELSE
30956 FF=10D0*PARU(1)*AS**3/
30957 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30958 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30959 BB=8D0*(SHTH2+TH*UH)
30960 CC=8D0*UHSH*(SHTH+THUH)
30961 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30962 IF(MSTP(147).EQ.0) THEN
30963 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30964 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30965 ELSEIF(MSTP(147).EQ.1) THEN
30966 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30967 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30968 ELSEIF(MSTP(147).EQ.3) THEN
30969 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30970 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30971 ELSEIF(MSTP(147).EQ.4) THEN
30972 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30973 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30974 ELSEIF(MSTP(147).EQ.5) THEN
30975 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30976 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30977 ELSEIF(MSTP(147).EQ.6) THEN
30978 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30979 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30980 ENDIF
30981 FACQQG=COMFAC*FF*FACQQG
30982 ENDIF
30983C...Split total contribution into different colour flows just like
30984C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30985C...(recalculate kinematics for massless partons).
30986 THP=-0.5D0*SH*(1D0-CTH)
30987 UHP=-0.5D0*SH*(1D0+CTH)
30988 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30989 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30990 FACQGS=FACQG1+FACQG2
30991 DO 2446 I=MMINA,MMAXA
30992 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30993 DO 2445 ISDE=1,2
30994 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30995 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30996 NCHN=NCHN+1
30997 ISIG(NCHN,ISDE)=I
30998 ISIG(NCHN,3-ISDE)=21
30999 ISIG(NCHN,3)=1
31000 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31001 NCHN=NCHN+1
31002 ISIG(NCHN,ISDE)=I
31003 ISIG(NCHN,3-ISDE)=21
31004 ISIG(NCHN,3)=2
31005 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31006 2445 CONTINUE
31007 2446 CONTINUE
31008
31009 ELSEIF(ISUB.EQ.428) THEN
31010C...q + q~ -> g + QQ~[3S18]
31011 IF(MSTP(145).EQ.0) THEN
31012 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31013 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31014 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31015 ELSE
31016 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31017 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31018 AA=SHTH2+UHSH2
31019 BB=4D0
31020 CC=4D0
31021 DD=0D0
31022 IF(MSTP(147).EQ.0) THEN
31023 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31024 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31025 ELSEIF(MSTP(147).EQ.1) THEN
31026 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31027 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31028 ELSEIF(MSTP(147).EQ.3) THEN
31029 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31030 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31031 ELSEIF(MSTP(147).EQ.4) THEN
31032 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31033 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31034 ELSEIF(MSTP(147).EQ.5) THEN
31035 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31036 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31037 ELSEIF(MSTP(147).EQ.6) THEN
31038 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31039 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31040 ENDIF
31041 FACQQG=COMFAC*FF*FACQQG
31042 ENDIF
31043C...Split total contribution into different colour flows just like
31044C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31045C...(recalculate kinematics for massless partons).
31046 THP=-0.5D0*SH*(1D0-CTH)
31047 UHP=-0.5D0*SH*(1D0+CTH)
31048 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31049 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31050 FACGGS=FACGG1+FACGG2
31051 DO 2447 I=MMINA,MMAXA
31052 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31053 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31054 NCHN=NCHN+1
31055 ISIG(NCHN,1)=I
31056 ISIG(NCHN,2)=-I
31057 ISIG(NCHN,3)=1
31058 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31059 NCHN=NCHN+1
31060 ISIG(NCHN,1)=I
31061 ISIG(NCHN,2)=-I
31062 ISIG(NCHN,3)=2
31063 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31064 2447 CONTINUE
31065
31066 ELSEIF(ISUB.EQ.429) THEN
31067C...q + q~ -> g + QQ~[1S08]
31068 IF(MSTP(145).EQ.0) THEN
31069 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31070 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31071 ELSE
31072 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31073 IF(MSTP(147).EQ.0) THEN
31074 FACQQG=COMFAC*FA
31075 ELSEIF(MSTP(147).EQ.1) THEN
31076 FACQQG=COMFAC*2D0*FA
31077 ELSEIF(MSTP(147).EQ.3) THEN
31078 FACQQG=COMFAC*FA
31079 ELSEIF(MSTP(147).EQ.4) THEN
31080 FACQQG=COMFAC*FA
31081 ELSEIF(MSTP(147).EQ.5) THEN
31082 FACQQG=0D0
31083 ELSEIF(MSTP(147).EQ.6) THEN
31084 FACQQG=0D0
31085 ENDIF
31086 ENDIF
31087C...Split total contribution into different colour flows just like
31088C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31089C...(recalculate kinematics for massless partons).
31090 THP=-0.5D0*SH*(1D0-CTH)
31091 UHP=-0.5D0*SH*(1D0+CTH)
31092 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31093 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31094 FACGGS=FACGG1+FACGG2
31095 DO 2448 I=MMINA,MMAXA
31096 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31097 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31098 NCHN=NCHN+1
31099 ISIG(NCHN,1)=I
31100 ISIG(NCHN,2)=-I
31101 ISIG(NCHN,3)=1
31102 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31103 NCHN=NCHN+1
31104 ISIG(NCHN,1)=I
31105 ISIG(NCHN,2)=-I
31106 ISIG(NCHN,3)=2
31107 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31108 2448 CONTINUE
31109
31110 ELSEIF(ISUB.EQ.430) THEN
31111C...q + q~ -> g + QQ~[3PJ8]
31112 IF(MSTP(145).EQ.0) THEN
31113 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31114 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31115 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31116 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31117 ELSE
31118 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31119 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31120 BB=8D0*(UHSH2+SH*TH)
31121 CC=8D0*(SHTH2+SH*UH)
31122 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31123 IF(MSTP(147).EQ.0) THEN
31124 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31125 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31126 ELSEIF(MSTP(147).EQ.1) THEN
31127 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31128 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31129 ELSEIF(MSTP(147).EQ.3) THEN
31130 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31131 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31132 ELSEIF(MSTP(147).EQ.4) THEN
31133 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31134 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31135 ELSEIF(MSTP(147).EQ.5) THEN
31136 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31137 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31138 ELSEIF(MSTP(147).EQ.6) THEN
31139 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31140 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31141 ENDIF
31142 FACQQG=COMFAC*FF*FACQQG
31143 ENDIF
31144C...Split total contribution into different colour flows just like
31145C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31146C...(recalculate kinematics for massless partons).
31147 THP=-0.5D0*SH*(1D0-CTH)
31148 UHP=-0.5D0*SH*(1D0+CTH)
31149 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31150 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31151 FACGGS=FACGG1+FACGG2
31152 DO 2449 I=MMINA,MMAXA
31153 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31154 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
31155 NCHN=NCHN+1
31156 ISIG(NCHN,1)=I
31157 ISIG(NCHN,2)=-I
31158 ISIG(NCHN,3)=1
31159 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31160 NCHN=NCHN+1
31161 ISIG(NCHN,1)=I
31162 ISIG(NCHN,2)=-I
31163 ISIG(NCHN,3)=2
31164 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31165 2449 CONTINUE
31166
31167 ELSEIF(ISUB.EQ.431) THEN
31168C...g + g -> QQ~[3P01] + g
31169 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31170 QGTW=(SH*TH*UH)/SH**3
31171 RGTW=SQMQQ/SH
31172 IF(MSTP(145).EQ.0) THEN
31173 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31174 & (9D0*RGTW**2*PGTW**4*
31175 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31176 & -6D0*RGTW*PGTW**3*QGTW*
31177 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31178 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31179 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31180 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31181 ELSE
31182 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
31183 & (9D0*RGTW**2*PGTW**4*
31184 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31185 & -6D0*RGTW*PGTW**3*QGTW*
31186 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31187 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31188 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31189 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31190 IF(MSTP(147).EQ.0) THEN
31191 FACQQG=COMFAC*FC1
31192 ELSEIF(MSTP(147).EQ.1) THEN
31193 FACQQG=COMFAC*2D0*FC1
31194 ELSEIF(MSTP(147).EQ.3) THEN
31195 FACQQG=COMFAC*FC1
31196 ELSEIF(MSTP(147).EQ.4) THEN
31197 FACQQG=COMFAC*FC1
31198 ELSEIF(MSTP(147).EQ.5) THEN
31199 FACQQG=0D0
31200 ELSEIF(MSTP(147).EQ.6) THEN
31201 FACQQG=0D0
31202 ENDIF
31203 ENDIF
31204 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31205 NCHN=NCHN+1
31206 ISIG(NCHN,1)=21
31207 ISIG(NCHN,2)=21
31208 ISIG(NCHN,3)=1
31209 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31210 ENDIF
31211
31212 ELSEIF(ISUB.EQ.432) THEN
31213C...g + g -> QQ~[3P11] + g
31214 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31215 QGTW=(SH*TH*UH)/SH**3
31216 RGTW=SQMQQ/SH
31217 IF(MSTP(145).EQ.0) THEN
31218 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
31219 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
31220 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
31221 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
31222 ELSE
31223 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
31224 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
31225 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
31226 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
31227 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
31228 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31229 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31230 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
31231 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31232 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31233 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
31234 C4=-4D0*THUH*(TH-UH)**2*
31235 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
31236 & -SH2*TH*UH*(TH2+UH2))
31237 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
31238 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
31239 & +SH2*(5D0*THUH2-17D0*TH*UH)))
31240 IF(MSTP(147).EQ.0) THEN
31241 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31242 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31243 ELSEIF(MSTP(147).EQ.1) THEN
31244 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31245 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31246 ELSEIF(MSTP(147).EQ.3) THEN
31247 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31248 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31249 ELSEIF(MSTP(147).EQ.4) THEN
31250 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31251 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31252 ELSEIF(MSTP(147).EQ.5) THEN
31253 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31254 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31255 ELSEIF(MSTP(147).EQ.6) THEN
31256 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31257 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31258 ENDIF
31259 FACQQG=COMFAC*FF*FACQQG
31260 ENDIF
31261 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31262 NCHN=NCHN+1
31263 ISIG(NCHN,1)=21
31264 ISIG(NCHN,2)=21
31265 ISIG(NCHN,3)=1
31266 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31267 ENDIF
31268
31269 ELSEIF(ISUB.EQ.433) THEN
31270C...g + g -> QQ~[3P21] + g
31271 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31272 QGTW=(SH*TH*UH)/SH**3
31273 RGTW=SQMQQ/SH
31274 IF(MSTP(145).EQ.0) THEN
31275 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31276 & (12D0*RGTW**2*PGTW**4*
31277 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31278 & -3D0*RGTW*PGTW**3*QGTW*
31279 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
31280 & +2D0*PGTW**2*QGTW**2*
31281 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
31282 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
31283 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31284 ELSE
31285 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
31286 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
31287 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
31288 & *SH*SH2**7
31289 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
31290 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
31291 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
31292 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
31293 & +10D0*(SH2**2+TH2**2))
31294 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
31295 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
31296 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
31297 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
31298 & +4D0*SH*TH*UH2**4*SHTH2)
31299 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
31300 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
31301 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
31302 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
31303 & +10D0*(SH2**2+UH2**2))
31304 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
31305 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
31306 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
31307 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
31308 & +4D0*SH*UH*TH2**4*UHSH2)
31309 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
31310 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
31311 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
31312 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
31313 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
31314 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
31315 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
31316 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
31317 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
31318 & +3D0*(TH2**3+UH2**3)))
31319 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
31320 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
31321 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
31322 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
31323 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
31324 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
31325 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
31326 & 82D0*TH**3)
31327 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
31328 & +45D0*TH**3)
31329 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
31330 & 8D0*TH**3)
31331 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
31332 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
31333 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
31334 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
31335 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
31336 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
31337 & 82D0*UH**3)
31338 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
31339 & +45D0*UH**3)
31340 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
31341 & 8D0*UH**3)
31342 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
31343 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
31344 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
31345 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
31346 & +4D0*SH*TH2**2*UH2**2*THUH2
31347 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
31348 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
31349 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
31350 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
31351 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31352 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
31353 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
31354 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
31355 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
31356 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
31357 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
31358 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
31359 & +2D0*(TH2**3+UH2**3))
31360 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
31361 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
31362 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
31363 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31364 IF(MSTP(147).EQ.0) THEN
31365 FACQQG=1D0/3D0*(C1*3D0
31366 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31367 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31368 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31369 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31370 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31371 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31372 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31373 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31374 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31375 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31376 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31377 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31378 ELSEIF(MSTP(147).EQ.1) THEN
31379 FACQQG=C1*2D0
31380 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31381 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31382 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31383 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31384 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31385 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31386 & +EL1K10*EL2K20*EL1K11*EL2K11)
31387 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31388 & +EL1K10*EL2K20*EL1K21*EL2K21)
31389 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31390 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31391 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31392 & +EL1K20*EL2K20*EL1K11*EL2K11)
31393 ELSEIF(MSTP(147).EQ.2) THEN
31394 FACQQG=2D0*(C1
31395 & -C2*EL1K11*EL2K11
31396 & -C3*EL1K21*EL2K21
31397 & -C4*EL1K11*EL2K21
31398 & +C5*(EL1K11*EL2K11)**2
31399 & +C6*(EL1K21*EL2K21)**2
31400 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31401 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31402 & +(C9+C0)*(EL1K11*EL2K21)**2)
31403 ENDIF
31404 FACQQG=COMFAC*FF*FACQQG
31405 ENDIF
31406 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31407 NCHN=NCHN+1
31408 ISIG(NCHN,1)=21
31409 ISIG(NCHN,2)=21
31410 ISIG(NCHN,3)=1
31411 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31412 ENDIF
31413
31414 ELSEIF(ISUB.EQ.434) THEN
31415C...q + g -> q + QQ~[3P01]
31416 IF(MSTP(145).EQ.0) THEN
31417 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
31418 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31419 ELSE
31420 FA=-PARU(1)*AS**3*(16D0/243D0)*
31421 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31422 IF(MSTP(147).EQ.0) THEN
31423 FACQQG=COMFAC*FA
31424 ELSEIF(MSTP(147).EQ.1) THEN
31425 FACQQG=COMFAC*2D0*FA
31426 ELSEIF(MSTP(147).EQ.3) THEN
31427 FACQQG=COMFAC*FA
31428 ELSEIF(MSTP(147).EQ.4) THEN
31429 FACQQG=COMFAC*FA
31430 ELSEIF(MSTP(147).EQ.5) THEN
31431 FACQQG=0D0
31432 ELSEIF(MSTP(147).EQ.6) THEN
31433 FACQQG=0D0
31434 ENDIF
31435 ENDIF
31436 DO 2452 I=MMINA,MMAXA
31437 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
31438 DO 2451 ISDE=1,2
31439 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
31440 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
31441 NCHN=NCHN+1
31442 ISIG(NCHN,ISDE)=I
31443 ISIG(NCHN,3-ISDE)=21
31444 ISIG(NCHN,3)=1
31445 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31446 2451 CONTINUE
31447 2452 CONTINUE
31448
31449 ELSEIF(ISUB.EQ.435) THEN
31450C...q + g -> q + QQ~[3P11]
31451 IF(MSTP(145).EQ.0) THEN
31452 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
31453 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
31454 ELSE
31455 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
31456 C1=SH*UH
31457 C2=2D0*SH
31458 C3=0D0
31459 C4=2D0*(SH-UH)
31460 IF(MSTP(147).EQ.0) THEN
31461 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31462 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31463 ELSEIF(MSTP(147).EQ.1) THEN
31464 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31465 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31466 ELSEIF(MSTP(147).EQ.3) THEN
31467 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31468 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31469 ELSEIF(MSTP(147).EQ.4) THEN
31470 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31471 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31472 ELSEIF(MSTP(147).EQ.5) THEN
31473 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31474 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31475 ELSEIF(MSTP(147).EQ.6) THEN
31476 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31477 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31478 ENDIF
31479 FACQQG=COMFAC*FF*FACQQG
31480 ENDIF
31481 DO 2454 I=MMINA,MMAXA
31482 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
31483 DO 2453 ISDE=1,2
31484 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
31485 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
31486 NCHN=NCHN+1
31487 ISIG(NCHN,ISDE)=I
31488 ISIG(NCHN,3-ISDE)=21
31489 ISIG(NCHN,3)=1
31490 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31491 2453 CONTINUE
31492 2454 CONTINUE
31493
31494 ELSEIF(ISUB.EQ.436) THEN
31495C...q + g -> q + QQ~[3P21]
31496 IF(MSTP(145).EQ.0) THEN
31497 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
31498 & ((6D0*SQMQQ**2+TH2)*UHSH2
31499 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
31500 & (SQMQQR*TH*UHSH2**2)
31501 ELSE
31502 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
31503 C1=TH*UHSH2
31504 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
31505 C3=4D0*UHSH2
31506 C4=8D0*SH*UHSH
31507 C5=8D0*TH
31508 C6=0D0
31509 C7=16D0*TH
31510 C8=0D0
31511 C9=-16D0*UHSH
31512 C0=16D0*SQMQQ
31513 IF(MSTP(147).EQ.0) THEN
31514 FACQQG=1D0/3D0*(C1*3D0
31515 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31516 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31517 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31518 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31519 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31520 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31521 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31522 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31523 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31524 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31525 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31526 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31527 ELSEIF(MSTP(147).EQ.1) THEN
31528 FACQQG=C1*2D0
31529 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31530 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31531 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31532 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31533 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31534 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31535 & +EL1K10*EL2K20*EL1K11*EL2K11)
31536 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31537 & +EL1K10*EL2K20*EL1K21*EL2K21)
31538 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31539 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31540 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31541 & +EL1K20*EL2K20*EL1K11*EL2K11)
31542 ELSEIF(MSTP(147).EQ.2) THEN
31543 FACQQG=2D0*(C1
31544 & -C2*EL1K11*EL2K11
31545 & -C3*EL1K21*EL2K21
31546 & -C4*EL1K11*EL2K21
31547 & +C5*(EL1K11*EL2K11)**2
31548 & +C6*(EL1K21*EL2K21)**2
31549 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31550 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31551 & +(C9+C0)*(EL1K11*EL2K21)**2)
31552 ENDIF
31553 FACQQG=COMFAC*FF*FACQQG
31554 ENDIF
31555 DO 2456 I=MMINA,MMAXA
31556 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
31557 DO 2455 ISDE=1,2
31558 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
31559 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
31560 NCHN=NCHN+1
31561 ISIG(NCHN,ISDE)=I
31562 ISIG(NCHN,3-ISDE)=21
31563 ISIG(NCHN,3)=1
31564 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31565 2455 CONTINUE
31566 2456 CONTINUE
31567
31568 ELSEIF(ISUB.EQ.437) THEN
31569C...q + q~ -> g + QQ~[3P01]
31570 IF(MSTP(145).EQ.0) THEN
31571 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
31572 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31573 ELSE
31574 FA=PARU(1)*AS**3*(128D0/729D0)*
31575 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31576 IF(MSTP(147).EQ.0) THEN
31577 FACQQG=COMFAC*FA
31578 ELSEIF(MSTP(147).EQ.1) THEN
31579 FACQQG=COMFAC*2D0*FA
31580 ELSEIF(MSTP(147).EQ.3) THEN
31581 FACQQG=COMFAC*FA
31582 ELSEIF(MSTP(147).EQ.4) THEN
31583 FACQQG=COMFAC*FA
31584 ELSEIF(MSTP(147).EQ.5) THEN
31585 FACQQG=0D0
31586 ELSEIF(MSTP(147).EQ.6) THEN
31587 FACQQG=0D0
31588 ENDIF
31589 ENDIF
31590 DO 2457 I=MMINA,MMAXA
31591 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31592 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
31593 NCHN=NCHN+1
31594 ISIG(NCHN,1)=I
31595 ISIG(NCHN,2)=-I
31596 ISIG(NCHN,3)=1
31597 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31598 2457 CONTINUE
31599
31600 ELSEIF(ISUB.EQ.438) THEN
31601C...q + q~ -> g + QQ~[3P11]
31602 IF(MSTP(145).EQ.0) THEN
31603 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
31604 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
31605 ELSE
31606 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
31607 C1=TH*UH
31608 C2=2D0*UH
31609 C3=2D0*TH
31610 C4=2D0*THUH
31611 IF(MSTP(147).EQ.0) THEN
31612 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31613 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31614 ELSEIF(MSTP(147).EQ.1) THEN
31615 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31616 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31617 ELSEIF(MSTP(147).EQ.3) THEN
31618 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31619 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31620 ELSEIF(MSTP(147).EQ.4) THEN
31621 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31622 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31623 ELSEIF(MSTP(147).EQ.5) THEN
31624 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31625 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31626 ELSEIF(MSTP(147).EQ.6) THEN
31627 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31628 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31629 ENDIF
31630 FACQQG=COMFAC*FF*FACQQG
31631 ENDIF
31632 DO 2458 I=MMINA,MMAXA
31633 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31634 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
31635 NCHN=NCHN+1
31636 ISIG(NCHN,1)=I
31637 ISIG(NCHN,2)=-I
31638 ISIG(NCHN,3)=1
31639 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31640 2458 CONTINUE
31641
31642 ELSEIF(ISUB.EQ.439) THEN
31643C...q + q~ -> g + QQ~[3P21]
31644 IF(MSTP(145).EQ.0) THEN
31645 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
31646 & ((6D0*SQMQQ**2+SH2)*THUH2
31647 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
31648 & (SQMQQR*SH*THUH2**2)
31649 ELSE
31650 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
31651 C1=SH*THUH2
31652 C2=4D0*(SH2+UH2+2D0*SH*THUH)
31653 C3=4D0*(SH2+TH2+2D0*SH*THUH)
31654 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
31655 C5=8D0*SH
31656 C6=C5
31657 C7=16D0*SH
31658 C8=C7
31659 C9=-16D0*THUH
31660 C0=16D0*SQMQQ
31661 IF(MSTP(147).EQ.0) THEN
31662 FACQQG=1D0/3D0*(C1*3D0
31663 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31664 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31665 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31666 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31667 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31668 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31669 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31670 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31671 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31672 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31673 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31674 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31675 ELSEIF(MSTP(147).EQ.1) THEN
31676 FACQQG=C1*2D0
31677 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31678 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31679 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31680 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31681 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31682 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31683 & +EL1K10*EL2K20*EL1K11*EL2K11)
31684 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31685 & +EL1K10*EL2K20*EL1K21*EL2K21)
31686 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31687 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31688 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31689 & +EL1K20*EL2K20*EL1K11*EL2K11)
31690 ELSEIF(MSTP(147).EQ.2) THEN
31691 FACQQG=2D0*(C1
31692 & -C2*EL1K11*EL2K11
31693 & -C3*EL1K21*EL2K21
31694 & -C4*EL1K11*EL2K21
31695 & +C5*(EL1K11*EL2K11)**2
31696 & +C6*(EL1K21*EL2K21)**2
31697 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31698 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31699 & +(C9+C0)*(EL1K11*EL2K21)**2)
31700 ENDIF
31701 FACQQG=COMFAC*FF*FACQQG
31702 ENDIF
31703 DO 2459 I=MMINA,MMAXA
31704 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31705 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
31706 NCHN=NCHN+1
31707 ISIG(NCHN,1)=I
31708 ISIG(NCHN,2)=-I
31709 ISIG(NCHN,3)=1
31710 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31711 2459 CONTINUE
31712 ENDIF
31713C...QUARKONIA---
31714
31715 ENDIF
31716
31717 RETURN
31718 END
31719
31720C*********************************************************************
31721
31722C...PYSGWZ
31723C...Subprocess cross sections for W/Z processes,
31724C...except that longitudinal WW scattering is in Higgs sector.
31725C...Auxiliary to PYSIGH.
31726
31727 SUBROUTINE PYSGWZ(NCHN,SIGS)
31728
31729C...Double precision and integer declarations
31730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31731 IMPLICIT INTEGER(I-N)
31732 INTEGER PYK,PYCHGE,PYCOMP
31733C...Parameter statement to help give large particle numbers.
31734 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31735 &KEXCIT=4000000,KDIMEN=5000000)
31736C...Commonblocks
31737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31739 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31740 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31741 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31742 COMMON/PYINT1/MINT(400),VINT(400)
31743 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31744 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31745 COMMON/PYINT4/MWID(500),WIDS(500,5)
31746 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
31747 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31748 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31749 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31750 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31751 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
31752 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
31753C...Local arrays and complex numbers
31754 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
31755 &HL4(3),HR4(3)
31756 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
31757
31758C...Differential cross section expressions.
31759
31760 IF(ISUB.LE.20) THEN
31761 IF(ISUB.EQ.1) THEN
31762C...f + fbar -> gamma*/Z0
31763 MINT(61)=2
31764 CALL PYWIDT(23,SH,WDTP,WDTE)
31765 HS=SHR*WDTP(0)
31766 FACZ=4D0*COMFAC*3D0
31767 HP0=AEM/3D0*SH
31768 HP1=AEM/3D0*XWC*SH
31769 DO 100 I=MMINA,MMAXA
31770 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31771 EI=KCHG(IABS(I),1)/3D0
31772 AI=SIGN(1D0,EI)
31773 VI=AI-4D0*EI*XWV
31774 HI0=HP0
31775 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
31776 HI1=HP1
31777 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
31778 NCHN=NCHN+1
31779 ISIG(NCHN,1)=I
31780 ISIG(NCHN,2)=-I
31781 ISIG(NCHN,3)=1
31782 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
31783 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
31784 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
31785 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
31786 100 CONTINUE
31787
31788 ELSEIF(ISUB.EQ.2) THEN
31789C...f + fbar' -> W+/-
31790 CALL PYWIDT(24,SH,WDTP,WDTE)
31791 HS=SHR*WDTP(0)
31792 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
31793 HP=AEM/(24D0*XW)*SH
31794 DO 120 I=MMIN1,MMAX1
31795 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31796 IA=IABS(I)
31797 DO 110 J=MMIN2,MMAX2
31798 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31799 JA=IABS(J)
31800 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
31801 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31802 & GOTO 110
31803 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31804 HI=HP*2D0
31805 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
31806 NCHN=NCHN+1
31807 ISIG(NCHN,1)=I
31808 ISIG(NCHN,2)=J
31809 ISIG(NCHN,3)=1
31810 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
31811 SIGH(NCHN)=HI*FACBW*HF
31812 110 CONTINUE
31813 120 CONTINUE
31814
31815 ELSEIF(ISUB.EQ.15) THEN
31816C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
31817 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31818C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31819 HFGG=0D0
31820 HFGZ=0D0
31821 HFZZ=0D0
31822 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31823 DO 130 I=1,MIN(16,MDCY(23,3))
31824 IDC=I+MDCY(23,2)-1
31825 IF(MDME(IDC,1).LT.0) GOTO 130
31826 IMDM=0
31827 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31828 & IMDM=1
31829 IF(I.LE.8) THEN
31830 EF=KCHG(I,1)/3D0
31831 AF=SIGN(1D0,EF+0.1D0)
31832 VF=AF-4D0*EF*XWV
31833 ELSEIF(I.LE.16) THEN
31834 EF=KCHG(I+2,1)/3D0
31835 AF=SIGN(1D0,EF+0.1D0)
31836 VF=AF-4D0*EF*XWV
31837 ENDIF
31838 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31839 IF(4D0*RM1.LT.1D0) THEN
31840 FCOF=1D0
31841 IF(I.LE.8) FCOF=3D0*RADC4
31842 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31843 IF(IMDM.EQ.1) THEN
31844 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31845 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31846 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31847 & AF**2*(1D0-4D0*RM1))*BE34
31848 ENDIF
31849 ENDIF
31850 130 CONTINUE
31851C...Propagators: as simulated in PYOFSH and as desired
31852 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31853 MINT15=MINT(15)
31854 MINT(15)=1
31855 MINT(61)=1
31856 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31857 MINT(15)=MINT15
31858 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31859 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31860 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31861 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31862C...Loop over flavours; consider full gamma/Z structure
31863 DO 140 I=MMINA,MMAXA
31864 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31865 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
31866 EI=KCHG(IABS(I),1)/3D0
31867 AI=SIGN(1D0,EI)
31868 VI=AI-4D0*EI*XWV
31869 NCHN=NCHN+1
31870 ISIG(NCHN,1)=I
31871 ISIG(NCHN,2)=-I
31872 ISIG(NCHN,3)=1
31873 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
31874 & (VI**2+AI**2)*HFZZ)/HBW4
31875 140 CONTINUE
31876
31877 ELSEIF(ISUB.EQ.16) THEN
31878C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
31879 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31880C...Propagators: as simulated in PYOFSH and as desired
31881 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31882 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31883 GMMWC=SQRT(SQM4)*WDTP(0)
31884 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31885 FACWG=FACWG*HBW4C/HBW4
31886 DO 160 I=MMIN1,MMAX1
31887 IA=IABS(I)
31888 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
31889 DO 150 J=MMIN2,MMAX2
31890 JA=IABS(J)
31891 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
31892 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
31893 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31894 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31895 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31896 NCHN=NCHN+1
31897 ISIG(NCHN,1)=I
31898 ISIG(NCHN,2)=J
31899 ISIG(NCHN,3)=1
31900 SIGH(NCHN)=FACWG*FCKM*WIDSC
31901 150 CONTINUE
31902 160 CONTINUE
31903
31904 ELSEIF(ISUB.EQ.19) THEN
31905C...f + fbar -> gamma + (gamma*/Z0)
31906 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31907C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31908 HFGG=0D0
31909 HFGZ=0D0
31910 HFZZ=0D0
31911 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31912 DO 170 I=1,MIN(16,MDCY(23,3))
31913 IDC=I+MDCY(23,2)-1
31914 IF(MDME(IDC,1).LT.0) GOTO 170
31915 IMDM=0
31916 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31917 & IMDM=1
31918 IF(I.LE.8) THEN
31919 EF=KCHG(I,1)/3D0
31920 AF=SIGN(1D0,EF+0.1D0)
31921 VF=AF-4D0*EF*XWV
31922 ELSEIF(I.LE.16) THEN
31923 EF=KCHG(I+2,1)/3D0
31924 AF=SIGN(1D0,EF+0.1D0)
31925 VF=AF-4D0*EF*XWV
31926 ENDIF
31927 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31928 IF(4D0*RM1.LT.1D0) THEN
31929 FCOF=1D0
31930 IF(I.LE.8) FCOF=3D0*RADC4
31931 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31932 IF(IMDM.EQ.1) THEN
31933 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31934 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31935 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31936 & AF**2*(1D0-4D0*RM1))*BE34
31937 ENDIF
31938 ENDIF
31939 170 CONTINUE
31940C...Propagators: as simulated in PYOFSH and as desired
31941 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31942 MINT15=MINT(15)
31943 MINT(15)=1
31944 MINT(61)=1
31945 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31946 MINT(15)=MINT15
31947 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31948 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31949 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31950 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31951C...Loop over flavours; consider full gamma/Z structure
31952 DO 180 I=MMINA,MMAXA
31953 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31954 EI=KCHG(IABS(I),1)/3D0
31955 AI=SIGN(1D0,EI)
31956 VI=AI-4D0*EI*XWV
31957 FCOI=1D0
31958 IF(IABS(I).LE.10) FCOI=FACA/3D0
31959 NCHN=NCHN+1
31960 ISIG(NCHN,1)=I
31961 ISIG(NCHN,2)=-I
31962 ISIG(NCHN,3)=1
31963 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31964 & (VI**2+AI**2)*HFZZ)/HBW4
31965 180 CONTINUE
31966
31967 ELSEIF(ISUB.EQ.20) THEN
31968C...f + fbar' -> gamma + W+/-
31969 FACGW=COMFAC*0.5D0*AEM**2/XW
31970C...Propagators: as simulated in PYOFSH and as desired
31971 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31972 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31973 GMMWC=SQRT(SQM4)*WDTP(0)
31974 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31975 FACGW=FACGW*HBW4C/HBW4
31976C...Anomalous couplings
31977 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31978 TERM2=0D0
31979 TERM3=0D0
31980 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31981 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31982 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31983 & (4D0*SQMW))/(TH+UH)**2
31984 ENDIF
31985 DO 200 I=MMIN1,MMAX1
31986 IA=IABS(I)
31987 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31988 DO 190 J=MMIN2,MMAX2
31989 JA=IABS(J)
31990 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31991 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31992 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31993 & GOTO 190
31994 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31995 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31996 IF(IA.LE.10) THEN
31997 FACWR=UH/(TH+UH)-1D0/3D0
31998 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31999 FCOI=FACA/3D0
32000 ELSE
32001 FACWR=-TH/(TH+UH)
32002 FCKM=1D0
32003 FCOI=1D0
32004 ENDIF
32005 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32006 NCHN=NCHN+1
32007 ISIG(NCHN,1)=I
32008 ISIG(NCHN,2)=J
32009 ISIG(NCHN,3)=1
32010 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32011 190 CONTINUE
32012 200 CONTINUE
32013 ENDIF
32014
32015 ELSEIF(ISUB.LE.40) THEN
32016 IF(ISUB.EQ.22) THEN
32017C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32018C...Kinematics dependence
32019 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32020 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32021C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32022 DO 220 I=1,6
32023 DO 210 J=1,3
32024 HGZ(I,J)=0D0
32025 210 CONTINUE
32026 220 CONTINUE
32027 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32028 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32029 DO 230 I=1,MIN(16,MDCY(23,3))
32030 IDC=I+MDCY(23,2)-1
32031 IF(MDME(IDC,1).LT.0) GOTO 230
32032 IMDM=0
32033 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32034 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32035 IF(I.LE.8) THEN
32036 EF=KCHG(I,1)/3D0
32037 AF=SIGN(1D0,EF+0.1D0)
32038 VF=AF-4D0*EF*XWV
32039 ELSEIF(I.LE.16) THEN
32040 EF=KCHG(I+2,1)/3D0
32041 AF=SIGN(1D0,EF+0.1D0)
32042 VF=AF-4D0*EF*XWV
32043 ENDIF
32044 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32045 IF(4D0*RM1.LT.1D0) THEN
32046 FCOF=1D0
32047 IF(I.LE.8) FCOF=3D0*RADC3
32048 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32049 IF(IMDM.GE.1) THEN
32050 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32051 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32052 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32053 & AF**2*(1D0-4D0*RM1))*BE34
32054 ENDIF
32055 ENDIF
32056 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32057 IF(4D0*RM1.LT.1D0) THEN
32058 FCOF=1D0
32059 IF(I.LE.8) FCOF=3D0*RADC4
32060 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32061 IF(IMDM.GE.1) THEN
32062 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32063 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32064 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32065 & AF**2*(1D0-4D0*RM1))*BE34
32066 ENDIF
32067 ENDIF
32068 230 CONTINUE
32069C...Propagators: as simulated in PYOFSH and as desired
32070 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32071 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32072 MINT15=MINT(15)
32073 MINT(15)=1
32074 MINT(61)=1
32075 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32076 MINT(15)=MINT15
32077 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32078 DO 240 J=1,3
32079 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32080 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32081 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32082 240 CONTINUE
32083 MINT15=MINT(15)
32084 MINT(15)=1
32085 MINT(61)=1
32086 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32087 MINT(15)=MINT15
32088 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32089 DO 250 J=1,3
32090 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32091 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32092 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32093 250 CONTINUE
32094C...Loop over flavours; separate left- and right-handed couplings
32095 DO 270 I=MMINA,MMAXA
32096 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32097 EI=KCHG(IABS(I),1)/3D0
32098 AI=SIGN(1D0,EI)
32099 VI=AI-4D0*EI*XWV
32100 VALI=VI-AI
32101 VARI=VI+AI
32102 FCOI=1D0
32103 IF(IABS(I).LE.10) FCOI=FACA/3D0
32104 DO 260 J=1,3
32105 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32106 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32107 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32108 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32109 260 CONTINUE
32110 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32111 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32112 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32113 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32114 NCHN=NCHN+1
32115 ISIG(NCHN,1)=I
32116 ISIG(NCHN,2)=-I
32117 ISIG(NCHN,3)=1
32118 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32119 270 CONTINUE
32120
32121 ELSEIF(ISUB.EQ.23) THEN
32122C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32123 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32124 FACZW=FACZW*WIDS(23,2)
32125 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32126 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32127 DO 290 I=MMIN1,MMAX1
32128 IA=IABS(I)
32129 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32130 DO 280 J=MMIN2,MMAX2
32131 JA=IABS(J)
32132 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32133 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32134 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32135 & GOTO 280
32136 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32137 EI=KCHG(IA,1)/3D0
32138 AI=SIGN(1D0,EI+0.1D0)
32139 VI=AI-4D0*EI*XWV
32140 EJ=KCHG(JA,1)/3D0
32141 AJ=SIGN(1D0,EJ+0.1D0)
32142 VJ=AJ-4D0*EJ*XWV
32143 IF(VI+AI.GT.0) THEN
32144 VISAV=VI
32145 AISAV=AI
32146 VI=VJ
32147 AI=AJ
32148 VJ=VISAV
32149 AJ=AISAV
32150 ENDIF
32151 FCKM=1D0
32152 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32153 FCOI=1D0
32154 IF(IA.LE.10) FCOI=FACA/3D0
32155 NCHN=NCHN+1
32156 ISIG(NCHN,1)=I
32157 ISIG(NCHN,2)=J
32158 ISIG(NCHN,3)=1
32159 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
32160 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
32161 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
32162 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
32163 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
32164 & WIDS(24,(5-KCHW)/2)
32165C***Protect against slightly negative cross sections. (Reason yet to be
32166C***sorted out. One possibility: addition of width to the W propagator.)
32167 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
32168 280 CONTINUE
32169 290 CONTINUE
32170
32171 ELSEIF(ISUB.EQ.25) THEN
32172C...f + fbar -> W+ + W-
32173C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32174 GMMZC=GMMZ
32175 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
32176 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32177 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32178 GMMW3=SQRT(SQM3)*WDTP(0)
32179 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32180 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32181 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32182 GMMW4=SQRT(SQM4)*WDTP(0)
32183 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
32184C...Kinematical functions
32185 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32186 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
32187 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
32188 GT=THUH34+4D0*THUH/TH2
32189 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
32190 GU=THUH34+4D0*THUH/UH2
32191 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
32192C...Common factors and couplings
32193 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
32194 FACWW=FACWW*WIDS(24,1)
32195 CGG=AEM**2/2D0
32196 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
32197 CZZ=AEM**2/(32D0*XW**2)*HBWZC
32198 CNG=AEM**2/(4D0*XW)
32199 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
32200 CNN=AEM**2/(16D0*XW**2)
32201C...Coulomb factor for W+W- pair
32202 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
32203 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
32204 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
32205 IF(COULE.LT.100D0*PMAS(24,2)) THEN
32206 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32207 & PMAS(24,2)**2)-COULE))
32208 ELSE
32209 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
32210 ENDIF
32211 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
32212 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32213 & PMAS(24,2)**2)+COULE))
32214 ELSE
32215 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
32216 & ABS(COULE)))
32217 ENDIF
32218 IF(MSTP(40).EQ.1) THEN
32219 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
32220 & MAX(1D-10,2D0*COULP*COULP1))
32221 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32222 ELSEIF(MSTP(40).EQ.2) THEN
32223 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
32224 COULCP=DCMPLX(0D0,DBLE(COULP))
32225 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
32226 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
32227 & (4D0*COULCP)*LOG(COULCD)
32228 COULCS=DCMPLX(0D0,0D0)
32229 NSTP=100
32230 DO 300 ISTP=1,NSTP
32231 COULXX=(ISTP-0.5)/NSTP
32232 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
32233 & (1D0+COULXX/COULCD))
32234 300 CONTINUE
32235 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
32236 & (COULCS/NSTP)
32237 FACCOU=ABS(COULCR)**2
32238 ELSEIF(MSTP(40).EQ.3) THEN
32239 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
32240 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
32241 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32242 ENDIF
32243 ELSEIF(MSTP(40).EQ.4) THEN
32244 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
32245 ELSE
32246 FACCOU=1D0
32247 ENDIF
32248 VINT(95)=FACCOU
32249 FACWW=FACWW*FACCOU
32250C...Loop over allowed flavours
32251 DO 310 I=MMINA,MMAXA
32252 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
32253 EI=KCHG(IABS(I),1)/3D0
32254 AI=SIGN(1D0,EI+0.1D0)
32255 VI=AI-4D0*EI*XWV
32256 FCOI=1D0
32257 IF(IABS(I).LE.10) FCOI=FACA/3D0
32258 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
32259 IF(AI.LT.0D0) THEN
32260 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
32261 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
32262 ELSE
32263 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
32264 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
32265 ENDIF
32266 ELSE
32267 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
32268 BET=SQRT(1D0-4D0*XMW02/SH)
32269 GAT=1D0/SQRT(1D0-BET**2)
32270 STHE2=1D0-CTH**2
32271 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
32272 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
32273 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
32274 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
32275 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
32276 & (1D0-2D0*BET*CTH+BET**2))
32277 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
32278 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
32279 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
32280 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
32281 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
32282 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
32283 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
32284 DSIGWW=ATOT
32285 ENDIF
32286 NCHN=NCHN+1
32287 ISIG(NCHN,1)=I
32288 ISIG(NCHN,2)=-I
32289 ISIG(NCHN,3)=1
32290 SIGH(NCHN)=FACWW*FCOI*DSIGWW
32291 310 CONTINUE
32292
32293 ELSEIF(ISUB.EQ.30) THEN
32294C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
32295 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
32296 & (-SH*UH)
32297C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32298 HFGG=0D0
32299 HFGZ=0D0
32300 HFZZ=0D0
32301 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32302 DO 320 I=1,MIN(16,MDCY(23,3))
32303 IDC=I+MDCY(23,2)-1
32304 IF(MDME(IDC,1).LT.0) GOTO 320
32305 IMDM=0
32306 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32307 & IMDM=1
32308 IF(I.LE.8) THEN
32309 EF=KCHG(I,1)/3D0
32310 AF=SIGN(1D0,EF+0.1D0)
32311 VF=AF-4D0*EF*XWV
32312 ELSEIF(I.LE.16) THEN
32313 EF=KCHG(I+2,1)/3D0
32314 AF=SIGN(1D0,EF+0.1D0)
32315 VF=AF-4D0*EF*XWV
32316 ENDIF
32317 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32318 IF(4D0*RM1.LT.1D0) THEN
32319 FCOF=1D0
32320 IF(I.LE.8) FCOF=3D0*RADC4
32321 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32322 IF(IMDM.EQ.1) THEN
32323 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32324 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32325 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32326 & AF**2*(1D0-4D0*RM1))*BE34
32327 ENDIF
32328 ENDIF
32329 320 CONTINUE
32330C...Propagators: as simulated in PYOFSH and as desired
32331 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32332 MINT15=MINT(15)
32333 MINT(15)=1
32334 MINT(61)=1
32335 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32336 MINT(15)=MINT15
32337 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32338 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32339 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32340 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32341C...Loop over flavours; consider full gamma/Z structure
32342 DO 340 I=MMINA,MMAXA
32343 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
32344 EI=KCHG(IABS(I),1)/3D0
32345 AI=SIGN(1D0,EI)
32346 VI=AI-4D0*EI*XWV
32347 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
32348 & (VI**2+AI**2)*HFZZ)/HBW4
32349 DO 330 ISDE=1,2
32350 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
32351 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
32352 NCHN=NCHN+1
32353 ISIG(NCHN,ISDE)=I
32354 ISIG(NCHN,3-ISDE)=21
32355 ISIG(NCHN,3)=1
32356 SIGH(NCHN)=FACZQ
32357 330 CONTINUE
32358 340 CONTINUE
32359
32360 ELSEIF(ISUB.EQ.31) THEN
32361C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
32362 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
32363 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
32364C...Propagators: as simulated in PYOFSH and as desired
32365 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32366 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32367 GMMWC=SQRT(SQM4)*WDTP(0)
32368 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32369 FACWQ=FACWQ*HBW4C/HBW4
32370 DO 360 I=MMINA,MMAXA
32371 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
32372 IA=IABS(I)
32373 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32374 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32375 DO 350 ISDE=1,2
32376 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
32377 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
32378 NCHN=NCHN+1
32379 ISIG(NCHN,ISDE)=I
32380 ISIG(NCHN,3-ISDE)=21
32381 ISIG(NCHN,3)=1
32382 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32383 350 CONTINUE
32384 360 CONTINUE
32385
32386 ELSEIF(ISUB.EQ.35) THEN
32387C...f + gamma -> f + (gamma*/Z0)
32388 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
32389 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
32390 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
32391 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
32392 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
32393 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
32394 ELSE
32395 FZQN=SH2+UH2+2D0*SQM4*TH
32396 FZQDTM=-SH*UH
32397 ENDIF
32398 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
32399C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32400 HFGG=0D0
32401 HFGZ=0D0
32402 HFZZ=0D0
32403 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32404 DO 370 I=1,MIN(16,MDCY(23,3))
32405 IDC=I+MDCY(23,2)-1
32406 IF(MDME(IDC,1).LT.0) GOTO 370
32407 IMDM=0
32408 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32409 & IMDM=1
32410 IF(I.LE.8) THEN
32411 EF=KCHG(I,1)/3D0
32412 AF=SIGN(1D0,EF+0.1D0)
32413 VF=AF-4D0*EF*XWV
32414 ELSEIF(I.LE.16) THEN
32415 EF=KCHG(I+2,1)/3D0
32416 AF=SIGN(1D0,EF+0.1D0)
32417 VF=AF-4D0*EF*XWV
32418 ENDIF
32419 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32420 IF(4D0*RM1.LT.1D0) THEN
32421 FCOF=1D0
32422 IF(I.LE.8) FCOF=3D0*RADC4
32423 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32424 IF(IMDM.EQ.1) THEN
32425 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32426 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32427 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32428 & AF**2*(1D0-4D0*RM1))*BE34
32429 ENDIF
32430 ENDIF
32431 370 CONTINUE
32432C...Propagators: as simulated in PYOFSH and as desired
32433 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32434 MINT15=MINT(15)
32435 MINT(15)=1
32436 MINT(61)=1
32437 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32438 MINT(15)=MINT15
32439 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32440 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32441 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32442 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32443C...Loop over flavours; consider full gamma/Z structure
32444 DO 390 I=MMINA,MMAXA
32445 IF(I.EQ.0) GOTO 390
32446 EI=KCHG(IABS(I),1)/3D0
32447 AI=SIGN(1D0,EI)
32448 VI=AI-4D0*EI*XWV
32449 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32450 & (VI**2+AI**2)*HFZZ)/HBW4
32451 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
32452 DO 380 ISDE=1,2
32453 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
32454 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
32455 NCHN=NCHN+1
32456 ISIG(NCHN,ISDE)=I
32457 ISIG(NCHN,3-ISDE)=22
32458 ISIG(NCHN,3)=1
32459 SIGH(NCHN)=FACZQ*FZQN/FZQD
32460 380 CONTINUE
32461 390 CONTINUE
32462
32463 ELSEIF(ISUB.EQ.36) THEN
32464C...f + gamma -> f' + W+/-
32465 FWQ=COMFAC*AEM**2/(2D0*XW)*
32466 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
32467C...Propagators: as simulated in PYOFSH and as desired
32468 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32469 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32470 GMMWC=SQRT(SQM4)*WDTP(0)
32471 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32472 FWQ=FWQ*HBW4C/HBW4
32473 DO 410 I=MMINA,MMAXA
32474 IF(I.EQ.0) GOTO 410
32475 IA=IABS(I)
32476 EIA=ABS(KCHG(IABS(I),1)/3D0)
32477 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
32478 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32479 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32480 DO 400 ISDE=1,2
32481 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
32482 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
32483 NCHN=NCHN+1
32484 ISIG(NCHN,ISDE)=I
32485 ISIG(NCHN,3-ISDE)=22
32486 ISIG(NCHN,3)=1
32487 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32488 400 CONTINUE
32489 410 CONTINUE
32490 ENDIF
32491
32492 ELSEIF(ISUB.LE.100) THEN
32493 IF(ISUB.EQ.69) THEN
32494C...gamma + gamma -> W+ + W-
32495 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32496 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
32497 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
32498 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
32499 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
32500 NCHN=NCHN+1
32501 ISIG(NCHN,1)=22
32502 ISIG(NCHN,2)=22
32503 ISIG(NCHN,3)=1
32504 SIGH(NCHN)=FACWW
32505 420 CONTINUE
32506
32507 ELSEIF(ISUB.EQ.70) THEN
32508C...gamma + W+/- -> Z0 + W+/-
32509 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32510 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
32511 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
32512 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
32513 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
32514 DO 440 KCHW=1,-1,-2
32515 DO 430 ISDE=1,2
32516 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
32517 NCHN=NCHN+1
32518 ISIG(NCHN,ISDE)=22
32519 ISIG(NCHN,3-ISDE)=24*KCHW
32520 ISIG(NCHN,3)=1
32521 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
32522 430 CONTINUE
32523 440 CONTINUE
32524 ENDIF
32525 ENDIF
32526
32527 RETURN
32528 END
32529
32530C*********************************************************************
32531
32532C...PYSGHG
32533C...Subprocess cross sections for Higgs processes,
32534C...except Higgs pairs in PYSGSU, but including WW scattering.
32535C...Auxiliary to PYSIGH.
32536
32537 SUBROUTINE PYSGHG(NCHN,SIGS)
32538
32539C...Double precision and integer declarations
32540 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32541 IMPLICIT INTEGER(I-N)
32542 INTEGER PYK,PYCHGE,PYCOMP
32543C...Parameter statement to help give large particle numbers.
32544 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32545 &KEXCIT=4000000,KDIMEN=5000000)
32546C...Commonblocks
32547 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32548 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32549 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32550 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32551 COMMON/PYINT1/MINT(400),VINT(400)
32552 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32553 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32554 COMMON/PYINT4/MWID(500),WIDS(500,5)
32555 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32556 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32557 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32558 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32559 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32560 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32561 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
32562 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
32563C...Local arrays and complex variables
32564 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32565 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
32566 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
32567
32568C...Convert H or A process into equivalent h one
32569 IHIGG=1
32570 KFHIGG=25
32571 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
32572 KFHIGG=KFPR(ISUB,1)
32573 END IF
32574 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
32575 &ISUB.LE.190)) THEN
32576 IHIGG=2
32577 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
32578 KFHIGG=33+IHIGG
32579 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
32580 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
32581 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
32582 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
32583 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
32584 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
32585 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
32586 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
32587 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
32588 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
32589 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
32590 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
32591 ENDIF
32592 SQMH=PMAS(KFHIGG,1)**2
32593 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
32594
32595C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32596 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
32597 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
32598C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
32599 IF(MSTP(46).LE.4) THEN
32600 HDTLH=LOG(PMAS(25,1)/PARP(44))
32601 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
32602 HDTNR=-1D0/18D0+HDTLH/6D0
32603 ELSE
32604 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
32605 HDTLQ=LOG(PARP(45)/PARP(44))
32606 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
32607 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
32608 ENDIF
32609
32610C...Calculate lowest and next-to-lowest order partial wave amplitudes
32611 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
32612 A00L=DBLE(HDTV*SH)
32613 A20L=-0.5D0*A00L
32614 A11L=A00L/6D0
32615 HDTLS=LOG(SH/PARP(44)**2)
32616 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32617 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
32618 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
32619 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32620 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
32621 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
32622 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
32623 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
32624
32625C...Unitarize partial wave amplitudes with Pade or K-matrix method
32626 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
32627 A00U=A00L/(1D0-A004/A00L)
32628 A20U=A20L/(1D0-A204/A20L)
32629 A11U=A11L/(1D0-A114/A11L)
32630 ELSE
32631 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
32632 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
32633 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
32634 ENDIF
32635 ENDIF
32636
32637C...Differential cross section expressions.
32638
32639 IF(ISUB.LE.60) THEN
32640 IF(ISUB.EQ.3) THEN
32641C...f + fbar -> h0 (or H0, or A0)
32642 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32643 HS=SHR*WDTP(0)
32644 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32645 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32646 & FACBW=0D0
32647 HP=AEM/(8D0*XW)*SH/SQMW*SH
32648 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32649 DO 100 I=MMINA,MMAXA
32650 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32651 IA=IABS(I)
32652 RMQ=PYMRUN(IA,SH)**2/SH
32653 HI=HP*RMQ
32654 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
32655 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32656 IKFI=1
32657 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32658 IF(IA.GT.10) IKFI=3
32659 HI=HI*PARU(150+10*IHIGG+IKFI)**2
32660 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32661 HI=HI/(1D0+RMSS(41))**2
32662 IF(IHIGG.NE.3) THEN
32663 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32664 & PARU(151+10*IHIGG))**2
32665 ENDIF
32666 ENDIF
32667 ENDIF
32668 NCHN=NCHN+1
32669 ISIG(NCHN,1)=I
32670 ISIG(NCHN,2)=-I
32671 ISIG(NCHN,3)=1
32672 SIGH(NCHN)=HI*FACBW*HF
32673 100 CONTINUE
32674
32675 ELSEIF(ISUB.EQ.5) THEN
32676C...Z0 + Z0 -> h0
32677 CALL PYWIDT(25,SH,WDTP,WDTE)
32678 HS=SHR*WDTP(0)
32679 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32680 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32681 HP=AEM/(8D0*XW)*SH/SQMW*SH
32682 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32683 HI=HP/4D0
32684 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
32685 DO 120 I=MMIN1,MMAX1
32686 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32687 DO 110 J=MMIN2,MMAX2
32688 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32689 EI=KCHG(IABS(I),1)/3D0
32690 AI=SIGN(1D0,EI)
32691 VI=AI-4D0*EI*XWV
32692 EJ=KCHG(IABS(J),1)/3D0
32693 AJ=SIGN(1D0,EJ)
32694 VJ=AJ-4D0*EJ*XWV
32695 NCHN=NCHN+1
32696 ISIG(NCHN,1)=I
32697 ISIG(NCHN,2)=J
32698 ISIG(NCHN,3)=1
32699 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
32700 110 CONTINUE
32701 120 CONTINUE
32702
32703 ELSEIF(ISUB.EQ.8) THEN
32704C...W+ + W- -> h0
32705 CALL PYWIDT(25,SH,WDTP,WDTE)
32706 HS=SHR*WDTP(0)
32707 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32708 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32709 HP=AEM/(8D0*XW)*SH/SQMW*SH
32710 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32711 HI=HP/2D0
32712 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
32713 DO 140 I=MMIN1,MMAX1
32714 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
32715 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32716 DO 130 J=MMIN2,MMAX2
32717 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
32718 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32719 IF(EI*EJ.GT.0D0) GOTO 130
32720 NCHN=NCHN+1
32721 ISIG(NCHN,1)=I
32722 ISIG(NCHN,2)=J
32723 ISIG(NCHN,3)=1
32724 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
32725 130 CONTINUE
32726 140 CONTINUE
32727
32728 ELSEIF(ISUB.EQ.24) THEN
32729C...f + fbar -> Z0 + h0 (or H0, or A0)
32730C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
32731 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32732 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32733 GMMZ3=SQRT(SQM3)*WDTP(0)
32734 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
32735 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32736 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32737 GMMH4=SQRT(SQM4)*WDTP(0)
32738 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32739 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32740 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
32741 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
32742 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
32743 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
32744 & PARU(154+10*IHIGG)**2
32745 DO 150 I=MMINA,MMAXA
32746 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
32747 EI=KCHG(IABS(I),1)/3D0
32748 AI=SIGN(1D0,EI)
32749 VI=AI-4D0*EI*XWV
32750 FCOI=1D0
32751 IF(IABS(I).LE.10) FCOI=FACA/3D0
32752 NCHN=NCHN+1
32753 ISIG(NCHN,1)=I
32754 ISIG(NCHN,2)=-I
32755 ISIG(NCHN,3)=1
32756 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
32757 150 CONTINUE
32758
32759 ELSEIF(ISUB.EQ.26) THEN
32760C...f + fbar' -> W+/- + h0 (or H0, or A0)
32761C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
32762 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32763 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32764 GMMW3=SQRT(SQM3)*WDTP(0)
32765 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32766 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32767 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32768 GMMH4=SQRT(SQM4)*WDTP(0)
32769 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32770 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32771 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
32772 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
32773 FACHW=FACHW*WIDS(KFHIGG,2)
32774 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
32775 & PARU(155+10*IHIGG)**2
32776 DO 170 I=MMIN1,MMAX1
32777 IA=IABS(I)
32778 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
32779 DO 160 J=MMIN2,MMAX2
32780 JA=IABS(J)
32781 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
32782 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
32783 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32784 & GOTO 160
32785 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32786 FCKM=1D0
32787 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32788 FCOI=1D0
32789 IF(IA.LE.10) FCOI=FACA/3D0
32790 NCHN=NCHN+1
32791 ISIG(NCHN,1)=I
32792 ISIG(NCHN,2)=J
32793 ISIG(NCHN,3)=1
32794 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
32795 160 CONTINUE
32796 170 CONTINUE
32797
32798 ELSEIF(ISUB.EQ.32) THEN
32799C...f + g -> f + h0 (q + g -> q + h0 only)
32800 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
32801C...H propagator: as simulated in PYOFSH and as desired
32802 SQMHC=PMAS(25,1)**2
32803 GMMHC=PMAS(25,1)*PMAS(25,2)
32804 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32805 CALL PYWIDT(25,SQM4,WDTP,WDTE)
32806 GMMHCC=SQRT(SQM4)*WDTP(0)
32807 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32808 FHCQ=FHCQ*HBW4C/HBW4
32809 DO 190 I=MMINA,MMAXA
32810 IA=IABS(I)
32811 IF(IA.NE.5) GOTO 190
32812 SQML=PYMRUN(IA,SH)**2
32813 SQMQ=PMAS(IA,1)**2
32814 FACHCQ=FHCQ*SQML/SQMW*
32815 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32816 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
32817 & (SQM4-SQMQ-SH)/SH)
32818 DO 180 ISDE=1,2
32819 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
32820 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
32821 NCHN=NCHN+1
32822 ISIG(NCHN,ISDE)=I
32823 ISIG(NCHN,3-ISDE)=21
32824 ISIG(NCHN,3)=1
32825 SIGH(NCHN)=FACHCQ*WIDS(25,2)
32826 180 CONTINUE
32827 190 CONTINUE
32828 ENDIF
32829
32830 ELSEIF(ISUB.LE.80) THEN
32831 IF(ISUB.EQ.71) THEN
32832C...Z0 + Z0 -> Z0 + Z0
32833 IF(SH.LE.4.01D0*SQMZ) GOTO 220
32834
32835 IF(MSTP(46).LE.2) THEN
32836C...Exact scattering ME:s for on-mass-shell gauge bosons
32837 BE2=1D0-4D0*SQMZ/SH
32838 TH=-0.5D0*SH*BE2*(1D0-CTH)
32839 UH=-0.5D0*SH*BE2*(1D0+CTH)
32840 IF(MAX(TH,UH).GT.-1D0) GOTO 220
32841 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
32842 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32843 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32844 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
32845 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32846 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32847 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
32848 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32849 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32850 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32851 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32852 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32853 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
32854 & (ASHIM+ATHIM+AUHIM)**2)
32855 IF(MSTP(46).EQ.2) FACZZ=0D0
32856
32857 ELSE
32858C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32859 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32860 & ABS(A00U+2D0*A20U)**2
32861 ENDIF
32862 FACZZ=FACZZ*WIDS(23,1)
32863
32864 DO 210 I=MMIN1,MMAX1
32865 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
32866 EI=KCHG(IABS(I),1)/3D0
32867 AI=SIGN(1D0,EI)
32868 VI=AI-4D0*EI*XWV
32869 AVI=AI**2+VI**2
32870 DO 200 J=MMIN2,MMAX2
32871 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
32872 EJ=KCHG(IABS(J),1)/3D0
32873 AJ=SIGN(1D0,EJ)
32874 VJ=AJ-4D0*EJ*XWV
32875 AVJ=AJ**2+VJ**2
32876 NCHN=NCHN+1
32877 ISIG(NCHN,1)=I
32878 ISIG(NCHN,2)=J
32879 ISIG(NCHN,3)=1
32880 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
32881 200 CONTINUE
32882 210 CONTINUE
32883 220 CONTINUE
32884
32885 ELSEIF(ISUB.EQ.72) THEN
32886C...Z0 + Z0 -> W+ + W-
32887 IF(SH.LE.4.01D0*SQMZ) GOTO 250
32888
32889 IF(MSTP(46).LE.2) THEN
32890C...Exact scattering ME:s for on-mass-shell gauge bosons
32891 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32892 CTH2=CTH**2
32893 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32894 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32895 IF(MAX(TH,UH).GT.-1D0) GOTO 250
32896 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32897 & (1D0-2D0*SQMZ/SH)
32898 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32899 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32900 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32901 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32902 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32903 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32904 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32905 ATWIM=0D0
32906 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32907 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32908 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32909 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32910 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32911 AUWIM=0D0
32912 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32913 A4IM=0D0
32914 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32915 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32916 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
32917 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32918 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32919 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
32920 & (ATWIM+AUWIM+A4IM)**2)
32921
32922 ELSE
32923C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32924 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32925 & ABS(A00U-A20U)**2
32926 ENDIF
32927 FACWW=FACWW*WIDS(24,1)
32928
32929 DO 240 I=MMIN1,MMAX1
32930 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32931 EI=KCHG(IABS(I),1)/3D0
32932 AI=SIGN(1D0,EI)
32933 VI=AI-4D0*EI*XWV
32934 AVI=AI**2+VI**2
32935 DO 230 J=MMIN2,MMAX2
32936 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32937 EJ=KCHG(IABS(J),1)/3D0
32938 AJ=SIGN(1D0,EJ)
32939 VJ=AJ-4D0*EJ*XWV
32940 AVJ=AJ**2+VJ**2
32941 NCHN=NCHN+1
32942 ISIG(NCHN,1)=I
32943 ISIG(NCHN,2)=J
32944 ISIG(NCHN,3)=1
32945 SIGH(NCHN)=FACWW*AVI*AVJ
32946 230 CONTINUE
32947 240 CONTINUE
32948 250 CONTINUE
32949
32950 ELSEIF(ISUB.EQ.73) THEN
32951C...Z0 + W+/- -> Z0 + W+/-
32952 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32953
32954 IF(MSTP(46).LE.2) THEN
32955C...Exact scattering ME:s for on-mass-shell gauge bosons
32956 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32957 EP1=1D0-(SQMZ-SQMW)/SH
32958 EP2=1D0+(SQMZ-SQMW)/SH
32959 TH=-0.5D0*SH*BE2*(1D0-CTH)
32960 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32961 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32962 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32963 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32964 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32965 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32966 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32967 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32968 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32969 ASWIM=0D0
32970 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32971 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32972 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32973 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32974 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32975 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32976 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32977 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32978 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32979 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32980 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32981 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32982 AUWIM=0D0
32983 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32984 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32985 A4IM=0D0
32986 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32987 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32988 IF(MSTP(46).LE.0) FACZW=0D0
32989 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32990 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32991 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32992 & (ASWIM+AUWIM+A4IM)**2)
32993
32994 ELSE
32995C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32996 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32997 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32998 ENDIF
32999 FACZW=FACZW*WIDS(23,2)
33000
33001 DO 270 I=MMIN1,MMAX1
33002 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33003 EI=KCHG(IABS(I),1)/3D0
33004 AI=SIGN(1D0,EI)
33005 VI=AI-4D0*EI*XWV
33006 AVI=AI**2+VI**2
33007 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33008 DO 260 J=MMIN2,MMAX2
33009 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33010 EJ=KCHG(IABS(J),1)/3D0
33011 AJ=SIGN(1D0,EJ)
33012 VJ=AI-4D0*EJ*XWV
33013 AVJ=AJ**2+VJ**2
33014 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33015 NCHN=NCHN+1
33016 ISIG(NCHN,1)=I
33017 ISIG(NCHN,2)=J
33018 ISIG(NCHN,3)=1
33019 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33020 NCHN=NCHN+1
33021 ISIG(NCHN,1)=I
33022 ISIG(NCHN,2)=J
33023 ISIG(NCHN,3)=2
33024 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33025 260 CONTINUE
33026 270 CONTINUE
33027 280 CONTINUE
33028
33029 ELSEIF(ISUB.EQ.75) THEN
33030C...W+ + W- -> gamma + gamma
33031
33032 ELSEIF(ISUB.EQ.76) THEN
33033C...W+ + W- -> Z0 + Z0
33034 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33035
33036 IF(MSTP(46).LE.2) THEN
33037C...Exact scattering ME:s for on-mass-shell gauge bosons
33038 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33039 CTH2=CTH**2
33040 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33041 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33042 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33043 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33044 & (1D0-2D0*SQMZ/SH)
33045 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33046 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33047 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33048 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33049 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33050 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33051 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33052 ATWIM=0D0
33053 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33054 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33055 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33056 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33057 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33058 AUWIM=0D0
33059 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33060 A4IM=0D0
33061 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33062 & (SH/SQMW)**2*SH2
33063 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33064 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33065 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33066 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33067 & (ATWIM+AUWIM+A4IM)**2)
33068
33069 ELSE
33070C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33071 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33072 & ABS(A00U-A20U)**2
33073 ENDIF
33074 FACZZ=FACZZ*WIDS(23,1)
33075
33076 DO 300 I=MMIN1,MMAX1
33077 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33078 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33079 DO 290 J=MMIN2,MMAX2
33080 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33081 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33082 IF(EI*EJ.GT.0D0) GOTO 290
33083 NCHN=NCHN+1
33084 ISIG(NCHN,1)=I
33085 ISIG(NCHN,2)=J
33086 ISIG(NCHN,3)=1
33087 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33088 290 CONTINUE
33089 300 CONTINUE
33090 310 CONTINUE
33091
33092 ELSEIF(ISUB.EQ.77) THEN
33093C...W+/- + W+/- -> W+/- + W+/-
33094 IF(SH.LE.4.01D0*SQMW) GOTO 340
33095
33096 IF(MSTP(46).LE.2) THEN
33097C...Exact scattering ME:s for on-mass-shell gauge bosons
33098 BE2=1D0-4D0*SQMW/SH
33099 BE4=BE2**2
33100 CTH2=CTH**2
33101 CTH3=CTH**3
33102 TH=-0.5D0*SH*BE2*(1D0-CTH)
33103 UH=-0.5D0*SH*BE2*(1D0+CTH)
33104 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33105 SHANG=(1D0+BE2)**2
33106 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33107 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33108 THANG=(BE2-CTH)**2
33109 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33110 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33111 UHANG=(BE2+CTH)**2
33112 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33113 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33114 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33115 ASGRE=XW*SGZANG
33116 ASGIM=0D0
33117 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33118 ASZIM=0D0
33119 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33120 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33121 ATGRE=0.5D0*XW*SH/TH*TGZANG
33122 ATGIM=0D0
33123 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33124 ATZIM=0D0
33125 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33126 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33127 AUGRE=0.5D0*XW*SH/UH*UGZANG
33128 AUGIM=0D0
33129 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33130 AUZIM=0D0
33131 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33132 A4AIM=0D0
33133 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33134 A4SIM=0D0
33135 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33136 & (SH/SQMW)**2*SH2
33137 IF(MSTP(46).LE.0) THEN
33138 AWWARE=ASHRE
33139 AWWAIM=ASHIM
33140 AWWSRE=0D0
33141 AWWSIM=0D0
33142 ELSEIF(MSTP(46).EQ.1) THEN
33143 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33144 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33145 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33146 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33147 ELSE
33148 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33149 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33150 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33151 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33152 ENDIF
33153 AWWA2=AWWARE**2+AWWAIM**2
33154 AWWS2=AWWSRE**2+AWWSIM**2
33155
33156 ELSE
33157C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33158 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33159 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
33160 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
33161 ENDIF
33162
33163 DO 330 I=MMIN1,MMAX1
33164 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
33165 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33166 DO 320 J=MMIN2,MMAX2
33167 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
33168 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33169 IF(EI*EJ.LT.0D0) THEN
33170C...W+W-
33171 IF(MSTP(45).EQ.1) GOTO 320
33172 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
33173 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
33174 ELSE
33175C...W+W+/W-W-
33176 IF(MSTP(45).EQ.2) GOTO 320
33177 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
33178 IF(MSTP(46).GE.3) FACWW=FWWS
33179 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
33180 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
33181 ENDIF
33182 NCHN=NCHN+1
33183 ISIG(NCHN,1)=I
33184 ISIG(NCHN,2)=J
33185 ISIG(NCHN,3)=1
33186 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
33187 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
33188 320 CONTINUE
33189 330 CONTINUE
33190 340 CONTINUE
33191 ENDIF
33192
33193 ELSEIF(ISUB.LE.120) THEN
33194 IF(ISUB.EQ.102) THEN
33195C...g + g -> h0 (or H0, or A0)
33196 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33197 WDTP13=0D0
33198 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33199 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33200 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33201 345 CONTINUE
33202 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33203 & '(PYSGHG:) did not find Higgs -> g g channel')
33204 HS=SHR*WDTP(0)
33205 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33206 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33207 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33208 & FACBW=0D0
33209 HI=SHR*WDTP13/32D0
33210 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
33211 NCHN=NCHN+1
33212 ISIG(NCHN,1)=21
33213 ISIG(NCHN,2)=21
33214 ISIG(NCHN,3)=1
33215 SIGH(NCHN)=HI*FACBW*HF
33216 350 CONTINUE
33217
33218 ELSEIF(ISUB.EQ.103) THEN
33219C...gamma + gamma -> h0 (or H0, or A0)
33220 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33221 WDTP14=0D0
33222 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33223 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
33224 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
33225 355 CONTINUE
33226 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
33227 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33228 HS=SHR*WDTP(0)
33229 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33230 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33231 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33232 & FACBW=0D0
33233 HI=SHR*WDTP14*2D0
33234 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
33235 NCHN=NCHN+1
33236 ISIG(NCHN,1)=22
33237 ISIG(NCHN,2)=22
33238 ISIG(NCHN,3)=1
33239 SIGH(NCHN)=HI*FACBW*HF
33240 360 CONTINUE
33241
33242 ELSEIF(ISUB.EQ.110) THEN
33243C...f + fbar -> gamma + h0
33244 THUH=MAX(TH*UH,SH*CKIN(3)**2)
33245 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
33246 FACHG=FACHG*WIDS(KFHIGG,2)
33247C...Calculate loop contributions for intermediate gamma* and Z0
33248 CIGTOT=DCMPLX(0D0,0D0)
33249 CIZTOT=DCMPLX(0D0,0D0)
33250 JMAX=3*MSTP(1)+1
33251 DO 370 J=1,JMAX
33252 IF(J.LE.2*MSTP(1)) THEN
33253 FNC=1D0
33254 EJ=KCHG(J,1)/3D0
33255 AJ=SIGN(1D0,EJ+0.1D0)
33256 VJ=AJ-4D0*EJ*XWV
33257 BALP=SQM4/(2D0*PMAS(J,1))**2
33258 BBET=SH/(2D0*PMAS(J,1))**2
33259 ELSEIF(J.LE.3*MSTP(1)) THEN
33260 FNC=3D0
33261 JL=2*(J-2*MSTP(1))-1
33262 EJ=KCHG(10+JL,1)/3D0
33263 AJ=SIGN(1D0,EJ+0.1D0)
33264 VJ=AJ-4D0*EJ*XWV
33265 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
33266 BBET=SH/(2D0*PMAS(10+JL,1))**2
33267 ELSE
33268 BALP=SQM4/(2D0*PMAS(24,1))**2
33269 BBET=SH/(2D0*PMAS(24,1))**2
33270 ENDIF
33271 BABI=1D0/(BALP-BBET)
33272 IF(BALP.LT.1D0) THEN
33273 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
33274 F1ALP=F0ALP**2
33275 ELSE
33276 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
33277 & -DBLE(0.5D0*PARU(1)))
33278 F1ALP=-F0ALP**2
33279 ENDIF
33280 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
33281 IF(BBET.LT.1D0) THEN
33282 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
33283 F1BET=F0BET**2
33284 ELSE
33285 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
33286 & -DBLE(0.5D0*PARU(1)))
33287 F1BET=-F0BET**2
33288 ENDIF
33289 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
33290 IF(J.LE.3*MSTP(1)) THEN
33291 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
33292 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
33293 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
33294 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
33295 ELSE
33296 TXW=XW/XW1
33297 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
33298 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
33299 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
33300 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
33301 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
33302 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
33303 & (F1BET-F1ALP))
33304 ENDIF
33305 370 CONTINUE
33306 CIGTOT=CIGTOT/DBLE(SH)
33307 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
33308C...Loop over initial flavours
33309 DO 380 I=MMINA,MMAXA
33310 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
33311 EI=KCHG(IABS(I),1)/3D0
33312 AI=SIGN(1D0,EI)
33313 VI=AI-4D0*EI*XWV
33314 FCOI=1D0
33315 IF(IABS(I).LE.10) FCOI=FACA/3D0
33316 NCHN=NCHN+1
33317 ISIG(NCHN,1)=I
33318 ISIG(NCHN,2)=-I
33319 ISIG(NCHN,3)=1
33320 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
33321 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
33322 380 CONTINUE
33323
33324 ELSEIF(ISUB.EQ.111) THEN
33325C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
33326 IF(MSTP(38).NE.0) THEN
33327C...Simple case: only do gg <-> h exactly.
33328 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33329 WDTP13=0D0
33330 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33331 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33332 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33333 385 CONTINUE
33334 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33335 & '(PYSGHG:) did not find Higgs -> g g channel')
33336 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
33337 & (TH**2+UH**2)/(SH*SQM4)
33338C...Propagators: as simulated in PYOFSH and as desired
33339 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33340 GMMHC=SQRT(SQM4)*WDTP(0)
33341 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33342 & ((SQM4-SQMH)**2+GMMHC**2)
33343 FACGH=FACGH*HBW4C/HBW4
33344 ELSE
33345C...Messy case: do full loop integrals
33346 A5STUR=0D0
33347 A5STUI=0D0
33348 DO 390 I=1,2*MSTP(1)
33349 SQMQ=PMAS(I,1)**2
33350 EPSS=4D0*SQMQ/SH
33351 EPSH=4D0*SQMQ/SQMH
33352 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33353 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33354 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33355 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33356 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
33357 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
33358 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
33359 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
33360 390 CONTINUE
33361 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33362 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
33363 FACGH=FACGH*WIDS(25,2)
33364 ENDIF
33365 DO 400 I=MMINA,MMAXA
33366 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33367 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33368 NCHN=NCHN+1
33369 ISIG(NCHN,1)=I
33370 ISIG(NCHN,2)=-I
33371 ISIG(NCHN,3)=1
33372 SIGH(NCHN)=FACGH
33373 400 CONTINUE
33374
33375 ELSEIF(ISUB.EQ.112) THEN
33376C...f + g -> f + h0 (q + g -> q + h0 only)
33377 IF(MSTP(38).NE.0) THEN
33378C...Simple case: only do gg <-> h exactly.
33379 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33380 WDTP13=0D0
33381 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33382 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33383 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33384 405 CONTINUE
33385 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33386 & '(PYSGHG:) did not find Higgs -> g g channel')
33387 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
33388 & (SH**2+UH**2)/(-TH*SQM4)
33389C...Propagators: as simulated in PYOFSH and as desired
33390 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33391 GMMHC=SQRT(SQM4)*WDTP(0)
33392 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33393 & ((SQM4-SQMH)**2+GMMHC**2)
33394 FACQH=FACQH*HBW4C/HBW4
33395 ELSE
33396C...Messy case: do full loop integrals
33397 A5TSUR=0D0
33398 A5TSUI=0D0
33399 DO 410 I=1,2*MSTP(1)
33400 SQMQ=PMAS(I,1)**2
33401 EPST=4D0*SQMQ/TH
33402 EPSH=4D0*SQMQ/SQMH
33403 CALL PYWAUX(1,EPST,W1TR,W1TI)
33404 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33405 CALL PYWAUX(2,EPST,W2TR,W2TI)
33406 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33407 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
33408 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
33409 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
33410 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
33411 410 CONTINUE
33412 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33413 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
33414 FACQH=FACQH*WIDS(25,2)
33415 ENDIF
33416 DO 430 I=MMINA,MMAXA
33417 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
33418 DO 420 ISDE=1,2
33419 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
33420 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
33421 NCHN=NCHN+1
33422 ISIG(NCHN,ISDE)=I
33423 ISIG(NCHN,3-ISDE)=21
33424 ISIG(NCHN,3)=1
33425 SIGH(NCHN)=FACQH
33426 420 CONTINUE
33427 430 CONTINUE
33428
33429 ELSEIF(ISUB.EQ.113) THEN
33430C...g + g -> g + h0
33431 IF(MSTP(38).NE.0) THEN
33432C...Simple case: only do gg <-> h exactly.
33433 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33434 WDTP13=0D0
33435 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33436 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33437 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33438 435 CONTINUE
33439 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33440 & '(PYSGHG:) did not find Higgs -> g g channel')
33441 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
33442 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
33443C...Propagators: as simulated in PYOFSH and as desired
33444 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33445 GMMHC=SQRT(SQM4)*WDTP(0)
33446 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33447 & ((SQM4-SQMH)**2+GMMHC**2)
33448 FACGH=FACGH*HBW4C/HBW4
33449 ELSE
33450C...Messy case: do full loop integrals
33451 A2STUR=0D0
33452 A2STUI=0D0
33453 A2USTR=0D0
33454 A2USTI=0D0
33455 A2TUSR=0D0
33456 A2TUSI=0D0
33457 A4STUR=0D0
33458 A4STUI=0D0
33459 DO 440 I=1,2*MSTP(1)
33460 SQMQ=PMAS(I,1)**2
33461 EPSS=4D0*SQMQ/SH
33462 EPST=4D0*SQMQ/TH
33463 EPSU=4D0*SQMQ/UH
33464 EPSH=4D0*SQMQ/SQMH
33465 IF(EPSH.LT.1D-6) GOTO 440
33466 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33467 CALL PYWAUX(1,EPST,W1TR,W1TI)
33468 CALL PYWAUX(1,EPSU,W1UR,W1UI)
33469 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33470 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33471 CALL PYWAUX(2,EPST,W2TR,W2TI)
33472 CALL PYWAUX(2,EPSU,W2UR,W2UI)
33473 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33474 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
33475 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
33476 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
33477 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
33478 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
33479 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
33480 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
33481 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
33482 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
33483 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
33484 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
33485 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
33486 W3STUR=YHSTUR-Y3STUR-Y3UTSR
33487 W3STUI=YHSTUI-Y3STUI-Y3UTSI
33488 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
33489 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
33490 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
33491 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
33492 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
33493 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
33494 W3USTR=YHUSTR-Y3USTR-Y3TSUR
33495 W3USTI=YHUSTI-Y3USTI-Y3TSUI
33496 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
33497 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
33498 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
33499 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
33500 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
33501 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
33502 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
33503 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
33504 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
33505 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
33506 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
33507 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
33508 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
33509 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
33510 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
33511 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
33512 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
33513 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
33514 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
33515 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
33516 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
33517 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
33518 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
33519 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
33520 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
33521 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
33522 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
33523 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
33524 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
33525 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
33526 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
33527 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
33528 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
33529 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
33530 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
33531 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
33532 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
33533 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
33534 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
33535 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
33536 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
33537 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
33538 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
33539 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
33540 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
33541 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
33542 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
33543 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
33544 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
33545 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
33546 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
33547 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
33548 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
33549 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
33550 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
33551 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
33552 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
33553 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
33554 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
33555 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
33556 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
33557 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
33558 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33559 & (W2SR-W2HR+W3STUR))
33560 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
33561 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33562 & (W2TR-W2HR+W3TUSR))
33563 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
33564 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33565 & (W2UR-W2HR+W3USTR))
33566 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
33567 A2STUR=A2STUR+B2STUR+B2SUTR
33568 A2STUI=A2STUI+B2STUI+B2SUTI
33569 A2USTR=A2USTR+B2USTR+B2UTSR
33570 A2USTI=A2USTI+B2USTI+B2UTSI
33571 A2TUSR=A2TUSR+B2TUSR+B2TSUR
33572 A2TUSI=A2TUSI+B2TUSI+B2TSUI
33573 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
33574 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
33575 440 CONTINUE
33576 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
33577 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
33578 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
33579 FACGH=FACGH*WIDS(25,2)
33580 ENDIF
33581 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
33582 NCHN=NCHN+1
33583 ISIG(NCHN,1)=21
33584 ISIG(NCHN,2)=21
33585 ISIG(NCHN,3)=1
33586 SIGH(NCHN)=FACGH
33587 450 CONTINUE
33588 ENDIF
33589
33590 ELSEIF(ISUB.LE.170) THEN
33591 IF(ISUB.EQ.121) THEN
33592C...g + g -> Q + Qbar + h0
33593 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
33594 IA=KFPR(ISUBSV,2)
33595 PMF=PYMRUN(IA,SH)
33596 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33597 & (0.5D0*PMF/PMAS(24,1))**2
33598 WID2=1D0
33599 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33600 FACQQH=FACQQH*WID2
33601 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33602 IKFI=1
33603 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33604 IF(IA.GT.10) IKFI=3
33605 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33606 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33607 FACQQH=FACQQH/(1D0+RMSS(41))**2
33608 IF(IHIGG.NE.3) THEN
33609 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33610 & PARU(151+10*IHIGG))**2
33611 ENDIF
33612 ENDIF
33613 ENDIF
33614 CALL PYQQBH(WTQQBH)
33615 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33616 HS=SHR*WDTP(0)
33617 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33618 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33619 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33620 & FACBW=0D0
33621 NCHN=NCHN+1
33622 ISIG(NCHN,1)=21
33623 ISIG(NCHN,2)=21
33624 ISIG(NCHN,3)=1
33625 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33626 460 CONTINUE
33627
33628 ELSEIF(ISUB.EQ.122) THEN
33629C...q + qbar -> Q + Qbar + h0
33630 IA=KFPR(ISUBSV,2)
33631 PMF=PYMRUN(IA,SH)
33632 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33633 & (0.5D0*PMF/PMAS(24,1))**2
33634 WID2=1D0
33635 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33636 FACQQH=FACQQH*WID2
33637 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33638 IKFI=1
33639 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33640 IF(IA.GT.10) IKFI=3
33641 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33642 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33643 FACQQH=FACQQH/(1D0+RMSS(41))**2
33644 IF(IHIGG.NE.3) THEN
33645 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33646 & PARU(151+10*IHIGG))**2
33647 ENDIF
33648 ENDIF
33649 ENDIF
33650 CALL PYQQBH(WTQQBH)
33651 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33652 HS=SHR*WDTP(0)
33653 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33654 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33655 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33656 & FACBW=0D0
33657 DO 470 I=MMINA,MMAXA
33658 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33659 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
33660 NCHN=NCHN+1
33661 ISIG(NCHN,1)=I
33662 ISIG(NCHN,2)=-I
33663 ISIG(NCHN,3)=1
33664 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33665 470 CONTINUE
33666
33667 ELSEIF(ISUB.EQ.123) THEN
33668C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
33669C...inner process)
33670 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
33671 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33672 & PARU(154+10*IHIGG)**2
33673 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33674 & (VINT(216)-VINT(209)**2))**2
33675 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33676 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
33677 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33678 HS=SHR*WDTP(0)
33679 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33680 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33681 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33682 & FACBW=0D0
33683 DO 490 I=MMIN1,MMAX1
33684 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
33685 IA=IABS(I)
33686 DO 480 J=MMIN2,MMAX2
33687 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
33688 JA=IABS(J)
33689 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
33690 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
33691 VI=AI-4D0*EI*XWV
33692 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
33693 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
33694 VJ=AJ-4D0*EJ*XWV
33695 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
33696 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
33697 NCHN=NCHN+1
33698 ISIG(NCHN,1)=I
33699 ISIG(NCHN,2)=J
33700 ISIG(NCHN,3)=1
33701 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
33702 480 CONTINUE
33703 490 CONTINUE
33704
33705 ELSEIF(ISUB.EQ.124) THEN
33706C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
33707C...inner process)
33708 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
33709 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33710 & PARU(155+10*IHIGG)**2
33711 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33712 & (VINT(216)-VINT(209)**2))**2
33713 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33714 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33715 HS=SHR*WDTP(0)
33716 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33717 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33718 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33719 & FACBW=0D0
33720 DO 510 I=MMIN1,MMAX1
33721 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
33722 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33723 DO 500 J=MMIN2,MMAX2
33724 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
33725 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33726 IF(EI*EJ.GT.0D0) GOTO 500
33727 FACLR=VINT(180+I)*VINT(180+J)
33728 NCHN=NCHN+1
33729 ISIG(NCHN,1)=I
33730 ISIG(NCHN,2)=J
33731 ISIG(NCHN,3)=1
33732 SIGH(NCHN)=FACLR*FACWW*FACBW
33733 500 CONTINUE
33734 510 CONTINUE
33735
33736 ELSEIF(ISUB.EQ.143) THEN
33737C...f + fbar' -> H+/-
33738 SQMHC=PMAS(37,1)**2
33739 CALL PYWIDT(37,SH,WDTP,WDTE)
33740 HS=SHR*WDTP(0)
33741 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
33742 HP=AEM/(8D0*XW)*SH/SQMW*SH
33743 DO 530 I=MMIN1,MMAX1
33744 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
33745 IA=IABS(I)
33746 IM=(MOD(IA,10)+1)/2
33747 DO 520 J=MMIN2,MMAX2
33748 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
33749 JA=IABS(J)
33750 JM=(MOD(JA,10)+1)/2
33751 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
33752 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33753 & GOTO 520
33754 IF(MOD(IA,2).EQ.0) THEN
33755 IU=IA
33756 IL=JA
33757 ELSE
33758 IU=JA
33759 IL=IA
33760 ENDIF
33761 RML=PYMRUN(IL,SH)**2/SH
33762 RMU=PYMRUN(IU,SH)**2/SH
33763 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
33764 IF(IA.LE.10) HI=HI*FACA/3D0
33765 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33766 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
33767 NCHN=NCHN+1
33768 ISIG(NCHN,1)=I
33769 ISIG(NCHN,2)=J
33770 ISIG(NCHN,3)=1
33771 SIGH(NCHN)=HI*FACBW*HF
33772 520 CONTINUE
33773 530 CONTINUE
33774
33775 ELSEIF(ISUB.EQ.161) THEN
33776C...f + g -> f' + H+/- (b + g -> t + H+/- only)
33777C...(choice of only b and t to avoid kinematics problems)
33778 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
33779C...H propagator: as simulated in PYOFSH and as desired
33780 SQMHC=PMAS(37,1)**2
33781 GMMHC=PMAS(37,1)*PMAS(37,2)
33782 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33783 CALL PYWIDT(37,SQM4,WDTP,WDTE)
33784 GMMHCC=SQRT(SQM4)*WDTP(0)
33785 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33786 FHCQ=FHCQ*HBW4C/HBW4
33787 Q2RM=SH
33788 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
33789 DO 550 I=MMINA,MMAXA
33790 IA=IABS(I)
33791 IF(IA.NE.5) GOTO 550
33792 SQML=PYMRUN(IA,Q2RM)**2
33793 IUA=IA+MOD(IA,2)
33794 SQMQ=PYMRUN(IUA,Q2RM)**2
33795 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
33796 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33797 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
33798 & (SQMHC-SQMQ-SH)/SH)
33799 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33800 DO 540 ISDE=1,2
33801 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
33802 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
33803 NCHN=NCHN+1
33804 ISIG(NCHN,ISDE)=I
33805 ISIG(NCHN,3-ISDE)=21
33806 ISIG(NCHN,3)=1
33807 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
33808 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
33809 540 CONTINUE
33810 550 CONTINUE
33811 ENDIF
33812
33813 ELSEIF(ISUB.LE.402) THEN
33814 IF(ISUB.EQ.401) THEN
33815C... g + g -> t + bbar + H-
33816 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
33817 IA=KFPR(ISUBSV,2)
33818 CALL PYSTBH(WTTBH)
33819 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33820 HS=SHR*WDTP(0)
33821 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33822 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33823 & FACBW=0D0
33824 NCHN=NCHN+1
33825 ISIG(NCHN,1)=21
33826 ISIG(NCHN,2)=21
33827 ISIG(NCHN,3)=1
33828 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33829c Since we don't know yet if H+ or H-, assume H+
33830c when calculating suppression due to closed channels.
33831 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33832 IF(ABS(WIDS(37,2)-WIDS(37,3))
33833 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
33834 & ABS(WIDS(6,2)-WIDS(6,3))
33835 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
33836 WRITE(*,*)'Error: Process 401 cannot handle different'
33837 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33838 WRITE(*,*)'Execution stopped.'
33839 CALL PYSTOP(108)
33840 END IF
33841 560 CONTINUE
33842
33843 ELSEIF(ISUB.EQ.402) THEN
33844C... q + qbar -> t + bbar + H-
33845 IA=KFPR(ISUBSV,2)
33846 CALL PYSTBH(WTTBH)
33847 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33848 HS=SHR*WDTP(0)
33849 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33850 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33851 & FACBW=0D0
33852 DO 570 I=MMINA,MMAXA
33853 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33854 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
33855 NCHN=NCHN+1
33856 ISIG(NCHN,1)=I
33857 ISIG(NCHN,2)=-I
33858 ISIG(NCHN,3)=1
33859 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33860c Since we don't know yet if H+ or H-, assume H+
33861c when calculating suppression due to closed channels.
33862 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33863 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
33864 & .GE.1D-6.OR.
33865 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
33866 & .GE.1D-6) THEN
33867 WRITE(*,*)'Error: Process 402 cannot handle different'
33868 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33869 WRITE(*,*)'Execution stopped.'
33870 CALL PYSTOP(108)
33871 END IF
33872 570 CONTINUE
33873 ENDIF
33874 ENDIF
33875
33876 RETURN
33877 END
33878
33879C*********************************************************************
33880
33881C...PYSGSU
33882C...Subprocess cross sections for SUSY processes,
33883C...including Higgs pair production.
33884C...Auxiliary to PYSIGH.
33885
33886 SUBROUTINE PYSGSU(NCHN,SIGS)
33887
33888C...Double precision and integer declarations
33889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33890 IMPLICIT INTEGER(I-N)
33891 INTEGER PYK,PYCHGE,PYCOMP
33892C...Parameter statement to help give large particle numbers.
33893 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33894 &KEXCIT=4000000,KDIMEN=5000000)
33895C...Commonblocks
33896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33897 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33898 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33899 COMMON/PYINT1/MINT(400),VINT(400)
33900 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33901 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33902 COMMON/PYINT4/MWID(500),WIDS(500,5)
33903 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33904 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33905 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33906 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33907 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33908 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33909 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33910 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
33911 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
33912C...Local arrays and complex variables
33913 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33914 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
33915 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
33916 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
33917
33918CMRENNA++
33919C...Z and W width, combinations of weak mixing angle
33920 ZWID=PMAS(23,2)
33921 WWID=PMAS(24,2)
33922 TANW=SQRT(XW/XW1)
33923 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33924
33925C...Convert almost equivalent SUSY processes into each other
33926C...Extract differences in flavours and couplings
33927
33928C...Sleptons and sneutrinos
33929 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33930 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33931 ISUB=201
33932 ILR=0
33933 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33934 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33935 ISUB=201
33936 ILR=1
33937 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33938 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33939 ISUB=203
33940 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33941 IF(ISUB.EQ.210) THEN
33942 RKF=2.0D0
33943 ELSEIF(ISUB.EQ.211) THEN
33944 RKF=SFMIX(15,1)**2
33945 ELSEIF(ISUB.EQ.212) THEN
33946 RKF=SFMIX(15,2)**2
33947 ENDIF
33948 ISUB=210
33949 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33950 IF(ISUB.EQ.213) THEN
33951 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33952 RKF=2.0D0
33953 ELSEIF(ISUB.EQ.214) THEN
33954 KFID=16
33955 RKF=1.0D0
33956 ENDIF
33957 ISUB=213
33958
33959C...Neutralinos
33960 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33961 IF(ISUB.EQ.216) THEN
33962 IZID1=1
33963 IZID2=1
33964 ELSEIF(ISUB.EQ.217) THEN
33965 IZID1=2
33966 IZID2=2
33967 ELSEIF(ISUB.EQ.218) THEN
33968 IZID1=3
33969 IZID2=3
33970 ELSEIF(ISUB.EQ.219) THEN
33971 IZID1=4
33972 IZID2=4
33973 ELSEIF(ISUB.EQ.220) THEN
33974 IZID1=1
33975 IZID2=2
33976 ELSEIF(ISUB.EQ.221) THEN
33977 IZID1=1
33978 IZID2=3
33979 ELSEIF(ISUB.EQ.222) THEN
33980 IZID1=1
33981 IZID2=4
33982 ELSEIF(ISUB.EQ.223) THEN
33983 IZID1=2
33984 IZID2=3
33985 ELSEIF(ISUB.EQ.224) THEN
33986 IZID1=2
33987 IZID2=4
33988 ELSEIF(ISUB.EQ.225) THEN
33989 IZID1=3
33990 IZID2=4
33991 ENDIF
33992 ISUB=216
33993
33994C...Charginos
33995 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33996 IF(ISUB.EQ.226) THEN
33997 IZID1=1
33998 IZID2=1
33999 ELSEIF(ISUB.EQ.227) THEN
34000 IZID1=2
34001 IZID2=2
34002 ELSEIF(ISUB.EQ.228) THEN
34003 IZID1=1
34004 IZID2=2
34005 ENDIF
34006 ISUB=226
34007
34008C...Neutralino + chargino
34009 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34010 IF(ISUB.EQ.229) THEN
34011 IZID1=1
34012 IZID2=1
34013 ELSEIF(ISUB.EQ.230) THEN
34014 IZID1=1
34015 IZID2=2
34016 ELSEIF(ISUB.EQ.231) THEN
34017 IZID1=1
34018 IZID2=3
34019 ELSEIF(ISUB.EQ.232) THEN
34020 IZID1=1
34021 IZID2=4
34022 ELSEIF(ISUB.EQ.233) THEN
34023 IZID1=2
34024 IZID2=1
34025 ELSEIF(ISUB.EQ.234) THEN
34026 IZID1=2
34027 IZID2=2
34028 ELSEIF(ISUB.EQ.235) THEN
34029 IZID1=2
34030 IZID2=3
34031 ELSEIF(ISUB.EQ.236) THEN
34032 IZID1=2
34033 IZID2=4
34034 ENDIF
34035 ISUB=229
34036
34037C...Gluino + neutralino
34038 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34039 IF(ISUB.EQ.237) THEN
34040 IZID=1
34041 ELSEIF(ISUB.EQ.238) THEN
34042 IZID=2
34043 ELSEIF(ISUB.EQ.239) THEN
34044 IZID=3
34045 ELSEIF(ISUB.EQ.240) THEN
34046 IZID=4
34047 ENDIF
34048 ISUB=237
34049
34050C...Gluino + chargino
34051 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34052 IF(ISUB.EQ.241) THEN
34053 IZID=1
34054 ELSEIF(ISUB.EQ.242) THEN
34055 IZID=2
34056 ENDIF
34057 ISUB=241
34058
34059C...Squark + neutralino
34060 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34061 ILR=0
34062 IF(MOD(ISUB,2).NE.0) ILR=1
34063 IF(ISUB.LE.247) THEN
34064 IZID=1
34065 ELSEIF(ISUB.LE.249) THEN
34066 IZID=2
34067 ELSEIF(ISUB.LE.251) THEN
34068 IZID=3
34069 ELSEIF(ISUB.LE.253) THEN
34070 IZID=4
34071 ENDIF
34072 ISUB=246
34073 RKF=5D0
34074
34075C...Squark + chargino
34076 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34077 IF(ISUB.LE.255) THEN
34078 IZID=1
34079 ELSEIF(ISUB.LE.257) THEN
34080 IZID=2
34081 ENDIF
34082 IF(MOD(ISUB,2).EQ.0) THEN
34083 ILR=0
34084 ELSE
34085 ILR=1
34086 ENDIF
34087 ISUB=254
34088 RKF=5D0
34089
34090C...Squark + gluino
34091 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34092 ISUB=258
34093 RKF=4D0
34094
34095C...Stops
34096 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34097 ILR=0
34098 IF(ISUB.EQ.262) ILR=1
34099 ISUB=261
34100 ELSEIF(ISUB.EQ.265) THEN
34101 ISUB=264
34102
34103C...Squarks
34104 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34105 ILR=0
34106 IF(ISUB.LE.273) THEN
34107 IF(ISUB.EQ.273) ILR=1
34108 ISUB=271
34109 RKF=16D0
34110 ELSEIF(ISUB.LE.276) THEN
34111 IF(ISUB.EQ.276) ILR=1
34112 ISUB=274
34113 RKF=16D0
34114 ELSEIF(ISUB.LE.278) THEN
34115 IF(ISUB.EQ.278) ILR=1
34116 ISUB=277
34117 RKF=4D0
34118 ELSE
34119 IF(ISUB.EQ.280) ILR=1
34120 ISUB=279
34121 RKF=4D0
34122 ENDIF
34123C...Sbottoms
34124 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
34125 ILR=0
34126 IF(ISUB.LE.283) THEN
34127 IF(ISUB.EQ.283) ILR=1
34128 ISUB=271
34129 RKF=4D0
34130 ELSEIF(ISUB.LE.286) THEN
34131 IF(ISUB.EQ.286) ILR=1
34132 ISUB=274
34133 RKF=4D0
34134 ELSEIF(ISUB.LE.288) THEN
34135 IF(ISUB.EQ.288) ILR=1
34136 ISUB=277
34137 RKF=1D0
34138 ELSEIF(ISUB.LE.290) THEN
34139 IF(ISUB.EQ.290) ILR=1
34140 ISUB=279
34141 RKF=1D0
34142 ELSEIF(ISUB.LE.293) THEN
34143 IF(ISUB.EQ.293) ILR=1
34144 ISUB=271
34145 RKF=1D0
34146 ELSEIF(ISUB.EQ.296) THEN
34147 ILR=1
34148 ISUB=274
34149 RKF=1D0
34150C...Squark + gluino
34151 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
34152 ISUB=258
34153 RKF=1D0
34154 ENDIF
34155C...H+/- + H0
34156 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
34157 IF(ISUB.EQ.297) THEN
34158 RKF=.5D0*PARU(195)**2
34159 ELSEIF(ISUB.EQ.298) THEN
34160 RKF=.5D0*(1D0-PARU(195)**2)
34161 ENDIF
34162 ISUB=210
34163C...A0 + H0
34164 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
34165 IF(ISUB.EQ.299) THEN
34166 RKF=PARU(186)**2
34167 KFID=25
34168 ELSEIF(ISUB.EQ.300) THEN
34169 RKF=PARU(187)**2
34170 KFID=35
34171 ENDIF
34172 ISUB=213
34173C...H+ + H-
34174 ELSEIF(ISUB.EQ.301) THEN
34175 KFID=37
34176 RKF=1D0
34177 ISUB=201
34178 ENDIF
34179
34180C...Supersymmetric processes - all of type 2 -> 2 :
34181C...correct final-state Breit-Wigners from fixed to running width.
34182 IF(MSTP(42).GT.0) THEN
34183 DO 100 I=1,2
34184 KFLW=KFPR(ISUBSV,I)
34185 KCW=PYCOMP(KFLW)
34186 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
34187 IF(I.EQ.1) SQMI=SQM3
34188 IF(I.EQ.2) SQMI=SQM4
34189 SQMS=PMAS(KCW,1)**2
34190 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
34191 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
34192 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
34193 GMMI=SQRT(SQMI)*WDTP(0)
34194 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
34195 COMFAC=COMFAC*(HBWI/HBWS)
34196 100 CONTINUE
34197 ENDIF
34198
34199C...Differential cross section expressions.
34200
34201 IF(ISUB.LE.210) THEN
34202 IF(ISUB.EQ.201) THEN
34203C...f + fbar -> e_L + e_Lbar
34204 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34205 DO 130 I=MMIN1,MMAX1
34206 IA=IABS(I)
34207 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
34208 EI=KCHG(IA,1)/3D0
34209 TT3I=SIGN(1D0,EI+1D-6)/2D0
34210 EJ=-1D0
34211 TT3J=-1D0/2D0
34212 FCOL=1D0
34213C...Color factor for e+ e-
34214 IF(IA.GE.11) FCOL=3D0
34215 IF(ISUBSV.EQ.301) THEN
34216 A1=1D0
34217 A2=0D0
34218 ELSEIF(ILR.EQ.1) THEN
34219 A1=SFMIX(KFID,3)**2
34220 A2=SFMIX(KFID,4)**2
34221 ELSEIF(ILR.EQ.0) THEN
34222 A1=SFMIX(KFID,1)**2
34223 A2=SFMIX(KFID,2)**2
34224 ENDIF
34225 XLQ=(TT3J-EJ*XW)*A1
34226 XRQ=(-EJ*XW)*A2
34227 XLF=(TT3I-EI*XW)
34228 XRF=(-EI*XW)
34229 TAA=(EI*EJ)**2*(POLL+POLR)
34230 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
34231 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
34232 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
34233 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34234 TNN=0.0D0
34235 TAN=0.0D0
34236 TZN=0.0D0
34237 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34238 FAC2=SQRT(2D0)
34239 TNN1=0D0
34240 TNN2=0D0
34241 TNN3=0D0
34242 DO 120 II=1,4
34243 DK=1D0/(TH-SMZ(II)**2)
34244 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34245 & ZMIX(II,1))
34246 FREK=FAC2*TANW*EI*ZMIX(II,1)
34247 TNN1=TNN1+FLEK**2*DK
34248 TNN2=TNN2+FREK**2*DK
34249 DO 110 JJ=1,4
34250 DL=1D0/(TH-SMZ(JJ)**2)
34251 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34252 & ZMIX(JJ,1))
34253 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34254 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34255 110 CONTINUE
34256 120 CONTINUE
34257 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
34258 & A2**2*TNN2**2*POLR)
34259 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
34260 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
34261 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
34262 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
34263 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34264 & (1D0-SQMZ/SH)/SH
34265 TZN=TZN/XW**2/XW1
34266 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
34267 & A2*TNN2*POLR)/XW
34268 ENDIF
34269 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
34270 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
34271 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
34272 NCHN=NCHN+1
34273 ISIG(NCHN,1)=I
34274 ISIG(NCHN,2)=-I
34275 ISIG(NCHN,3)=1
34276 SIGH(NCHN)=FACQQ1+FACQQ2
34277 130 CONTINUE
34278
34279 ELSEIF(ISUB.EQ.203) THEN
34280C...f + fbar -> e_L + e_Rbar
34281 DO 160 I=MMIN1,MMAX1
34282 IA=IABS(I)
34283 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
34284 EI=KCHG(IABS(I),1)/3D0
34285 TT3I=SIGN(1D0,EI)/2D0
34286 EJ=-1
34287 TT3J=-1D0/2D0
34288 FCOL=1D0
34289C...Color factor for e+ e-
34290 IF(IA.GE.11) FCOL=3D0
34291 A1=SFMIX(KFID,1)**2
34292 A2=SFMIX(KFID,2)**2
34293 XLQ=(TT3J-EJ*XW)
34294 XRQ=(-EJ*XW)
34295 XLF=(TT3I-EI*XW)
34296 XRF=(-EI*XW)
34297 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
34298 & /XW**2/XW1**2*A1*A2
34299 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34300 TNN=0.0D0
34301 TZN=0.0D0
34302 TNNA=0D0
34303 TNNB=0D0
34304 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34305 FAC2=SQRT(2D0)
34306 TNN1=0D0
34307 TNN2=0D0
34308 TNN3=0D0
34309 DO 150 II=1,4
34310 DK=1D0/(TH-SMZ(II)**2)
34311 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34312 & ZMIX(II,1))
34313 FREK=FAC2*TANW*EI*ZMIX(II,1)
34314 TNN1=TNN1+FLEK**2*DK
34315 TNN2=TNN2+FREK**2*DK
34316 DO 140 JJ=1,4
34317 DL=1D0/(TH-SMZ(JJ)**2)
34318 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34319 & ZMIX(JJ,1))
34320 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34321 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34322 140 CONTINUE
34323 150 CONTINUE
34324 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
34325 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
34326 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
34327 TZN=(UH*TH-SQM3*SQM4)*A1*A2
34328 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
34329 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34330 & (1D0-SQMZ/SH)/SH
34331 ENDIF
34332 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
34333 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
34334 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
34335C%%%%%%%%%%%
34336 NCHN=NCHN+1
34337 ISIG(NCHN,1)=I
34338 ISIG(NCHN,2)=-I
34339 ISIG(NCHN,3)=1
34340 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34341 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34342 NCHN=NCHN+1
34343 ISIG(NCHN,1)=I
34344 ISIG(NCHN,2)=-I
34345 ISIG(NCHN,3)=2
34346 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34347 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34348 160 CONTINUE
34349
34350 ELSEIF(ISUB.EQ.210) THEN
34351C...q + qbar' -> W*- > ~l_L + ~nu_L
34352 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
34353 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
34354 DO 180 I=MMIN1,MMAX1
34355 IA=IABS(I)
34356 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
34357 DO 170 J=MMIN2,MMAX2
34358 JA=IABS(J)
34359 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
34360 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
34361 FCKM=3D0
34362 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34363 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34364 KCHW=2
34365 IF(KCHSUM.LT.0) KCHW=3
34366 NCHN=NCHN+1
34367 ISIG(NCHN,1)=I
34368 ISIG(NCHN,2)=J
34369 ISIG(NCHN,3)=1
34370 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
34371 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34372 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34373 ELSE
34374 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34375 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34376 ENDIF
34377 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
34378 170 CONTINUE
34379 180 CONTINUE
34380 ENDIF
34381
34382 ELSEIF(ISUB.LE.220) THEN
34383 IF(ISUB.EQ.213) THEN
34384C...f + fbar -> ~nu_L + ~nu_Lbar
34385 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
34386 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34387 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34388 ELSE
34389 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34390 ENDIF
34391 COMFAC=COMFAC*FACR
34392 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
34393 XLL=0.5D0
34394 XLR=0.0D0
34395 DO 190 I=MMIN1,MMAX1
34396 IA=IABS(I)
34397 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
34398 EI=KCHG(IA,1)/3D0
34399 FCOL=1D0
34400C...Color factor for e+ e-
34401 IF(IA.GE.11) FCOL=3D0
34402 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
34403 XRQ=-EI*XW
34404 TZC=0.0D0
34405 TCC=0.0D0
34406 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
34407 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
34408 & (TH-SMW(2)**2)
34409 TCC=TZC**2
34410 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
34411 ENDIF
34412 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
34413 FACQQ2=TZC+TCC/4D0
34414 NCHN=NCHN+1
34415 ISIG(NCHN,1)=I
34416 ISIG(NCHN,2)=-I
34417 ISIG(NCHN,3)=1
34418 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
34419 & *AEM**2*FCOL/3D0/XW**2
34420 190 CONTINUE
34421
34422 ELSEIF(ISUB.EQ.216) THEN
34423C...q + qbar -> ~chi0_1 + ~chi0_1
34424 IF(IZID1.EQ.IZID2) THEN
34425 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34426 ELSE
34427 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34428 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34429 ENDIF
34430 FACXX=COMFAC*AEM**2/3D0/XW**2
34431 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
34432 ZM12=SQM3
34433 ZM22=SQM4
34434 WU2 = (UH-ZM12)*(UH-ZM22)
34435 WT2 = (TH-ZM12)*(TH-ZM22)
34436 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
34437 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34438 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34439 DO 200 I=1,4
34440 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
34441 IF(IZID2.NE.IZID1) THEN
34442 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34443 ENDIF
34444 200 CONTINUE
34445 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
34446 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
34447 ORPP=DCONJG(OLPP)
34448 DO 210 I=MMINA,MMAXA
34449 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
34450 EI=KCHG(IABS(I),1)/3D0
34451 T3I=SIGN(1D0,EI+1D-6)/2D0
34452 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
34453 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
34454 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
34455 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
34456 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
34457 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
34458 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
34459 & /DCMPLX(TH-XML2)
34460 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
34461 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
34462 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
34463 FCOL=1D0
34464 IF(IABS(I).GE.11) FCOL=3D0
34465 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34466 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34467 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34468 & QRL*DCONJG(QRR)*POLR)*WS2
34469 NCHN=NCHN+1
34470 ISIG(NCHN,1)=I
34471 ISIG(NCHN,2)=-I
34472 ISIG(NCHN,3)=1
34473 SIGH(NCHN)=FACXX*FACGG1*FCOL
34474 210 CONTINUE
34475 ENDIF
34476
34477 ELSEIF(ISUB.LE.230) THEN
34478 IF(ISUB.EQ.226) THEN
34479C...f + fbar -> ~chi+_1 + ~chi-_1
34480 FACXX=COMFAC*AEM**2/3D0
34481 ZM12=SQM3
34482 ZM22=SQM4
34483 WU2 = (UH-ZM12)*(UH-ZM22)
34484 WT2 = (TH-ZM12)*(TH-ZM22)
34485 WS2 = SMW(IZID1)*SMW(IZID2)*SH
34486 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34487 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34488 DIFF=0D0
34489 IF(IZID1.EQ.IZID2) DIFF=1D0
34490 DO 220 I=1,2
34491 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34492 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34493 IF(IZID2.NE.IZID1) THEN
34494 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
34495 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
34496 ENDIF
34497 220 CONTINUE
34498 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
34499 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
34500 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
34501 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
34502 DO 230 I=MMINA,MMAXA
34503 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
34504 EI=KCHG(IABS(I),1)/3D0
34505 T3I=SIGN(1D0,EI+1D-6)/2D0
34506 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
34507 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
34508 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
34509 IF(MOD(I,2).EQ.0) THEN
34510 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
34511 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34512 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
34513 & DCMPLX(T3I/XW/(TH-XML2))
34514 ELSE
34515 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
34516 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34517 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
34518 & DCMPLX(T3I/XW/(TH-XML2))
34519 ENDIF
34520 FCOL=1D0
34521 IF(IABS(I).GE.11) FCOL=3D0
34522 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34523 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34524 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34525 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
34526 NCHN=NCHN+1
34527 ISIG(NCHN,1)=I
34528 ISIG(NCHN,2)=-I
34529 ISIG(NCHN,3)=1
34530 IF(IZID1.EQ.IZID2) THEN
34531 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34532 ELSE
34533 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34534 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34535 NCHN=NCHN+1
34536 ISIG(NCHN,1)=I
34537 ISIG(NCHN,2)=-I
34538 ISIG(NCHN,3)=2
34539 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34540 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34541 ENDIF
34542 230 CONTINUE
34543
34544 ELSEIF(ISUB.EQ.229) THEN
34545C...q + qbar' -> ~chi0_1 + ~chi+-_1
34546 FACXX=COMFAC*AEM**2/6D0/XW**2
34547 ZM12=SQM3
34548 ZM22=SQM4
34549 WU2 = (UH-ZM12)*(UH-ZM22)
34550 WT2 = (TH-ZM12)*(TH-ZM22)
34551 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
34552 RT2I = 1D0/SQRT(2D0)
34553 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
34554 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
34555 DO 240 I=1,2
34556 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34557 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34558 240 CONTINUE
34559 DO 250 I=1,4
34560 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34561 250 CONTINUE
34562 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
34563 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
34564 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
34565 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
34566
34567 DO 270 I=MMIN1,MMAX1
34568 IA=IABS(I)
34569 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
34570 EI=KCHG(IA,1)/3D0
34571 T3I=SIGN(1D0,EI+1D-6)/2D0
34572 DO 260 J=MMIN2,MMAX2
34573 JA=IABS(J)
34574 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
34575 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
34576 EJ=KCHG(JA,1)/3D0
34577 T3J=SIGN(1D0,EJ+1D-6)/2D0
34578 FCKM=3D0
34579 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34580 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34581 KCHW=2
34582 IF(KCHSUM.LT.0) KCHW=3
34583 IF(MOD(IA,2).EQ.0) THEN
34584 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34585 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34586 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
34587 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
34588 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34589 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
34590 & /DCMPLX(TH-ZMJ2)
34591 ELSE
34592 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34593 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34594 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
34595 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
34596 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34597 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
34598 & /DCMPLX(TH-ZMI2)
34599 ENDIF
34600 ZINTR=DBLE(QLR*DCONJG(QLL))
34601 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
34602 & 2D0*ZINTR*WS2)
34603 NCHN=NCHN+1
34604 ISIG(NCHN,1)=I
34605 ISIG(NCHN,2)=J
34606 ISIG(NCHN,3)=1
34607 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34608 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34609 260 CONTINUE
34610 270 CONTINUE
34611 ENDIF
34612
34613 ELSEIF(ISUB.LE.240) THEN
34614 IF(ISUB.EQ.237) THEN
34615C...q + qbar -> gluino + ~chi0_1
34616 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34617 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34618 ASYUK=RMSS(42)*AS
34619 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
34620 GM2=SQM3
34621 ZM2=SQM4
34622 DO 280 I=MMINA,MMAXA
34623 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
34624 EI=KCHG(IABS(I),1)/3D0
34625 IA=IABS(I)
34626 XLQC = -TANW*EI*ZMIX(IZID,1)
34627 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34628 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34629 XLQ2=XLQC**2
34630 XRQ2=XRQC**2
34631 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
34632 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
34633 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
34634 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
34635 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
34636 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34637 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
34638 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
34639 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
34640 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34641 NCHN=NCHN+1
34642 ISIG(NCHN,1)=I
34643 ISIG(NCHN,2)=-I
34644 ISIG(NCHN,3)=1
34645 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
34646 280 CONTINUE
34647 ENDIF
34648
34649 ELSEIF(ISUB.LE.250) THEN
34650 IF(ISUB.EQ.241) THEN
34651C...q + qbar' -> ~chi+-_1 + gluino
34652 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
34653 GM2=SQM3
34654 ZM2=SQM4
34655 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
34656 FAC0=UMIX(IZID,1)**2
34657 FAC1=VMIX(IZID,1)**2
34658 DO 300 I=MMIN1,MMAX1
34659 IA=IABS(I)
34660 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
34661 DO 290 J=MMIN2,MMAX2
34662 JA=IABS(J)
34663 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
34664 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
34665 FCKM=1D0
34666 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34667 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34668 KCHW=2
34669 IF(KCHSUM.LT.0) KCHW=3
34670 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
34671 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
34672 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
34673 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
34674 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
34675 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
34676 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
34677 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
34678 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
34679 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
34680 & SH/(TH-XMU2)/(UH-XMD2))/2D0
34681 NCHN=NCHN+1
34682 ISIG(NCHN,1)=I
34683 ISIG(NCHN,2)=J
34684 ISIG(NCHN,3)=1
34685 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
34686 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34687 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34688 290 CONTINUE
34689 300 CONTINUE
34690
34691 ELSEIF(ISUB.EQ.243) THEN
34692C...q + qbar -> gluino + gluino
34693 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34694 XMT=SQM3-TH
34695 XMU=SQM3-UH
34696 DO 310 I=MMINA,MMAXA
34697 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34698 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
34699 NCHN=NCHN+1
34700 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
34701 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
34702 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34703 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34704 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34705 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34706 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
34707 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
34708 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34709 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34710 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34711 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34712 ISIG(NCHN,1)=I
34713 ISIG(NCHN,2)=-I
34714 ISIG(NCHN,3)=1
34715C...1/2 for identical particles
34716 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
34717 310 CONTINUE
34718
34719 ELSEIF(ISUB.EQ.244) THEN
34720C...g + g -> gluino + gluino
34721 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34722 XMT=SQM3-TH
34723 XMU=SQM3-UH
34724 FACQQ1=COMFAC*AS**2*9D0/4D0*(
34725 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
34726 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
34727 FACQQ2=COMFAC*AS**2*9D0/4D0*(
34728 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
34729 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
34730 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
34731 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
34732 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
34733 NCHN=NCHN+1
34734 ISIG(NCHN,1)=21
34735 ISIG(NCHN,2)=21
34736 ISIG(NCHN,3)=1
34737 SIGH(NCHN)=FACQQ1/2D0
34738 NCHN=NCHN+1
34739 ISIG(NCHN,1)=21
34740 ISIG(NCHN,2)=21
34741 ISIG(NCHN,3)=2
34742 SIGH(NCHN)=FACQQ2/2D0
34743 NCHN=NCHN+1
34744 ISIG(NCHN,1)=21
34745 ISIG(NCHN,2)=21
34746 ISIG(NCHN,3)=3
34747 SIGH(NCHN)=FACQQ3/2D0
34748 320 CONTINUE
34749
34750 ELSEIF(ISUB.EQ.246) THEN
34751C...g + q_j -> ~chi0_1 + ~q_j
34752 FAC0=COMFAC*AS*AEM/6D0/XW
34753 ZM2=SQM4
34754 QM2=SQM3
34755 FACZQ0=FAC0*( (ZM2-TH)/SH +
34756 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34757 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34758 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34759 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
34760 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
34761 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
34762 EI=KCHG(IABS(I),1)/3D0
34763 IA=IABS(I)
34764 XRQZ = -TANW*EI*ZMIX(IZID,1)
34765 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34766 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34767 IF(ILR.EQ.0) THEN
34768 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
34769 ELSE
34770 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
34771 ENDIF
34772 FACZQ=FACZQ0*BS
34773 KCHQ=2
34774 IF(I.LT.0) KCHQ=3
34775 DO 330 ISDE=1,2
34776 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
34777 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
34778 NCHN=NCHN+1
34779 ISIG(NCHN,ISDE)=I
34780 ISIG(NCHN,3-ISDE)=21
34781 ISIG(NCHN,3)=1
34782 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34783 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34784 330 CONTINUE
34785 340 CONTINUE
34786 ENDIF
34787
34788 ELSEIF(ISUB.LE.260) THEN
34789 IF(ISUB.EQ.254) THEN
34790C...g + q_j -> ~chi1_1 + ~q_i
34791 FAC0=COMFAC*AS*AEM/12D0/XW
34792 ZM2=SQM4
34793 QM2=SQM3
34794 AU=UMIX(IZID,1)**2
34795 AD=VMIX(IZID,1)**2
34796 FACZQ0=FAC0*( (ZM2-TH)/SH +
34797 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34798 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34799 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
34800 IF(MOD(KFNSQ1,2).EQ.0) THEN
34801 KFNSQ=KFNSQ1-1
34802 KCHW=2
34803 ELSE
34804 KFNSQ=KFNSQ1+1
34805 KCHW=3
34806 ENDIF
34807 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
34808 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
34809 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
34810 IA=IABS(I)
34811 IF(MOD(IA,2).EQ.0) THEN
34812 FACZQ=FACZQ0*AU
34813 ELSE
34814 FACZQ=FACZQ0*AD
34815 ENDIF
34816 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
34817 KCHQ=2
34818 IF(I.LT.0) KCHQ=3
34819 KCHWQ=KCHW
34820 IF(I.LT.0) KCHWQ=5-KCHW
34821 DO 350 ISDE=1,2
34822 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
34823 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
34824 NCHN=NCHN+1
34825 ISIG(NCHN,ISDE)=I
34826 ISIG(NCHN,3-ISDE)=21
34827 ISIG(NCHN,3)=1
34828 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34829 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
34830 350 CONTINUE
34831 360 CONTINUE
34832
34833 ELSEIF(ISUB.EQ.258) THEN
34834C...g + q_j -> gluino + ~q_i
34835 XG2=SQM4
34836 XQ2=SQM3
34837 XMT=XG2-TH
34838 XMU=XG2-UH
34839 XST=XQ2-TH
34840 XSU=XQ2-UH
34841 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
34842 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
34843 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
34844 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
34845 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
34846 & (SH*(UH+XG2)
34847 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
34848 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
34849 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
34850 ASYUK=RMSS(42)*AS
34851 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
34852 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
34853 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34854 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
34855 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
34856 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
34857 KCHQ=2
34858 IF(I.LT.0) KCHQ=3
34859 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34860 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34861 DO 370 ISDE=1,2
34862 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
34863 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
34864 NCHN=NCHN+1
34865 ISIG(NCHN,ISDE)=I
34866 ISIG(NCHN,3-ISDE)=21
34867 ISIG(NCHN,3)=1
34868 SIGH(NCHN)=FACQG1*FACSEL
34869 NCHN=NCHN+1
34870 ISIG(NCHN,ISDE)=I
34871 ISIG(NCHN,3-ISDE)=21
34872 ISIG(NCHN,3)=2
34873 SIGH(NCHN)=FACQG2*FACSEL
34874 370 CONTINUE
34875 380 CONTINUE
34876 ENDIF
34877
34878 ELSEIF(ISUB.LE.270) THEN
34879 IF(ISUB.EQ.261) THEN
34880C...q_i + q_ibar -> ~t_1 + ~t_1bar
34881 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
34882 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34883 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34884 FAC0=AS**2*4D0/9D0
34885 DO 390 I=MMIN1,MMAX1
34886 IA=IABS(I)
34887 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
34888 IF(IA.GE.11.AND.IA.LE.18) THEN
34889 EI=KCHG(IA,1)/3D0
34890 EJ=KCHG(KFNSQ,1)/3D0
34891 T3I=SIGN(1D0,EI)/2D0
34892 T3J=SIGN(1D0,EJ)/2D0
34893 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
34894 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
34895 XLF=2D0*(T3I-EI*XW)
34896 XRF=2D0*(-EI*XW)
34897 TAA=0.5D0*(EI*EJ)**2
34898 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34899 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34900 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34901 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34902 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34903 ENDIF
34904 NCHN=NCHN+1
34905 ISIG(NCHN,1)=I
34906 ISIG(NCHN,2)=-I
34907 ISIG(NCHN,3)=1
34908 SIGH(NCHN)=FACQQ1*FAC0
34909 390 CONTINUE
34910
34911 ELSEIF(ISUB.EQ.263) THEN
34912C...f + fbar -> ~t1 + ~t2bar
34913 DO 400 I=MMIN1,MMAX1
34914 IA=IABS(I)
34915 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34916 EI=KCHG(IABS(I),1)/3D0
34917 TT3I=SIGN(1D0,EI)/2D0
34918 EJ=2D0/3D0
34919 TT3J=1D0/2D0
34920 FCOL=1D0
34921C...Color factor for e+ e-
34922 IF(IA.GE.11) FCOL=3D0
34923 XLQ=2D0*(TT3J-EJ*XW)
34924 XRQ=2D0*(-EJ*XW)
34925 XLF=2D0*(TT3I-EI*XW)
34926 XRF=2D0*(-EI*XW)
34927 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34928 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34929 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34930C...Factor of 2 for t1 t2bar + t2 t1bar
34931 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34932 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34933 NCHN=NCHN+1
34934 ISIG(NCHN,1)=I
34935 ISIG(NCHN,2)=-I
34936 ISIG(NCHN,3)=1
34937 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34938 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34939 NCHN=NCHN+1
34940 ISIG(NCHN,1)=I
34941 ISIG(NCHN,2)=-I
34942 ISIG(NCHN,3)=2
34943 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34944 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34945 400 CONTINUE
34946
34947 ELSEIF(ISUB.EQ.264) THEN
34948C...g + g -> ~t_1 + ~t_1bar
34949 XSU=SQM3-UH
34950 XST=SQM3-TH
34951 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34952 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34953 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34954 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34955 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34956 NCHN=NCHN+1
34957 ISIG(NCHN,1)=21
34958 ISIG(NCHN,2)=21
34959 ISIG(NCHN,3)=1
34960 SIGH(NCHN)=FACQQ1
34961 NCHN=NCHN+1
34962 ISIG(NCHN,1)=21
34963 ISIG(NCHN,2)=21
34964 ISIG(NCHN,3)=2
34965 SIGH(NCHN)=FACQQ2
34966 410 CONTINUE
34967 ENDIF
34968
34969 ELSEIF(ISUB.LE.280) THEN
34970 IF(ISUB.EQ.271) THEN
34971C...q + q' -> ~q + ~q' (~g exchange)
34972 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34973 XMT=XMG2-TH
34974 XMU=XMG2-UH
34975 XSU1=SQM3-UH
34976 XSU2=SQM4-UH
34977 XST1=SQM3-TH
34978 XST2=SQM4-TH
34979 ASYUK=RMSS(42)*AS
34980 IF(ILR.EQ.1) THEN
34981 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34982 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34983 FACQQB=0.0D0
34984 ELSE
34985 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34986 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34987 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34988 & XMT/XMU )
34989 ENDIF
34990 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34991 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34992 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34993 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34994 IA=IABS(I)
34995 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34996 KCHQ=2
34997 IF(I.LT.0) KCHQ=3
34998 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34999 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35000 JA=IABS(J)
35001 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35002 IF(I*J.LT.0) GOTO 420
35003 NCHN=NCHN+1
35004 ISIG(NCHN,1)=I
35005 ISIG(NCHN,2)=J
35006 ISIG(NCHN,3)=1
35007 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35008 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35009 IF(I.EQ.J) THEN
35010 IF(ILR.EQ.0) THEN
35011 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35012 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35013 ELSE
35014 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35015 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35016 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35017 ENDIF
35018 NCHN=NCHN+1
35019 ISIG(NCHN,1)=I
35020 ISIG(NCHN,2)=J
35021 ISIG(NCHN,3)=2
35022 IF(ILR.EQ.0) THEN
35023 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35024 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35025 ELSE
35026 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35027 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35028 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35029 ENDIF
35030 ENDIF
35031 420 CONTINUE
35032 430 CONTINUE
35033
35034 ELSEIF(ISUB.EQ.274) THEN
35035C...q + qbar' -> ~q + ~qbar'
35036 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35037 XMT=XMG2-TH
35038 XMU=XMG2-UH
35039 IF(ILR.EQ.0) THEN
35040C...Mrenna...Normalization.and.1/XMT
35041 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35042 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35043 FACQQB=COMFAC*AS**2*4D0/9D0*(
35044 & (UH*TH-SQM3*SQM4)/SH2 )
35045 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35046 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35047 FACQQB=FACQQB+FACQQ1+FACQQI
35048 ELSE
35049 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35050 FACQQB=FACQQ1
35051 ENDIF
35052 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35053 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35054 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35055 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35056 IA=IABS(I)
35057 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35058 KCHQ=2
35059 IF(I.LT.0) KCHQ=3
35060 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35061 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35062 JA=IABS(J)
35063 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35064 IF(I*J.GT.0) GOTO 440
35065 NCHN=NCHN+1
35066 ISIG(NCHN,1)=I
35067 ISIG(NCHN,2)=J
35068 ISIG(NCHN,3)=1
35069 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35070 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35071 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35072 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35073 440 CONTINUE
35074 450 CONTINUE
35075
35076 ELSEIF(ISUB.EQ.277) THEN
35077C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35078C...if i .eq. j covered in 274
35079 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35080 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35081 FAC0=0D0
35082 DO 460 I=MMIN1,MMAX1
35083 IA=IABS(I)
35084 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35085 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35086 IF(IA.EQ.KFNSQ) GOTO 460
35087 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35088 EI=KCHG(IA,1)/3D0
35089 EJ=KCHG(KFNSQ,1)/3D0
35090 T3J=SIGN(0.5D0,EJ)
35091 T3I=SIGN(1D0,EI)/2D0
35092 IF(ILR.EQ.0) THEN
35093 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35094 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35095 ELSE
35096 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35097 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35098 ENDIF
35099 XLF=2D0*(T3I-EI*XW)
35100 XRF=2D0*(-EI*XW)
35101 IF(ILR.EQ.0) THEN
35102 XRQ=0D0
35103 ELSE
35104 XLQ=0D0
35105 ENDIF
35106 TAA=0.5D0*(EI*EJ)**2
35107 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35108 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35109 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35110 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35111 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35112 ELSEIF(IA.LE.6) THEN
35113 FAC0=AS**2*8D0/9D0/2D0
35114 ENDIF
35115 NCHN=NCHN+1
35116 ISIG(NCHN,1)=I
35117 ISIG(NCHN,2)=-I
35118 ISIG(NCHN,3)=1
35119 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35120 460 CONTINUE
35121
35122 ELSEIF(ISUB.EQ.279) THEN
35123C...g + g -> ~q_j + ~q_jbar
35124 XSU=SQM3-UH
35125 XST=SQM3-TH
35126C...5=RKF because ~t ~tbar treated separately
35127 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
35128 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35129 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35130 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
35131 NCHN=NCHN+1
35132 ISIG(NCHN,1)=21
35133 ISIG(NCHN,2)=21
35134 ISIG(NCHN,3)=1
35135 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35136 NCHN=NCHN+1
35137 ISIG(NCHN,1)=21
35138 ISIG(NCHN,2)=21
35139 ISIG(NCHN,3)=2
35140 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35141 470 CONTINUE
35142
35143 ENDIF
35144 ENDIF
35145CMRENNA--
35146
35147 RETURN
35148 END
35149
35150C*********************************************************************
35151
35152C...PYSGTC
35153C...Subprocess cross sections for Technicolor processes.
35154C...Auxiliary to PYSIGH.
35155
35156 SUBROUTINE PYSGTC(NCHN,SIGS)
35157
35158C...Double precision and integer declarations
35159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35160 IMPLICIT INTEGER(I-N)
35161 INTEGER PYK,PYCHGE,PYCOMP
35162C...Parameter statement to help give large particle numbers.
35163 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35164 &KEXCIT=4000000,KDIMEN=5000000)
35165C...Commonblocks
35166 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35167 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35168 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35169 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35170 COMMON/PYINT1/MINT(400),VINT(400)
35171 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35172 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35173 COMMON/PYINT4/MWID(500),WIDS(500,5)
35174 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35175 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35176 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35177 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35178 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35179 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35180 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35181C...Local arrays and complex variables
35182 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35183 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35184 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35185 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35186 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35187 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35188 COMPLEX*16 DVVS,DVVT,DVVU
35189 INTEGER INDX(6)
35190
35191C...Combinations of weak mixing angle.
35192 TANW=SQRT(XW/XW1)
35193 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35194
35195C...Convert almost equivalent technicolor processes into
35196C...a few basic processes, and set distinguishing parameters.
35197 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
35198 SQTV=RTCM(12)**2
35199 SQTA=RTCM(13)**2
35200 SN2W=2D0*SQRT(XW*XW1)
35201 CS2W=1D0-2D0*XW
35202 CT2W=CS2W/SN2W
35203 CSXI=COS(ASIN(RTCM(3)))
35204 CSXIP=COS(ASIN(RTCM(4)))
35205 QUPD=2D0*RTCM(2)-1D0
35206 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
35207 CAB2=0D0
35208 VOGP=0D0
35209 VRGP=0D0
35210 AOGP=0D0
35211 ARGP=0D0
35212 VXGP=0D0
35213 AXGP=0D0
35214 VAGP=0D0
35215 VZGP=0D0
35216 VWGP=0D0
35217C... rho_tc0, etc. -> W_L W_L, W_L W_T
35218 IF(ISUB.EQ.361) THEN
35219 KFA=24
35220 KFB=24
35221 CAB2=RTCM(3)**4
35222 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35223 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35224 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
35225C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
35226 AXGP = SQRT(2D0)*AXGP
35227 ARGP = SQRT(2D0)*ARGP
35228 VOGP = SQRT(2D0)*VOGP
35229C... rho_tc0 -> W_L pi_tc-
35230 ELSEIF(ISUB.EQ.362) THEN
35231 KFA=24
35232 KFB=KTECHN+211
35233 ISUB=361
35234 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35235C... pi_tc pi_tc
35236 ELSEIF(ISUB.EQ.363) THEN
35237 KFA=KTECHN+211
35238 KFB=KTECHN+211
35239 ISUB=361
35240 CAB2=(1D0-RTCM(3)**2)**2
35241C... rho_tc0/omega_tc -> gamma pi_tc
35242 ELSEIF(ISUB.EQ.364) THEN
35243 KFA=22
35244 KFB=KTECHN+111
35245 ISUB=361
35246 VOGP=CSXI/RTCM(12)
35247 VRGP=VOGP*QUPD
35248 VAGP=2D0*QUPD*CSXI
35249 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35250C... gamma pi_tc'
35251 ELSEIF(ISUB.EQ.365) THEN
35252 KFA=22
35253 KFB=KTECHN+221
35254 ISUB=361
35255 VRGP=CSXIP/RTCM(12)
35256 VOGP=VRGP*QUPD
35257 VAGP=2D0*Q2UD*CSXIP
35258 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
35259C... Z pi_tc
35260 ELSEIF(ISUB.EQ.366) THEN
35261 KFA=23
35262 KFB=KTECHN+111
35263 ISUB=361
35264 VOGP=CSXI*CT2W/RTCM(12)
35265 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35266 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35267 VZGP=-QUPD*CSXI*CS2W/XW1
35268C... Z pi_tc'
35269 ELSEIF(ISUB.EQ.367) THEN
35270 KFA=23
35271 KFB=KTECHN+221
35272 ISUB=361
35273C...RTCM(48) is the M_V for the techni-a
35274 VXGP=-CSXIP/SN2W/RTCM(48)
35275 VRGP=CSXIP*CT2W/RTCM(12)
35276 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
35277 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
35278 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
35279C... W_T pi_tc
35280 ELSEIF(ISUB.EQ.368) THEN
35281 KFA=24
35282 KFB=KTECHN+211
35283 ISUB=361
35284C...RTCM(49) is the M_A for the techni-a
35285 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
35286 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
35287 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
35288 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
35289 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35290C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
35291 ELSEIF(ISUB.EQ.370) THEN
35292 KFA=24
35293 KFB=23
35294 CAB2=RTCM(3)**4
35295 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35296 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35297C... W_L pi_tc0
35298 ELSEIF(ISUB.EQ.371) THEN
35299 KFA=24
35300 KFB=KTECHN+111
35301 ISUB=370
35302 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35303C... Z_L pi_tc+
35304 ELSEIF(ISUB.EQ.372) THEN
35305 KFA=KTECHN+211
35306 KFB=23
35307 ISUB=370
35308 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35309C... pi_tc+ pi_tc0
35310 ELSEIF(ISUB.EQ.373) THEN
35311 KFA=KTECHN+211
35312 KFB=KTECHN+111
35313 ISUB=370
35314 CAB2=(1D0-RTCM(3)**2)**2
35315C... gamma pi_tc+
35316 ELSEIF(ISUB.EQ.374) THEN
35317 KFA=KTECHN+211
35318 KFB=22
35319 ISUB=370
35320 VRGP=QUPD*CSXI/RTCM(12)
35321 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
35322 AXGP=-CSXI/RTCM(49)
35323C... Z_T pi_tc+
35324 ELSEIF(ISUB.EQ.375) THEN
35325 KFA=KTECHN+211
35326 KFB=23
35327 ISUB=370
35328 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35329 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
35330 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35331 AXGP=-CSXI*CT2W/RTCM(49)
35332C... W_T pi_tc0
35333 ELSEIF(ISUB.EQ.376) THEN
35334 KFA=24
35335 KFB=KTECHN+111
35336 ISUB=370
35337 VRGP=0D0
35338 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
35339 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
35340C... W_T pi_tc0'
35341 ELSEIF(ISUB.EQ.377) THEN
35342 KFA=24
35343 KFB=KTECHN+221
35344 ISUB=370
35345 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
35346 VWGP=CSXIP/(2D0*XW)
35347 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
35348C... gamma W+
35349 ELSEIF(ISUB.EQ.378) THEN
35350 KFA=24
35351 KFB=22
35352 ISUB=370
35353 VRGP=QUPD*RTCM(3)/RTCM(12)
35354 AXGP=-RTCM(3)/RTCM(49)
35355C... gamma Z
35356 ELSEIF(ISUB.EQ.379) THEN
35357 KFA=23
35358 KFB=22
35359 ISUB=361
35360 VOGP=RTCM(3)/RTCM(12)
35361 VRGP=QUPD*RTCM(3)/RTCM(12)
35362 ELSEIF(ISUB.EQ.380) THEN
35363 KFA=23
35364 KFB=23
35365 ISUB=361
35366 VOGP=RTCM(3)*CT2W/RTCM(12)
35367 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
35368 ENDIF
35369 ENDIF
35370
35371C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
35372 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
35373 IF(ITCM(5).LE.4) THEN
35374 SQDQQS=1D0/SH2
35375 SQDQQT=1D0/TH2
35376 SQDQQU=1D0/UH2
35377 SQDGGS=SQDQQS
35378 SQDGGT=SQDQQT
35379 SQDGGU=SQDQQU
35380 REDGGS=1D0/SH
35381 REDGGT=1D0/TH
35382 REDGGU=1D0/UH
35383 REDGTU=1D0/UH/TH
35384 REDGSU=1D0/SH/UH
35385 REDGST=1D0/SH/TH
35386 REDQST=1D0/SH/TH
35387 REDQTU=1D0/UH/TH
35388 SQDLGS=0D0
35389 SQDLGT=0D0
35390 SQDQTS=SQDQQS
35391 ELSEIF(ITCM(5).EQ.5) THEN
35392 TANT3=RTCM(21)
35393 IF(ITCM(2).EQ.0) THEN
35394 IMDL=1
35395 ELSE
35396 IMDL=2
35397 ENDIF
35398 ALPRHT=2.16D0*(3D0/ITCM(1))
35399 SIN2T=2D0*TANT3/(TANT3**2+1D0)
35400 SINT3=TANT3/SQRT(TANT3**2+1D0)
35401 XIG=SQRT(PYALPS(SH)/ALPRHT)
35402 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
35403 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
35404 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
35405 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
35406 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
35407 & SINT3**2)*2D0/SIN2T
35408 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
35409 & SINT3**2)*2D0/SIN2T
35410
35411 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
35412 SM1112=X12*RTCM(28)**2*SIN2T
35413 SM1121=-X21*RTCM(28)**2*SIN2T
35414 SM2212=-SM1112
35415 SM2221=-SM1121
35416 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
35417 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
35418
35419C.........SH LOOP
35420 ZTC(1,1)=DCMPLX(SH,0D0)
35421 CALL PYWIDT(3100021,SH,WDTP,WDTE)
35422 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
35423 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
35424 CALL PYWIDT(3100113,SH,WDTP,WDTE)
35425 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
35426 CALL PYWIDT(3400113,SH,WDTP,WDTE)
35427 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
35428 CALL PYWIDT(3200113,SH,WDTP,WDTE)
35429 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
35430 CALL PYWIDT(3300113,SH,WDTP,WDTE)
35431 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
35432 ZTC(1,2)=(0D0,0D0)
35433 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
35434 ZTC(1,4)=ZTC(1,3)
35435 ZTC(1,5)=ZTC(1,2)
35436 ZTC(1,6)=ZTC(1,2)
35437 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
35438 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
35439 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
35440 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
35441 ZTC(3,4)=-SM1122
35442 ZTC(3,5)=-SM1112
35443 ZTC(3,6)=-SM1121
35444 ZTC(4,5)=-SM2212
35445 ZTC(4,6)=-SM2221
35446 ZTC(5,6)=-SM1221
35447
35448 DO 110 I=1,5
35449 DO 100 J=I+1,6
35450 ZTC(J,I)=ZTC(I,J)
35451 100 CONTINUE
35452 110 CONTINUE
35453 CALL PYLDCM(ZTC,6,6,INDX,D)
35454 DO 130 I=1,6
35455 DO 120 J=1,6
35456 YTC(I,J)=(0D0,0D0)
35457 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35458 120 CONTINUE
35459 130 CONTINUE
35460
35461 DO 140 I=1,6
35462 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35463 140 CONTINUE
35464 DGGS=YTC(1,1)
35465 DVVS=YTC(2,2)
35466 DGVS=YTC(1,2)
35467
35468 XIG=SQRT(PYALPS(-TH)/ALPRHT)
35469C.........TH LOOP
35470 ZTC(1,1)=DCMPLX(TH)
35471 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
35472 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
35473 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
35474 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
35475 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
35476 ZTC(1,2)=(0D0,0D0)
35477 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
35478 ZTC(1,4)=ZTC(1,3)
35479 ZTC(1,5)=ZTC(1,2)
35480 ZTC(1,6)=ZTC(1,2)
35481 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
35482 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
35483 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
35484 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
35485 ZTC(3,4)=-SM1122
35486 ZTC(3,5)=-SM1112
35487 ZTC(3,6)=-SM1121
35488 ZTC(4,5)=-SM2212
35489 ZTC(4,6)=-SM2221
35490 ZTC(5,6)=-SM1221
35491 DO 160 I=1,5
35492 DO 150 J=I+1,6
35493 ZTC(J,I)=ZTC(I,J)
35494 150 CONTINUE
35495 160 CONTINUE
35496 CALL PYLDCM(ZTC,6,6,INDX,D)
35497 DO 180 I=1,6
35498 DO 170 J=1,6
35499 YTC(I,J)=(0D0,0D0)
35500 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35501 170 CONTINUE
35502 180 CONTINUE
35503 DO 190 I=1,6
35504 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35505 190 CONTINUE
35506 DGGT=YTC(1,1)
35507 DVVT=YTC(2,2)
35508 DGVT=YTC(1,2)
35509
35510 XIG=SQRT(PYALPS(-UH)/ALPRHT)
35511C.........UH LOOP
35512 ZTC(1,1)=DCMPLX(UH,0D0)
35513 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
35514 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
35515 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
35516 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
35517 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
35518 ZTC(1,2)=(0D0,0D0)
35519 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
35520 ZTC(1,4)=ZTC(1,3)
35521 ZTC(1,5)=ZTC(1,2)
35522 ZTC(1,6)=ZTC(1,2)
35523 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
35524 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
35525 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
35526 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
35527 ZTC(3,4)=-SM1122
35528 ZTC(3,5)=-SM1112
35529 ZTC(3,6)=-SM1121
35530 ZTC(4,5)=-SM2212
35531 ZTC(4,6)=-SM2221
35532 ZTC(5,6)=-SM1221
35533 DO 210 I=1,5
35534 DO 200 J=I+1,6
35535 ZTC(J,I)=ZTC(I,J)
35536 200 CONTINUE
35537 210 CONTINUE
35538 CALL PYLDCM(ZTC,6,6,INDX,D)
35539 DO 230 I=1,6
35540 DO 220 J=1,6
35541 YTC(I,J)=(0D0,0D0)
35542 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35543 220 CONTINUE
35544 230 CONTINUE
35545 DO 240 I=1,6
35546 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35547 240 CONTINUE
35548 DGGU=YTC(1,1)
35549 DVVU=YTC(2,2)
35550 DGVU=YTC(1,2)
35551
35552 IF(IMDL.EQ.1) THEN
35553 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
35554 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
35555 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
35556 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
35557 DQGS=DGGS-DGVS*DCMPLX(TANT3)
35558 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35559 ELSE
35560 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35561 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
35562 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
35563 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35564 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35565 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35566 ENDIF
35567
35568 SQDQTS=ABS(DQTS)**2
35569 SQDQQS=ABS(DQQS)**2
35570 SQDQQT=ABS(DQQT)**2
35571 SQDQQU=ABS(DQQU)**2
35572 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
35573 REDLGS=DBLE(DQGS)
35574 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
35575 REDHGS=DBLE(DTGS)
35576 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
35577
35578 SQDGGS=ABS(DGGS)**2
35579 SQDGGT=ABS(DGGT)**2
35580 SQDGGU=ABS(DGGU)**2
35581 REDGGS=DBLE(DGGS)
35582 REDGGT=DBLE(DGGT)
35583 REDGGU=DBLE(DGGU)
35584 REDGTU=DBLE(DGGU*DCONJG(DGGT))
35585 REDGSU=DBLE(DGGU*DCONJG(DGGS))
35586 REDGST=DBLE(DGGS*DCONJG(DGGT))
35587 REDQST=DBLE(DQQS*DCONJG(DQQT))
35588 REDQTU=DBLE(DQQT*DCONJG(DQQU))
35589 ENDIF
35590 ENDIF
35591
35592
35593C...Differential cross section expressions.
35594
35595 IF(ISUB.LE.190) THEN
35596 IF(ISUB.EQ.149) THEN
35597C...g + g -> eta_tc
35598 KCTC=PYCOMP(KTECHN+331)
35599 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
35600 HS=SHR*WDTP(0)
35601 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
35602 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35603 HP=SH
35604 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
35605 HI=HP*WDTP(3)
35606 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35607 NCHN=NCHN+1
35608 ISIG(NCHN,1)=21
35609 ISIG(NCHN,2)=21
35610 ISIG(NCHN,3)=1
35611 SIGH(NCHN)=HI*FACBW*HF
35612 250 CONTINUE
35613
35614 ELSEIF(ISUB.EQ.165) THEN
35615C...q + qbar -> l+ + l- (including contact term for compositeness)
35616 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35617 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35618 KFF=IABS(KFPR(ISUB,1))
35619 EF=KCHG(KFF,1)/3D0
35620 AF=SIGN(1D0,EF+0.1D0)
35621 VF=AF-4D0*EF*XWV
35622 VALF=VF+AF
35623 VARF=VF-AF
35624 FCOF=1D0
35625 IF(KFF.LE.10) FCOF=3D0
35626 WID2=1D0
35627 IF(KFF.EQ.6) WID2=WIDS(6,1)
35628 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
35629 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35630 DO 260 I=MMINA,MMAXA
35631 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
35632 EI=KCHG(IABS(I),1)/3D0
35633 AI=SIGN(1D0,EI+0.1D0)
35634 VI=AI-4D0*EI*XWV
35635 VALI=VI+AI
35636 VARI=VI-AI
35637 FCOI=1D0
35638 IF(IABS(I).LE.10) FCOI=FACA/3D0
35639 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
35640 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
35641 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
35642 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35643 ELSE
35644 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
35645 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35646 ENDIF
35647 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
35648 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
35649 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
35650 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
35651 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
35652 NCHN=NCHN+1
35653 ISIG(NCHN,1)=I
35654 ISIG(NCHN,2)=-I
35655 ISIG(NCHN,3)=1
35656 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
35657 260 CONTINUE
35658
35659 ELSEIF(ISUB.EQ.166) THEN
35660C...q + q'bar -> l + nu_l (including contact term for compositeness)
35661 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
35662 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
35663 KFF=IABS(KFPR(ISUB,1))
35664 FCOF=1D0
35665 IF(KFF.LE.10) FCOF=3D0
35666 DO 280 I=MMIN1,MMAX1
35667 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
35668 IA=IABS(I)
35669 DO 270 J=MMIN2,MMAX2
35670 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
35671 JA=IABS(J)
35672 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
35673 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35674 & GOTO 270
35675 FCOI=1D0
35676 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35677 WID2=1D0
35678 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
35679 & MOD(J,2).EQ.0)) THEN
35680 IF(KFF.EQ.5) WID2=WIDS(6,2)
35681 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
35682 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
35683 ELSE
35684 IF(KFF.EQ.5) WID2=WIDS(6,3)
35685 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
35686 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
35687 ENDIF
35688 NCHN=NCHN+1
35689 ISIG(NCHN,1)=I
35690 ISIG(NCHN,2)=J
35691 ISIG(NCHN,3)=1
35692 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
35693 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
35694 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
35695 270 CONTINUE
35696 280 CONTINUE
35697 ENDIF
35698
35699 ELSEIF(ISUB.LE.200) THEN
35700 IF(ISUB.EQ.191) THEN
35701C...q + qbar -> rho_tc0.
35702 KCTC=PYCOMP(KTECHN+113)
35703 SQMRHT=PMAS(KCTC,1)**2
35704 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35705 HS=SHR*WDTP(0)
35706 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35707 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35708 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35709 ALPRHT=2.16D0*(3D0/ITCM(1))
35710 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
35711 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
35712 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35713 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35714 DO 290 I=MMINA,MMAXA
35715 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
35716 IA=IABS(I)
35717 EI=KCHG(IABS(I),1)/3D0
35718 AI=SIGN(1D0,EI+0.1D0)
35719 VI=AI-4D0*EI*XWV
35720 VALI=0.5D0*(VI+AI)
35721 VARI=0.5D0*(VI-AI)
35722 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
35723 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
35724 IF(IA.LE.10) HI=HI*FACA/3D0
35725 NCHN=NCHN+1
35726 ISIG(NCHN,1)=I
35727 ISIG(NCHN,2)=-I
35728 ISIG(NCHN,3)=1
35729 SIGH(NCHN)=HI*FACBW*HF
35730 290 CONTINUE
35731
35732 ELSEIF(ISUB.EQ.192) THEN
35733C...q + qbar' -> rho_tc+/-.
35734 KCTC=PYCOMP(KTECHN+213)
35735 SQMRHT=PMAS(KCTC,1)**2
35736 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35737 HS=SHR*WDTP(0)
35738 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35739 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35740 ALPRHT=2.16D0*(3D0/ITCM(1))
35741 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
35742 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
35743 DO 310 I=MMIN1,MMAX1
35744 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
35745 IA=IABS(I)
35746 DO 300 J=MMIN2,MMAX2
35747 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
35748 JA=IABS(J)
35749 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
35750 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35751 & GOTO 300
35752 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35753 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
35754 HI=HP
35755 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35756 NCHN=NCHN+1
35757 ISIG(NCHN,1)=I
35758 ISIG(NCHN,2)=J
35759 ISIG(NCHN,3)=1
35760 SIGH(NCHN)=HI*FACBW*HF
35761 300 CONTINUE
35762 310 CONTINUE
35763
35764 ELSEIF(ISUB.EQ.193) THEN
35765C...q + qbar -> omega_tc0.
35766 KCTC=PYCOMP(KTECHN+223)
35767 SQMOMT=PMAS(KCTC,1)**2
35768 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35769 HS=SHR*WDTP(0)
35770 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
35771 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35772 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35773 ALPRHT=2.16D0*(3D0/ITCM(1))
35774 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
35775 & (2D0*RTCM(2)-1D0)**2
35776 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35777 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35778 DO 320 I=MMINA,MMAXA
35779 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
35780 IA=IABS(I)
35781 EI=KCHG(IABS(I),1)/3D0
35782 AI=SIGN(1D0,EI+0.1D0)
35783 VI=AI-4D0*EI*XWV
35784 VALI=0.5D0*(VI+AI)
35785 VARI=0.5D0*(VI-AI)
35786 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
35787 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
35788 IF(IA.LE.10) HI=HI*FACA/3D0
35789 NCHN=NCHN+1
35790 ISIG(NCHN,1)=I
35791 ISIG(NCHN,2)=-I
35792 ISIG(NCHN,3)=1
35793 SIGH(NCHN)=HI*FACBW*HF
35794 320 CONTINUE
35795
35796 ELSEIF(ISUB.EQ.194) THEN
35797C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
35798C...Default final state is e+e-
35799 KFA=KFPR(ISUBSV,1)
35800 ALPRHT=2.16D0*(3D0/ITCM(1))
35801 HP=AEM**2*COMFAC
35802
35803 SN2W=2D0*SQRT(XW*XW1)
35804C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
35805C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
35806
35807 QUPD=2D0*RTCM(2)-1D0
35808 FAR=SQRT(AEM/ALPRHT)
35809 FAO=FAR*QUPD
35810 FZR=FAR*CT2W
35811 FZO=-FAO*TANW
35812C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35813 FZX=-FAR/SN2W*RTCM(47)
35814 SFAR=FAR**2
35815 SFAO=FAO**2
35816 SFZR=FZR**2
35817 SFZO=FZO**2
35818 SFZX=FZX**2
35819 CALL PYWIDT(23,SH,WDTP,WDTE)
35820 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35821 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35822 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35823 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35824 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35825 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35826 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35827C...Propagator including a_T^0
35828 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35829 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35830C...Add in techni-a contribution
35831 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35832 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35833 $ SFZX*SSMR*SSMO)/DETD/SH
35834 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35835 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35836
35837 XWRHT=1D0/(4D0*XW*(1D0-XW))
35838 KFF=IABS(KFPR(ISUB,1))
35839 EF=KCHG(KFF,1)/3D0
35840 AF=SIGN(1D0,EF+0.1D0)
35841 VF=AF-4D0*EF*XWV
35842 VALF=0.5D0*(VF+AF)
35843 VARF=0.5D0*(VF-AF)
35844 FCOF=1D0
35845 IF(KFF.LE.10) FCOF=3D0
35846
35847 WID2=1D0
35848 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
35849 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35850 DZZ=DZZ*DCMPLX(XWRHT,0D0)
35851 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
35852
35853 DO 330 I=MMINA,MMAXA
35854 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
35855 EI=KCHG(IABS(I),1)/3D0
35856 AI=SIGN(1D0,EI+0.1D0)
35857 VI=AI-4D0*EI*XWV
35858 VALI=0.5D0*(VI+AI)
35859 VARI=0.5D0*(VI-AI)
35860 FCOI=FCOF
35861 IF(IABS(I).LE.10) FCOI=FCOI/3D0
35862 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
35863 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
35864 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
35865 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
35866 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
35867 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
35868 NCHN=NCHN+1
35869 ISIG(NCHN,1)=I
35870 ISIG(NCHN,2)=-I
35871 ISIG(NCHN,3)=1
35872 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
35873 330 CONTINUE
35874
35875 ELSEIF(ISUB.EQ.195) THEN
35876C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
35877 KFA=KFPR(ISUBSV,1)
35878 KFB=KFA+1
35879 ALPRHT=2.16D0*(3D0/ITCM(1))
35880 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
35881
35882 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35883C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35884C
35885C...Propagator including a_T^+
35886 FWX=-FWR*RTCM(47)
35887 CALL PYWIDT(24,SH,WDTP,WDTE)
35888 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35889 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35890 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35891 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
35892 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
35893 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
35894 & DCMPLX(FWX**2,0D0)*SSMR
35895 DWW=SSMR*SSMX/DETD/SH
35896 FCOF=1D0
35897 IF(KFA.LE.8) FCOF=3D0
35898 HP=FACTC*ABS(DWW)**2*FCOF
35899
35900 DO 350 I=MMIN1,MMAX1
35901 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
35902 IA=IABS(I)
35903 DO 340 J=MMIN2,MMAX2
35904 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
35905 JA=IABS(J)
35906 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
35907 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35908 & GOTO 340
35909 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35910 HI=HP
35911 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35912 NCHN=NCHN+1
35913 ISIG(NCHN,1)=I
35914 ISIG(NCHN,2)=J
35915 ISIG(NCHN,3)=1
35916 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
35917 340 CONTINUE
35918 350 CONTINUE
35919 ENDIF
35920
35921 ELSEIF(ISUB.LE.380) THEN
35922 ALPRHT=2.16D0*(3D0/ITCM(1))
35923 IF(ISUB.EQ.361) THEN
35924 FAR=SQRT(AEM/ALPRHT)
35925 FAO=FAR*QUPD
35926 FZR=FAR*CT2W
35927 FZO=-FAO*TANW
35928C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35929 FZX=-FAR/SN2W*RTCM(47)
35930 SFAR=FAR**2
35931 SFAO=FAO**2
35932 SFZR=FZR**2
35933 SFZO=FZO**2
35934 SFZX=FZX**2
35935 CALL PYWIDT(23,SH,WDTP,WDTE)
35936 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35937 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35938 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35939 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35940 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35941 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35942 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35943 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35944 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35945C...Add in techni-a contribution
35946 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35947 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
35948 $ SFZX*FAR*SSMO)/DETD/SH
35949 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
35950 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
35951 $ SFZX*FAO*SSMR)/DETD/SH
35952 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
35953 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
35954 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
35955 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35956 $ SFZX*SSMR*SSMO)/DETD/SH
35957 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35958 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35959
35960C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35961C...W+W-, W pi_tc, pi_T pi_T, etc.
35962 FACA=(SH**2*BE34**2-(TH-UH)**2)
35963 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35964 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35965 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35966 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35967 DO 370 I=MMINA,MMAXA
35968 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35969 IA=IABS(I)
35970 EI=KCHG(IABS(I),1)/3D0
35971 AI=SIGN(1D0,EI+0.1D0)
35972 VI=AI-4D0*EI*XWV
35973 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
35974 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
35975C...........Eqs. (5) and (6) in LSTC-rates.pdf
35976 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35977 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35978 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
35979 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35980 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35981 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35982 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35983 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
35984 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35985 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35986 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35987C...........Eqs. (5) and (7) in LSTC-rates.pdf
35988 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35989 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35990 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
35991 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35992 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35993 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
35994 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35995C
35996C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
35997C
35998c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35999c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36000c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36001c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36002 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36003 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36004 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36005 HI=HI+HJ+HK
36006 IF(IA.LE.10) HI=HI/3D0
36007 NCHN=NCHN+1
36008 ISIG(NCHN,1)=I
36009 ISIG(NCHN,2)=-I
36010 ISIG(NCHN,3)=1
36011 IF(KFA.EQ.KFB) THEN
36012 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36013 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36014 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36015 NCHN=NCHN+1
36016 ISIG(NCHN,1)=I
36017 ISIG(NCHN,2)=-I
36018 ISIG(NCHN,3)=2
36019 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36020 ELSE
36021 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36022 ENDIF
36023 370 CONTINUE
36024
36025 ELSEIF(ISUB.EQ.370) THEN
36026C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
36027C...f + fbar' -> gamma pi_tc, etc.
36028 FACA=(SH**2*BE34**2-(TH-UH)**2)
36029 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36030 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36031 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36032 ALPRHT=2.16D0*(3D0/ITCM(1))
36033 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36034 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36035C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36036 FWX=-FWR*RTCM(47)
36037 CALL PYWIDT(24,SH,WDTP,WDTE)
36038 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36039 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36040 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36041 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36042 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36043 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36044 & DCMPLX(FWX**2,0D0)*SSMR
36045 DWW=SSMR*SSMX/DETD/SH
36046 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36047 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36048 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36049 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36050C
36051C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36052C
36053c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36054 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36055C...Add in W_L Z_T axial and vector contributions.
36056 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36057 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36058 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36059 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36060 DO 410 I=MMIN1,MMAX1
36061 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36062 IA=IABS(I)
36063 DO 400 J=MMIN2,MMAX2
36064 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36065 JA=IABS(J)
36066 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36067 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36068 & GOTO 400
36069 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36070 HI=HP
36071 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36072 NCHN=NCHN+1
36073 ISIG(NCHN,1)=I
36074 ISIG(NCHN,2)=J
36075 ISIG(NCHN,3)=1
36076 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36077 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36078 ELSE
36079 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36080 & WIDS(PYCOMP(KFB),2)
36081 ENDIF
36082 400 CONTINUE
36083 410 CONTINUE
36084 ENDIF
36085
36086 ELSEIF(ISUB.LE.390) THEN
36087 IF(ISUB.EQ.381) THEN
36088C...f + f' -> f + f' (g exchange)
36089 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36090 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36091 & MSTP(34)*2D0/3D0*UH2*REDQST)
36092 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36093 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36094 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36095 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36096C...Modifications from contact interactions (compositeness)
36097 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36098 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36099 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36100 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36101 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36102 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36103 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36104 ELSEIF(ITCM(5).EQ.5) THEN
36105 FACCI1=FACQQ1
36106 FACCIB=FACQQB
36107 FACCI2=FACQQ2
36108 FACCI3=FACQQ1
36109CSM.......Check this change from
36110CSM RATCII=1D0
36111 RATCII=RATQQI
36112 ENDIF
36113 DO 430 I=MMIN1,MMAX1
36114 IA=IABS(I)
36115 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36116 DO 420 J=MMIN2,MMAX2
36117 JA=IABS(J)
36118 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36119 NCHN=NCHN+1
36120 ISIG(NCHN,1)=I
36121 ISIG(NCHN,2)=J
36122 ISIG(NCHN,3)=1
36123 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
36124 & JA.GE.3))) THEN
36125 SIGH(NCHN)=FACQQ1
36126 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
36127 ELSE
36128 SIGH(NCHN)=FACCI1
36129 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
36130 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
36131 ENDIF
36132 IF(I.EQ.J) THEN
36133 NCHN=NCHN+1
36134 ISIG(NCHN,1)=I
36135 ISIG(NCHN,2)=J
36136 ISIG(NCHN,3)=2
36137 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
36138 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
36139 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
36140 ELSE
36141 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
36142 SIGH(NCHN)=0.5D0*FACCI2*RATCII
36143 ENDIF
36144 ENDIF
36145 420 CONTINUE
36146 430 CONTINUE
36147
36148 ELSEIF(ISUB.EQ.382) THEN
36149C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36150 CALL PYWIDT(21,SH,WDTP,WDTE)
36151 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
36152 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36153 IF(ITCM(5).EQ.1) THEN
36154C...Modifications from contact interactions (compositeness)
36155 FACCIB=FACQQB
36156 DO 440 I=1,2
36157 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
36158 & WDTE(I,2)+WDTE(I,4))
36159 440 CONTINUE
36160 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
36161 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
36162 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36163 ELSEIF(ITCM(5).EQ.5) THEN
36164 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
36165 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
36166 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
36167 ENDIF
36168 DO 450 I=MMINA,MMAXA
36169 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36170 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
36171 NCHN=NCHN+1
36172 ISIG(NCHN,1)=I
36173 ISIG(NCHN,2)=-I
36174 ISIG(NCHN,3)=1
36175 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
36176 SIGH(NCHN)=FACQQB
36177 ELSEIF(ITCM(5).EQ.5) THEN
36178 SIGH(NCHN)=FACQQB
36179 NCHN=NCHN+1
36180 ISIG(NCHN,1)=I
36181 ISIG(NCHN,2)=-I
36182 ISIG(NCHN,3)=2
36183 SIGH(NCHN)=FACCIB
36184 ELSE
36185 SIGH(NCHN)=FACCIB
36186 ENDIF
36187 450 CONTINUE
36188
36189 ELSEIF(ISUB.EQ.383) THEN
36190C...f + fbar -> g + g (q + qbar -> g + g only)
36191 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36192 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36193 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36194 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36195 IF(ITCM(5).EQ.5) THEN
36196 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36197 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36198 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36199 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36200 ENDIF
36201 DO 460 I=MMINA,MMAXA
36202 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36203 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36204 NCHN=NCHN+1
36205 ISIG(NCHN,1)=I
36206 ISIG(NCHN,2)=-I
36207 ISIG(NCHN,3)=1
36208 SIGH(NCHN)=0.5D0*FACGG1
36209 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
36210 NCHN=NCHN+1
36211 ISIG(NCHN,1)=I
36212 ISIG(NCHN,2)=-I
36213 ISIG(NCHN,3)=2
36214 SIGH(NCHN)=0.5D0*FACGG2
36215 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
36216 460 CONTINUE
36217
36218 ELSEIF(ISUB.EQ.384) THEN
36219C...f + g -> f + g (q + g -> q + g only)
36220 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
36221 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
36222 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
36223 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
36224 DO 480 I=MMINA,MMAXA
36225 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
36226 DO 470 ISDE=1,2
36227 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
36228 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
36229 NCHN=NCHN+1
36230 ISIG(NCHN,ISDE)=I
36231 ISIG(NCHN,3-ISDE)=21
36232 ISIG(NCHN,3)=1
36233 SIGH(NCHN)=FACQG1
36234 NCHN=NCHN+1
36235 ISIG(NCHN,ISDE)=I
36236 ISIG(NCHN,3-ISDE)=21
36237 ISIG(NCHN,3)=2
36238 SIGH(NCHN)=FACQG2
36239 470 CONTINUE
36240 480 CONTINUE
36241
36242 ELSEIF(ISUB.EQ.385) THEN
36243C...g + g -> f + fbar (g + g -> q + qbar only)
36244 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
36245 IDC0=MDCY(21,2)-1
36246C...Begin by d, u, s flavours.
36247 FLAVWT=0D0
36248 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
36249 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
36250 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
36251 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
36252 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
36253 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
36254 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36255 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36256 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36257 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36258 NCHN=NCHN+1
36259 ISIG(NCHN,1)=21
36260 ISIG(NCHN,2)=21
36261 ISIG(NCHN,3)=1
36262 SIGH(NCHN)=FACQQ1
36263 NCHN=NCHN+1
36264 ISIG(NCHN,1)=21
36265 ISIG(NCHN,2)=21
36266 ISIG(NCHN,3)=2
36267 SIGH(NCHN)=FACQQ2
36268C...Next c and b flavours: modified that and uhat for fixed
36269C...cos(theta-hat).
36270 DO 490 IFL=4,5
36271 SQMAVG=PMAS(IFL,1)**2
36272 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
36273 BE34=SQRT(1D0-4D0*SQMAVG/SH)
36274 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36275 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36276 THUHQ=THQ*UHQ-SQMAVG*SH
36277 IF(MSTP(34).EQ.0) THEN
36278 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36279 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36280 ELSE
36281 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36282 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36283 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36284 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36285 ENDIF
36286 IF(ITCM(5).GE.5) THEN
36287 IF(IFL.EQ.4) THEN
36288 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36289 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36290 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36291 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36292 ELSE
36293 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36294 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36295 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36296 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36297 ENDIF
36298 ENDIF
36299 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
36300 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
36301 NCHN=NCHN+1
36302 ISIG(NCHN,1)=21
36303 ISIG(NCHN,2)=21
36304 ISIG(NCHN,3)=1+2*(IFL-3)
36305 SIGH(NCHN)=FACQQ1
36306 NCHN=NCHN+1
36307 ISIG(NCHN,1)=21
36308 ISIG(NCHN,2)=21
36309 ISIG(NCHN,3)=2+2*(IFL-3)
36310 SIGH(NCHN)=FACQQ2
36311 ENDIF
36312 490 CONTINUE
36313 500 CONTINUE
36314
36315 ELSEIF(ISUB.EQ.386) THEN
36316C...g + g -> g + g
36317 IF(ITCM(5).LE.4) THEN
36318 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
36319 & 2D0*TH/SH+TH2/SH2)*FACA
36320 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
36321 & 2D0*SH/UH+SH2/UH2)*FACA
36322 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
36323 & 2D0*UH/TH+UH2/TH2)
36324 ELSE
36325 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
36326 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
36327 & 4D0*REDGST*(SH + 2D0*TH)*
36328 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
36329 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
36330 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
36331 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
36332 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
36333 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
36334 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
36335 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
36336 & 4D0*REDGSU*(SH + 2D0*UH)*
36337 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
36338 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
36339 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
36340 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
36341 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
36342 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
36343 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
36344 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
36345 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
36346 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
36347 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
36348 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
36349 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
36350 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
36351 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
36352 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
36353 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
36354 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
36355 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
36356 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
36357 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
36358 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
36359 ENDIF
36360 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
36361 NCHN=NCHN+1
36362 ISIG(NCHN,1)=21
36363 ISIG(NCHN,2)=21
36364 ISIG(NCHN,3)=1
36365 SIGH(NCHN)=0.5D0*FACGG1
36366 NCHN=NCHN+1
36367 ISIG(NCHN,1)=21
36368 ISIG(NCHN,2)=21
36369 ISIG(NCHN,3)=2
36370 SIGH(NCHN)=0.5D0*FACGG2
36371 NCHN=NCHN+1
36372 ISIG(NCHN,1)=21
36373 ISIG(NCHN,2)=21
36374 ISIG(NCHN,3)=3
36375 SIGH(NCHN)=0.5D0*FACGG3
36376 510 CONTINUE
36377
36378 ELSEIF(ISUB.EQ.387) THEN
36379C...q + qbar -> Q + Qbar
36380 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36381 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36382 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36383 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
36384 & 2D0*SQMAVG/SH)
36385 IF(ITCM(5).GE.5) THEN
36386 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36387 FACQQB=FACQQB*SH2*SQDQTS
36388 ELSE
36389 FACQQB=FACQQB*SH2*SQDQQS
36390 ENDIF
36391 ENDIF
36392 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
36393 WID2=1D0
36394 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36395 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36396 FACQQB=FACQQB*WID2
36397 DO 520 I=MMINA,MMAXA
36398 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36399 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
36400 NCHN=NCHN+1
36401 ISIG(NCHN,1)=I
36402 ISIG(NCHN,2)=-I
36403 ISIG(NCHN,3)=1
36404 SIGH(NCHN)=FACQQB
36405 520 CONTINUE
36406
36407 ELSEIF(ISUB.EQ.388) THEN
36408C...g + g -> Q + Qbar
36409 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36410 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36411 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36412 THUHQ=THQ*UHQ-SQMAVG*SH
36413 IF(MSTP(34).EQ.0) THEN
36414 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36415 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36416 ELSE
36417 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36418 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36419 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36420 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36421 ENDIF
36422 IF(ITCM(5).GE.5) THEN
36423 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36424 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36425 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36426 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36427 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36428 ELSE
36429 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36430 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36431 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36432 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36433 ENDIF
36434 ENDIF
36435 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
36436 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
36437 IF(MSTP(35).GE.1) THEN
36438 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
36439 FACQQ1=FACQQ1*FATRE
36440 FACQQ2=FACQQ2*FATRE
36441 ENDIF
36442 WID2=1D0
36443 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36444 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36445 FACQQ1=FACQQ1*WID2
36446 FACQQ2=FACQQ2*WID2
36447 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
36448 NCHN=NCHN+1
36449 ISIG(NCHN,1)=21
36450 ISIG(NCHN,2)=21
36451 ISIG(NCHN,3)=1
36452 SIGH(NCHN)=FACQQ1
36453 NCHN=NCHN+1
36454 ISIG(NCHN,1)=21
36455 ISIG(NCHN,2)=21
36456 ISIG(NCHN,3)=2
36457 SIGH(NCHN)=FACQQ2
36458 530 CONTINUE
36459 ENDIF
36460 ENDIF
36461
36462CMRENNA--
36463
36464 RETURN
36465 END
36466
36467C*********************************************************************
36468
36469C...PYSGEX
36470C...Subprocess cross sections for assorted exotic processes,
36471C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
36472C...Auxiliary to PYSIGH.
36473
36474 SUBROUTINE PYSGEX(NCHN,SIGS)
36475
36476C...Double precision and integer declarations
36477 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36478 IMPLICIT INTEGER(I-N)
36479 INTEGER PYK,PYCHGE,PYCOMP
36480C...Parameter statement to help give large particle numbers.
36481 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36482 &KEXCIT=4000000,KDIMEN=5000000)
36483C...Commonblocks
36484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36486 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36487 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36488 COMMON/PYINT1/MINT(400),VINT(400)
36489 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36490 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36491 COMMON/PYINT4/MWID(500),WIDS(500,5)
36492 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36493 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36494 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36495 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36496 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36497 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36498 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36499C...Local arrays
36500 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36501
36502C...Differential cross section expressions.
36503
36504 IF(ISUB.LE.160) THEN
36505 IF(ISUB.EQ.141) THEN
36506C...f + fbar -> gamma*/Z0/Z'0
36507 SQMZP=PMAS(32,1)**2
36508 MINT(61)=2
36509 CALL PYWIDT(32,SH,WDTP,WDTE)
36510 HP0=AEM/3D0*SH
36511 HP1=AEM/3D0*XWC*SH
36512 HP2=HP1
36513 HS=SHR*VINT(117)
36514 HSP=SHR*WDTP(0)
36515 FACZP=4D0*COMFAC*3D0
36516 DO 100 I=MMINA,MMAXA
36517 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
36518 EI=KCHG(IABS(I),1)/3D0
36519 AI=SIGN(1D0,EI)
36520 VI=AI-4D0*EI*XWV
36521 IA=IABS(I)
36522 IF(IA.LT.10) THEN
36523 IF(IA.LE.2) THEN
36524 VPI=PARU(123-2*MOD(IABS(I),2))
36525 API=PARU(124-2*MOD(IABS(I),2))
36526 ELSEIF(IA.LE.4) THEN
36527 VPI=PARJ(182-2*MOD(IABS(I),2))
36528 API=PARJ(183-2*MOD(IABS(I),2))
36529 ELSE
36530 VPI=PARJ(190-2*MOD(IABS(I),2))
36531 API=PARJ(191-2*MOD(IABS(I),2))
36532 ENDIF
36533 ELSE
36534 IF(IA.LE.12) THEN
36535 VPI=PARU(127-2*MOD(IABS(I),2))
36536 API=PARU(128-2*MOD(IABS(I),2))
36537 ELSEIF(IA.LE.14) THEN
36538 VPI=PARJ(186-2*MOD(IABS(I),2))
36539 API=PARJ(187-2*MOD(IABS(I),2))
36540 ELSE
36541 VPI=PARJ(194-2*MOD(IABS(I),2))
36542 API=PARJ(195-2*MOD(IABS(I),2))
36543 ENDIF
36544 ENDIF
36545 HI0=HP0
36546 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
36547 HI1=HP1
36548 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
36549 HI2=HP2
36550 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
36551 NCHN=NCHN+1
36552 ISIG(NCHN,1)=I
36553 ISIG(NCHN,2)=-I
36554 ISIG(NCHN,3)=1
36555 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
36556 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
36557 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
36558 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
36559 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
36560 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
36561 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
36562 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
36563 100 CONTINUE
36564
36565 ELSEIF(ISUB.EQ.142) THEN
36566C...f + fbar' -> W'+/-
36567 SQMWP=PMAS(34,1)**2
36568 CALL PYWIDT(34,SH,WDTP,WDTE)
36569 HS=SHR*WDTP(0)
36570 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
36571 HP=AEM/(24D0*XW)*SH
36572 DO 120 I=MMIN1,MMAX1
36573 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
36574 IA=IABS(I)
36575 DO 110 J=MMIN2,MMAX2
36576 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
36577 JA=IABS(J)
36578 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
36579 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36580 & GOTO 110
36581 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36582 HI=HP*(PARU(133)**2+PARU(134)**2)
36583 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
36584 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36585 NCHN=NCHN+1
36586 ISIG(NCHN,1)=I
36587 ISIG(NCHN,2)=J
36588 ISIG(NCHN,3)=1
36589 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36590 SIGH(NCHN)=HI*FACBW*HF
36591 110 CONTINUE
36592 120 CONTINUE
36593
36594 ELSEIF(ISUB.EQ.144) THEN
36595C...f + fbar' -> R
36596 SQMR=PMAS(41,1)**2
36597 CALL PYWIDT(41,SH,WDTP,WDTE)
36598 HS=SHR*WDTP(0)
36599 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
36600 HP=AEM/(12D0*XW)*SH
36601 DO 140 I=MMIN1,MMAX1
36602 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
36603 IA=IABS(I)
36604 DO 130 J=MMIN2,MMAX2
36605 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
36606 JA=IABS(J)
36607 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
36608 HI=HP
36609 IF(IA.LE.10) HI=HI*FACA/3D0
36610 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
36611 NCHN=NCHN+1
36612 ISIG(NCHN,1)=I
36613 ISIG(NCHN,2)=J
36614 ISIG(NCHN,3)=1
36615 SIGH(NCHN)=HI*FACBW*HF
36616 130 CONTINUE
36617 140 CONTINUE
36618
36619 ELSEIF(ISUB.EQ.145) THEN
36620C...q + l -> LQ (leptoquark)
36621 SQMLQ=PMAS(42,1)**2
36622 CALL PYWIDT(42,SH,WDTP,WDTE)
36623 HS=SHR*WDTP(0)
36624 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
36625 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
36626 HP=AEM/4D0*SH
36627 KFLQQ=KFDP(MDCY(42,2),1)
36628 KFLQL=KFDP(MDCY(42,2),2)
36629 DO 160 I=MMIN1,MMAX1
36630 IF(KFAC(1,I).EQ.0) GOTO 160
36631 IA=IABS(I)
36632 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
36633 DO 150 J=MMIN2,MMAX2
36634 IF(KFAC(2,J).EQ.0) GOTO 150
36635 JA=IABS(J)
36636 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
36637 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
36638 IF(JA.EQ.IA) GOTO 150
36639 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
36640 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
36641 HI=HP*PARU(151)
36642 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
36643 NCHN=NCHN+1
36644 ISIG(NCHN,1)=I
36645 ISIG(NCHN,2)=J
36646 ISIG(NCHN,3)=1
36647 SIGH(NCHN)=HI*FACBW*HF
36648 150 CONTINUE
36649 160 CONTINUE
36650
36651 ELSEIF(ISUB.EQ.146) THEN
36652C...e + gamma* -> e* (excited lepton)
36653 KFQSTR=KFPR(ISUB,1)
36654 KCQSTR=PYCOMP(KFQSTR)
36655 KFQEXC=MOD(KFQSTR,KEXCIT)
36656 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36657 HS=SHR*WDTP(0)
36658 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36659 QF=-RTCM(43)/2D0-RTCM(44)/2D0
36660 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
36661 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36662 & FACBW=0D0
36663 HP=SH
36664 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
36665 DO 170 ISDE=1,2
36666 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
36667 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
36668 HI=HP
36669 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36670 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36671 NCHN=NCHN+1
36672 ISIG(NCHN,ISDE)=I
36673 ISIG(NCHN,3-ISDE)=22
36674 ISIG(NCHN,3)=1
36675 SIGH(NCHN)=HI*FACBW*HF
36676 170 CONTINUE
36677 180 CONTINUE
36678
36679 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
36680C...d + g -> d* and u + g -> u* (excited quarks)
36681 KFQSTR=KFPR(ISUB,1)
36682 KCQSTR=PYCOMP(KFQSTR)
36683 KFQEXC=MOD(KFQSTR,KEXCIT)
36684 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36685 HS=SHR*WDTP(0)
36686 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36687 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
36688 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36689 & FACBW=0D0
36690 HP=SH
36691 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
36692 DO 190 ISDE=1,2
36693 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
36694 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
36695 HI=HP
36696 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36697 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36698 NCHN=NCHN+1
36699 ISIG(NCHN,ISDE)=I
36700 ISIG(NCHN,3-ISDE)=21
36701 ISIG(NCHN,3)=1
36702 SIGH(NCHN)=HI*FACBW*HF
36703 190 CONTINUE
36704 200 CONTINUE
36705 ENDIF
36706
36707 ELSEIF(ISUB.LE.190) THEN
36708 IF(ISUB.EQ.162) THEN
36709C...q + g -> LQ + lbar; LQ=leptoquark
36710 SQMLQ=PMAS(42,1)**2
36711 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
36712 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
36713 KFLQQ=KFDP(MDCY(42,2),1)
36714 DO 220 I=MMINA,MMAXA
36715 IF(IABS(I).NE.KFLQQ) GOTO 220
36716 KCHLQ=ISIGN(1,I)
36717 DO 210 ISDE=1,2
36718 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
36719 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
36720 NCHN=NCHN+1
36721 ISIG(NCHN,ISDE)=I
36722 ISIG(NCHN,3-ISDE)=21
36723 ISIG(NCHN,3)=1
36724 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
36725 210 CONTINUE
36726 220 CONTINUE
36727
36728 ELSEIF(ISUB.EQ.163) THEN
36729C...g + g -> LQ + LQbar; LQ=leptoquark
36730 SQMLQ=PMAS(42,1)**2
36731 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
36732 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
36733 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
36734 & ((TH-SQMLQ)*(UH-SQMLQ)))
36735 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
36736 NCHN=NCHN+1
36737 ISIG(NCHN,1)=21
36738 ISIG(NCHN,2)=21
36739C...Since don't know proper colour flow, randomize between alternatives
36740 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
36741 SIGH(NCHN)=FACLQ
36742 230 CONTINUE
36743
36744 ELSEIF(ISUB.EQ.164) THEN
36745C...q + qbar -> LQ + LQbar; LQ=leptoquark
36746 DELTA=0.25D0*(SQM3-SQM4)**2/SH
36747 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
36748 TH=TH-DELTA
36749 UH=UH-DELTA
36750C SQMLQ=PMAS(42,1)**2
36751 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
36752 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
36753 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
36754 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
36755 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
36756 KFLQQ=KFDP(MDCY(42,2),1)
36757 DO 240 I=MMINA,MMAXA
36758 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36759 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
36760 NCHN=NCHN+1
36761 ISIG(NCHN,1)=I
36762 ISIG(NCHN,2)=-I
36763 ISIG(NCHN,3)=1
36764 SIGH(NCHN)=FACLQA
36765 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
36766 240 CONTINUE
36767
36768 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
36769C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
36770 KFQSTR=KFPR(ISUB,2)
36771 KCQSTR=PYCOMP(KFQSTR)
36772 KFQEXC=MOD(KFQSTR,KEXCIT)
36773 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
36774 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36775 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36776C...Propagators: as simulated in PYOFSH and as desired
36777 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36778 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36779 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36780 GMMQC=SQRT(SQM4)*WDTP(0)
36781 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36782 FACQSA=FACQSA*HBW4C/HBW4
36783 FACQSB=FACQSB*HBW4C/HBW4
36784C...Branching ratios.
36785 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36786 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36787 DO 260 I=MMIN1,MMAX1
36788 IA=IABS(I)
36789 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
36790 DO 250 J=MMIN2,MMAX2
36791 JA=IABS(J)
36792 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
36793 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
36794 NCHN=NCHN+1
36795 ISIG(NCHN,1)=I
36796 ISIG(NCHN,2)=J
36797 ISIG(NCHN,3)=1
36798 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36799 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36800 NCHN=NCHN+1
36801 ISIG(NCHN,1)=I
36802 ISIG(NCHN,2)=J
36803 ISIG(NCHN,3)=2
36804 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36805 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36806 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
36807 NCHN=NCHN+1
36808 ISIG(NCHN,1)=I
36809 ISIG(NCHN,2)=J
36810 ISIG(NCHN,3)=1
36811 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36812 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
36813 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
36814 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
36815 NCHN=NCHN+1
36816 ISIG(NCHN,1)=I
36817 ISIG(NCHN,2)=J
36818 ISIG(NCHN,3)=1
36819 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36820 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36821 NCHN=NCHN+1
36822 ISIG(NCHN,1)=I
36823 ISIG(NCHN,2)=J
36824 ISIG(NCHN,3)=2
36825 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36826 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36827 ELSEIF(I.EQ.-J) THEN
36828 NCHN=NCHN+1
36829 ISIG(NCHN,1)=I
36830 ISIG(NCHN,2)=J
36831 ISIG(NCHN,3)=1
36832 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36833 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36834 NCHN=NCHN+1
36835 ISIG(NCHN,1)=I
36836 ISIG(NCHN,2)=J
36837 ISIG(NCHN,3)=2
36838 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36839 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36840 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
36841 NCHN=NCHN+1
36842 ISIG(NCHN,1)=I
36843 ISIG(NCHN,2)=J
36844 ISIG(NCHN,3)=1
36845 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36846 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
36847 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
36848 ENDIF
36849 250 CONTINUE
36850 260 CONTINUE
36851
36852 ELSEIF(ISUB.EQ.169) THEN
36853C...q + qbar -> e + e* (excited lepton)
36854 KFQSTR=KFPR(ISUB,2)
36855 KCQSTR=PYCOMP(KFQSTR)
36856 KFQEXC=MOD(KFQSTR,KEXCIT)
36857 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36858 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36859C...Propagators: as simulated in PYOFSH and as desired
36860 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36861 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36862 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36863 GMMQC=SQRT(SQM4)*WDTP(0)
36864 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36865 FACQSB=FACQSB*HBW4C/HBW4
36866C...Branching ratios.
36867 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36868 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36869 DO 270 I=MMIN1,MMAX1
36870 IA=IABS(I)
36871 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
36872 J=-I
36873 JA=IABS(J)
36874 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
36875 NCHN=NCHN+1
36876 ISIG(NCHN,1)=I
36877 ISIG(NCHN,2)=J
36878 ISIG(NCHN,3)=1
36879 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36880 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36881 NCHN=NCHN+1
36882 ISIG(NCHN,1)=I
36883 ISIG(NCHN,2)=J
36884 ISIG(NCHN,3)=2
36885 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36886 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36887 270 CONTINUE
36888 ENDIF
36889
36890 ELSEIF(ISUB.LE.360) THEN
36891 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
36892C...l + l -> H_L++/-- or H_R++/--.
36893 KFRES=KFPR(ISUB,1)
36894 KFREC=PYCOMP(KFRES)
36895 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36896 HS=SHR*WDTP(0)
36897 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
36898 DO 290 I=MMIN1,MMAX1
36899 IA=IABS(I)
36900 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
36901 & GOTO 290
36902 DO 280 J=MMIN2,MMAX2
36903 JA=IABS(J)
36904 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
36905 & GOTO 280
36906 IF(I*J.LT.0) GOTO 280
36907 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36908 NCHN=NCHN+1
36909 ISIG(NCHN,1)=I
36910 ISIG(NCHN,2)=J
36911 ISIG(NCHN,3)=1
36912 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
36913 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36914 SIGH(NCHN)=HI*FACBW*HF
36915 280 CONTINUE
36916 290 CONTINUE
36917
36918 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
36919C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
36920 KFRES=KFPR(ISUB,1)
36921 KFREC=PYCOMP(KFRES)
36922C...Propagators: as simulated in PYOFSH and as desired
36923 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
36924 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
36925 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36926 GMMC=SQRT(SQM3)*WDTP(0)
36927 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
36928 FHCC=COMFAC*AEM*HBW3C/HBW3
36929 DO 310 I=MMINA,MMAXA
36930 IA=IABS(I)
36931 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36932 SQML=PMAS(IA,1)**2
36933 J=ISIGN(KFPR(ISUB,2),-I)
36934 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36935 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36936 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36937 & (UH-SQM3)**2
36938 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36939 & (TH-SQM4)*SH)/(TH-SQM4)**2
36940 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36941 & SH)/(SH-SQML)**2
36942 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36943 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36944 & ((UH-SQM3)*(TH-SQM4))
36945 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36946 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36947 & ((UH-SQM3)*(SH-SQML))
36948 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36949 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36950 & ((SH-SQML)*(TH-SQM4))
36951 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36952 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36953 DO 300 ISDE=1,2
36954 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36955 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36956 NCHN=NCHN+1
36957 ISIG(NCHN,ISDE)=I
36958 ISIG(NCHN,3-ISDE)=22
36959 ISIG(NCHN,3)=0
36960 SIGH(NCHN)=FHCC*SMM*WIDSC
36961 300 CONTINUE
36962 310 CONTINUE
36963
36964 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36965C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36966 KFRES=KFPR(ISUB,1)
36967 KFREC=PYCOMP(KFRES)
36968 SQMH=PMAS(KFREC,1)**2
36969 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36970C...Propagators: H++/-- as simulated in PYOFSH and as desired
36971 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36972 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36973 GMMH3=SQRT(SQM3)*WDTP(0)
36974 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36975 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36976 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36977 GMMH4=SQRT(SQM4)*WDTP(0)
36978 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36979C...Kinematical and coupling functions
36980 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36981 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36982C...Loop over allowed flavours
36983 DO 320 I=MMINA,MMAXA
36984 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36985 EI=KCHG(IABS(I),1)/3D0
36986 AI=SIGN(1D0,EI+0.1D0)
36987 VI=AI-4D0*EI*XWV
36988 FCOI=1D0
36989 IF(IABS(I).LE.10) FCOI=FACA/3D0
36990 IF(ISUB.EQ.349) THEN
36991 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36992 IF(IABS(I).LT.10) THEN
36993 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36994 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36995 & (VI**2+AI**2)*XWHH**2*HBWZ)
36996 ELSE
36997 IAOFF=181+3*((IABS(I)-11)/2)
36998 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36999 & (4D0*PARU(1))
37000 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37001 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37002 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37003 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37004 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37005 & 4D0*HSUM**2/TH2
37006 ENDIF
37007 ELSE
37008 IF(IABS(I).LT.10) THEN
37009 DSIGHH=8D0*AEM**2*EI**2/SH2
37010 ELSE
37011 IAOFF=181+3*((IABS(I)-11)/2)
37012 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37013 & (4D0*PARU(1))
37014 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37015 & 4D0*HSUM**2/TH2
37016 ENDIF
37017 ENDIF
37018 NCHN=NCHN+1
37019 ISIG(NCHN,1)=I
37020 ISIG(NCHN,2)=-I
37021 ISIG(NCHN,3)=1
37022 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37023 320 CONTINUE
37024
37025 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37026C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37027 KFRES=KFPR(ISUB,1)
37028 KFREC=PYCOMP(KFRES)
37029 SQMH=PMAS(KFREC,1)**2
37030 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37031 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37032 & PMAS(PYCOMP(9900024),1)**2
37033 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37034 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37035 & (VINT(209)**2-VINT(216)))
37036 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37037 & (VINT(209)**2+2D0*VINT(218)))
37038 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37039 HS=SHR*WDTP(0)
37040 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37041 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37042 & FACBW=0D0
37043 DO 340 I=MMIN1,MMAX1
37044 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37045 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37046 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37047 DO 330 J=MMIN2,MMAX2
37048 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37049 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37050 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37051 KCHH=KCHWI+KCHWJ
37052 IF(IABS(KCHH).NE.2) GOTO 330
37053 FACLR=VINT(180+I)*VINT(180+J)
37054 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37055 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37056 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37057 ELSE
37058 FACPRP=FACPRT**2
37059 ENDIF
37060 NCHN=NCHN+1
37061 ISIG(NCHN,1)=I
37062 ISIG(NCHN,2)=J
37063 ISIG(NCHN,3)=1
37064 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37065 330 CONTINUE
37066 340 CONTINUE
37067
37068 ELSEIF(ISUB.EQ.353) THEN
37069C...f + fbar -> Z_R0
37070 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37071 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37072 HS=SHR*WDTP(0)
37073 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37074 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37075 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37076 DO 350 I=MMINA,MMAXA
37077 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37078 IF(IABS(I).LE.8) THEN
37079 EI=KCHG(IABS(I),1)/3D0
37080 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37081 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37082 ELSE
37083 AI=-(1D0-2D0*XW)
37084 VI=-1D0+4D0*XW
37085 ENDIF
37086 HI=HP*(VI**2+AI**2)
37087 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37088 NCHN=NCHN+1
37089 ISIG(NCHN,1)=I
37090 ISIG(NCHN,2)=-I
37091 ISIG(NCHN,3)=1
37092 SIGH(NCHN)=HI*FACBW*HF
37093 350 CONTINUE
37094
37095 ELSEIF(ISUB.EQ.354) THEN
37096C...f + fbar' -> W_R+/-
37097 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37098 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37099 HS=SHR*WDTP(0)
37100 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
37101 HP=AEM/(24D0*XW)*SH
37102 DO 370 I=MMIN1,MMAX1
37103 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
37104 IA=IABS(I)
37105 DO 360 J=MMIN2,MMAX2
37106 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
37107 JA=IABS(J)
37108 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
37109 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37110 & GOTO 360
37111 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37112 HI=HP*2D0
37113 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37114 NCHN=NCHN+1
37115 ISIG(NCHN,1)=I
37116 ISIG(NCHN,2)=J
37117 ISIG(NCHN,3)=1
37118 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37119 SIGH(NCHN)=HI*FACBW*HF
37120 360 CONTINUE
37121 370 CONTINUE
37122 ENDIF
37123
37124 ELSEIF(ISUB.LE.400) THEN
37125 IF(ISUB.EQ.391) THEN
37126C...f + fbar -> G*.
37127 KFGSTR=KFPR(ISUB,1)
37128 KCGSTR=PYCOMP(KFGSTR)
37129 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37130 HS=SHR*WDTP(0)
37131 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37132 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
37133 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37134C...Modify cross section in wings of peak.
37135 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37136 DO 380 I=MMINA,MMAXA
37137 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
37138 HI=1D0
37139 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37140 NCHN=NCHN+1
37141 ISIG(NCHN,1)=I
37142 ISIG(NCHN,2)=-I
37143 ISIG(NCHN,3)=1
37144 SIGH(NCHN)=FACG*HI
37145 380 CONTINUE
37146
37147 ELSEIF(ISUB.EQ.392) THEN
37148C...g + g -> G*.
37149 KFGSTR=KFPR(ISUB,1)
37150 KCGSTR=PYCOMP(KFGSTR)
37151 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37152 HS=SHR*WDTP(0)
37153 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37154 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
37155 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37156C...Modify cross section in wings of peak.
37157 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37158 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
37159 NCHN=NCHN+1
37160 ISIG(NCHN,1)=21
37161 ISIG(NCHN,2)=21
37162 ISIG(NCHN,3)=1
37163 SIGH(NCHN)=FACG
37164 390 CONTINUE
37165
37166 ELSEIF(ISUB.EQ.393) THEN
37167C...q + qbar -> g + G*.
37168 KFGSTR=KFPR(ISUB,2)
37169 KCGSTR=PYCOMP(KFGSTR)
37170 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
37171 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
37172 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
37173 & 2D0*SH2/(TH*UH))
37174C...Propagators: as simulated in PYOFSH and as desired
37175 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37176 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37177 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37178 HS=SQRT(SQM4)*WDTP(0)
37179 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37180 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37181 FACG=FACG*HBW4C/HBW4
37182 DO 400 I=MMINA,MMAXA
37183 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37184 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
37185 NCHN=NCHN+1
37186 ISIG(NCHN,1)=I
37187 ISIG(NCHN,2)=-I
37188 ISIG(NCHN,3)=1
37189 SIGH(NCHN)=FACG
37190 400 CONTINUE
37191
37192 ELSEIF(ISUB.EQ.394) THEN
37193C...q + g -> q + G*.
37194 KFGSTR=KFPR(ISUB,2)
37195 KCGSTR=PYCOMP(KFGSTR)
37196 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
37197 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
37198 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
37199 & 2D0*TH2*TH/(UH*SH2))
37200C...Propagators: as simulated in PYOFSH and as desired
37201 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37202 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37203 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37204 HS=SQRT(SQM4)*WDTP(0)
37205 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37206 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37207 FACG=FACG*HBW4C/HBW4
37208 DO 420 I=MMINA,MMAXA
37209 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
37210 DO 410 ISDE=1,2
37211 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
37212 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
37213 NCHN=NCHN+1
37214 ISIG(NCHN,ISDE)=I
37215 ISIG(NCHN,3-ISDE)=21
37216 ISIG(NCHN,3)=1
37217 SIGH(NCHN)=FACG
37218 410 CONTINUE
37219 420 CONTINUE
37220
37221 ELSEIF(ISUB.EQ.395) THEN
37222C...g + g -> g + G*.
37223 KFGSTR=KFPR(ISUB,2)
37224 KCGSTR=PYCOMP(KFGSTR)
37225 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
37226 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
37227 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
37228C...Propagators: as simulated in PYOFSH and as desired
37229 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37230 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37231 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37232 HS=SQRT(SQM4)*WDTP(0)
37233 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37234 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37235 FACG=FACG*HBW4C/HBW4
37236 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
37237 NCHN=NCHN+1
37238 ISIG(NCHN,1)=21
37239 ISIG(NCHN,2)=21
37240 ISIG(NCHN,3)=1
37241 SIGH(NCHN)=FACG
37242 ENDIF
37243 ENDIF
37244 ENDIF
37245
37246 RETURN
37247 END
37248
37249C*********************************************************************
37250
37251C...PYPDFU
37252C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
37253C...parton distributions according to a few different parametrizations.
37254C...Note that what is coded is x times the probability distribution,
37255C...i.e. xq(x,Q2) etc.
37256
37257 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
37258
37259C...Double precision and integer declarations.
37260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37261 IMPLICIT INTEGER(I-N)
37262 INTEGER PYK,PYCHGE,PYCOMP
37263C...Commonblocks.
37264 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37267 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37268 COMMON/PYINT1/MINT(400),VINT(400)
37269 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37270 &XPDIR(-6:6)
37271 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37272 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
37273 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
37274 & XMI(2,240),PT2MI(240),IMISEP(0:240)
37275 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
37276 &/PYINT9/,/PYINTM/
37277C...Local arrays.
37278 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
37279 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
37280 SAVE PPAR
37281
37282C...Interface to PDFLIB.
37283 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
37284 SAVE /LW50513/
37285 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
37286 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
37287 CHARACTER*20 PARM(20)
37288 DATA VALUE/20*0D0/,PARM/20*' '/
37289
37290C...Data related to Schuler-Sjostrand photon distributions.
37291 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
37292
37293C...Valence PDF momentum integral parametrizations PER PARTON!
37294 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
37295 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
37296 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
37297 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
37298
37299C...Reset parton distributions.
37300 MINT(92)=0
37301 DO 100 KFL=-25,25
37302 XPQ(KFL)=0D0
37303 100 CONTINUE
37304 DO 110 KFL=-6,6
37305 XPVAL(KFL)=0D0
37306 110 CONTINUE
37307
37308C...Check x and particle species.
37309 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37310 WRITE(MSTU(11),5000) X
37311 GOTO 9999
37312 ENDIF
37313 KFA=IABS(KF)
37314 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
37315 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
37316 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
37317 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
37318 &KFA.NE.310.AND.KFA.NE.130) THEN
37319 WRITE(MSTU(11),5100) KF
37320 GOTO 9999
37321 ENDIF
37322
37323C...Electron (or muon or tau) parton distribution call.
37324 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
37325 CALL PYPDEL(KFA,X,Q2,XPEL)
37326 DO 120 KFL=-25,25
37327 XPQ(KFL)=XPEL(KFL)
37328 120 CONTINUE
37329
37330C...Photon parton distribution call (VDM+anomalous).
37331 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
37332 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
37333 CALL PYPDGA(X,Q2,XPGA)
37334 DO 130 KFL=-6,6
37335 XPQ(KFL)=XPGA(KFL)
37336 130 CONTINUE
37337 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37338 XPVAL(1)=XPVU/4D0
37339 XPVAL(2)=XPVU
37340 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37341 XPVAL(4)=MIN(XPQ(4),XPVU)
37342 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37343 XPVAL(-1)=XPVAL(1)
37344 XPVAL(-2)=XPVAL(2)
37345 XPVAL(-3)=XPVAL(3)
37346 XPVAL(-4)=XPVAL(4)
37347 XPVAL(-5)=XPVAL(5)
37348 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37349 Q2MX=Q2
37350 P2MX=0.36D0
37351 IF(MSTP(55).GE.7) P2MX=4.0D0
37352 IF(MSTP(57).EQ.0) Q2MX=P2MX
37353 P2=0D0
37354 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37355 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37356 DO 140 KFL=-6,6
37357 XPQ(KFL)=XPGA(KFL)
37358 XPVAL(KFL)=VXPDGM(KFL)
37359 140 CONTINUE
37360 VINT(231)=P2MX
37361 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37362 Q2MX=Q2
37363 P2MX=0.36D0
37364 IF(MSTP(55).GE.11) P2MX=4.0D0
37365 IF(MSTP(57).EQ.0) Q2MX=P2MX
37366 P2=0D0
37367 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37368 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37369 DO 150 KFL=-6,6
37370 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37371 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37372 150 CONTINUE
37373 VINT(231)=P2MX
37374 ELSEIF(MSTP(56).EQ.2) THEN
37375C...Call PDFLIB parton distributions.
37376 PARM(1)='NPTYPE'
37377 VALUE(1)=3
37378 PARM(2)='NGROUP'
37379 VALUE(2)=MSTP(55)/1000
37380 PARM(3)='NSET'
37381 VALUE(3)=MOD(MSTP(55),1000)
37382 IF(MINT(93).NE.3000000+MSTP(55)) THEN
257b7092 37383 CALL PDFSET_ALICE(PARM,VALUE)
b527e4b2 37384 MINT(93)=3000000+MSTP(55)
37385 ENDIF
37386 XX=X
37387 QQ2=MAX(0D0,Q2MIN,Q2)
37388 IF(MSTP(57).EQ.0) QQ2=Q2MIN
37389 P2=0D0
37390 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37391 IP2=MSTP(60)
37392 IF(MSTP(55).EQ.5004) THEN
37393 IF(5D0*P2.LT.QQ2.AND.
37394 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
37395 & P2.GE.0D0.AND.P2.LT.10D0.AND.
37396 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
37397 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37398 & BOT,TOP,GLU)
37399 ELSE
37400 UPV=0D0
37401 DNV=0D0
37402 USEA=0D0
37403 DSEA=0D0
37404 STR=0D0
37405 CHM=0D0
37406 BOT=0D0
37407 TOP=0D0
37408 GLU=0D0
37409 ENDIF
37410 ELSE
37411 IF(P2.LT.QQ2) THEN
37412 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37413 & BOT,TOP,GLU)
37414 ELSE
37415 UPV=0D0
37416 DNV=0D0
37417 USEA=0D0
37418 DSEA=0D0
37419 STR=0D0
37420 CHM=0D0
37421 BOT=0D0
37422 TOP=0D0
37423 GLU=0D0
37424 ENDIF
37425 ENDIF
37426 VINT(231)=Q2MIN
37427 XPQ(0)=GLU
37428 XPQ(1)=DNV
37429 XPQ(-1)=DNV
37430 XPQ(2)=UPV
37431 XPQ(-2)=UPV
37432 XPQ(3)=STR
37433 XPQ(-3)=STR
37434 XPQ(4)=CHM
37435 XPQ(-4)=CHM
37436 XPQ(5)=BOT
37437 XPQ(-5)=BOT
37438 XPQ(6)=TOP
37439 XPQ(-6)=TOP
37440 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37441 XPVAL(1)=XPVU/4D0
37442 XPVAL(2)=XPVU
37443 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37444 XPVAL(4)=MIN(XPQ(4),XPVU)
37445 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37446 XPVAL(-1)=XPVAL(1)
37447 XPVAL(-2)=XPVAL(2)
37448 XPVAL(-3)=XPVAL(3)
37449 XPVAL(-4)=XPVAL(4)
37450 XPVAL(-5)=XPVAL(5)
37451 ELSE
37452 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
37453 ENDIF
37454
37455C...Pion/gammaVDM parton distribution call.
37456 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
37457 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37458 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
37459 & MSTP(55).LE.12) THEN
37460 ISET=1+MOD(MSTP(55)-1,4)
37461 Q2MX=Q2
37462 P2MX=0.36D0
37463 IF(ISET.GE.3) P2MX=4.0D0
37464 IF(MSTP(57).EQ.0) Q2MX=P2MX
37465 P2=0D0
37466 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37467 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37468 DO 160 KFL=-6,6
37469 XPQ(KFL)=XPVMD(KFL)
37470 XPVAL(KFL)=VXPVMD(KFL)
37471 160 CONTINUE
37472 VINT(231)=P2MX
37473 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
37474 CALL PYPDPI(X,Q2,XPPI)
37475 DO 170 KFL=-6,6
37476 XPQ(KFL)=XPPI(KFL)
37477 170 CONTINUE
37478 XPVAL(2)=XPQ(2)-XPQ(-2)
37479 XPVAL(-1)=XPQ(-1)-XPQ(1)
37480 ELSEIF(MSTP(54).EQ.2) THEN
37481C...Call PDFLIB parton distributions.
37482 PARM(1)='NPTYPE'
37483 VALUE(1)=2
37484 PARM(2)='NGROUP'
37485 VALUE(2)=MSTP(53)/1000
37486 PARM(3)='NSET'
37487 VALUE(3)=MOD(MSTP(53),1000)
37488 IF(MINT(93).NE.2000000+MSTP(53)) THEN
257b7092 37489 CALL PDFSET_ALICE(PARM,VALUE)
b527e4b2 37490 MINT(93)=2000000+MSTP(53)
37491 ENDIF
37492 XX=X
37493 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37494 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37495 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37496 VINT(231)=Q2MIN
37497 XPQ(0)=GLU
37498 XPQ(1)=DSEA
37499 XPQ(-1)=UPV+DSEA
37500 XPQ(2)=UPV+USEA
37501 XPQ(-2)=USEA
37502 XPQ(3)=STR
37503 XPQ(-3)=STR
37504 XPQ(4)=CHM
37505 XPQ(-4)=CHM
37506 XPQ(5)=BOT
37507 XPQ(-5)=BOT
37508 XPQ(6)=TOP
37509 XPQ(-6)=TOP
37510 XPVAL(2)=UPV
37511 XPVAL(-1)=UPV
37512 ELSE
37513 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
37514 ENDIF
37515
37516C...Anomalous photon parton distribution call.
37517 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
37518 Q2MX=Q2
37519 P2MX=PARP(15)**2
37520 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
37521 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
37522 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
37523 IF(MSTP(57).EQ.0) Q2MX=P2MX
37524 P2=0D0
37525 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37526 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37527 DO 180 KFL=-6,6
37528 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
37529 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
37530 180 CONTINUE
37531 VINT(231)=P2MX
37532 ELSEIF(MSTP(56).EQ.1) THEN
37533 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
37534 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
37535 IF(MSTP(57).EQ.0) Q2MX=P2MX
37536 P2=0D0
37537 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37538 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37539 DO 190 KFL=-6,6
37540 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37541 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37542 190 CONTINUE
37543 VINT(231)=P2MX
37544 ELSEIF(MSTP(56).EQ.2) THEN
37545 IF(MSTP(57).EQ.0) Q2MX=P2MX
37546 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
37547 DO 200 KFL=-6,6
37548 XPQ(KFL)=XPGA(KFL)
37549 XPVAL(KFL)=VXPGA(KFL)
37550 200 CONTINUE
37551 VINT(231)=P2MX
37552 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
37553 IF(MSTP(57).EQ.0) Q2MX=P2MX
37554 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37555 DO 210 KFL=-6,6
37556 XPQ(KFL)=XPGA(KFL)
37557 XPVAL(KFL)=VXPGA(KFL)
37558 210 CONTINUE
37559 VINT(231)=P2MX
37560 ELSE
37561 220 RKF=11D0*PYR(0)
37562 KFR=1
37563 IF(RKF.GT.1D0) KFR=2
37564 IF(RKF.GT.5D0) KFR=3
37565 IF(RKF.GT.6D0) KFR=4
37566 IF(RKF.GT.10D0) KFR=5
37567 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
37568 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
37569 IF(MSTP(57).EQ.0) Q2MX=P2MX
37570 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37571 DO 230 KFL=-6,6
37572 XPQ(KFL)=XPGA(KFL)
37573 XPVAL(KFL)=VXPGA(KFL)
37574 230 CONTINUE
37575 VINT(231)=P2MX
37576 ENDIF
37577
37578C...Proton parton distribution call.
37579 ELSE
37580 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
37581 CALL PYPDPR(X,Q2,XPPR)
37582 DO 240 KFL=-6,6
37583 XPQ(KFL)=XPPR(KFL)
37584 240 CONTINUE
37585 XPVAL(1)=XPQ(1)-XPQ(-1)
37586 XPVAL(2)=XPQ(2)-XPQ(-2)
37587 ELSEIF(MSTP(52).EQ.2) THEN
37588C...Call PDFLIB parton distributions.
37589 PARM(1)='NPTYPE'
37590 VALUE(1)=1
37591 PARM(2)='NGROUP'
37592 VALUE(2)=MSTP(51)/1000
37593 PARM(3)='NSET'
37594 VALUE(3)=MOD(MSTP(51),1000)
37595 IF(MINT(93).NE.1000000+MSTP(51)) THEN
257b7092 37596 CALL PDFSET_ALICE(PARM,VALUE)
b527e4b2 37597 MINT(93)=1000000+MSTP(51)
37598 ENDIF
37599 XX=X
37600 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37601 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37602 CALL STRUCTM_ALICE
37603 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37604 VINT(231)=Q2MIN
37605 XPQ(0)=GLU
37606 XPQ(1)=DNV+DSEA
37607 XPQ(-1)=DSEA
37608 XPQ(2)=UPV+USEA
37609 XPQ(-2)=USEA
37610 XPQ(3)=STR
37611 XPQ(-3)=STR
37612 XPQ(4)=CHM
37613 XPQ(-4)=CHM
37614 XPQ(5)=BOT
37615 XPQ(-5)=BOT
37616 XPQ(6)=TOP
37617 XPQ(-6)=TOP
37618 XPVAL(1)=DNV
37619 XPVAL(2)=UPV
37620 ELSE
37621 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
37622 ENDIF
37623 ENDIF
37624
37625C...Isospin average for pi0/gammaVDM.
37626 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37627 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
37628 XPV=XPQ(2)-XPQ(1)
37629 XPQ(2)=XPQ(1)
37630 XPQ(-2)=XPQ(-1)
37631 ELSE
37632 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37633 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37634 XPQ(2)=XPS
37635 XPQ(-1)=XPS
37636 ENDIF
37637 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
37638 & XPVAL(3)+XPVAL(4)+XPVAL(5)
37639 DO 250 KFL=-6,6
37640 XPVAL(KFL)=0D0
37641 250 CONTINUE
37642 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
37643 XPQ(1)=XPQ(1)+0.2D0*XPV
37644 XPQ(2)=XPQ(2)+0.8D0*XPV
37645 XPVAL(1)=0.2D0*XPVL
37646 XPVAL(2)=0.8D0*XPVL
37647 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
37648 XPQ(3)=XPQ(3)+XPV
37649 XPVAL(3)=XPVL
37650 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
37651 XPQ(4)=XPQ(4)+XPV
37652 XPVAL(4)=XPVL
37653 IF(MSTP(55).GE.9) THEN
37654 DO 260 KFL=-6,6
37655 XPQ(KFL)=0D0
37656 260 CONTINUE
37657 ENDIF
37658 ELSE
37659 XPQ(1)=XPQ(1)+0.5D0*XPV
37660 XPQ(2)=XPQ(2)+0.5D0*XPV
37661 XPVAL(1)=0.5D0*XPVL
37662 XPVAL(2)=0.5D0*XPVL
37663 ENDIF
37664 DO 270 KFL=1,6
37665 XPQ(-KFL)=XPQ(KFL)
37666 XPVAL(-KFL)=XPVAL(KFL)
37667 270 CONTINUE
37668
37669C...Rescale for gammaVDM by effective gamma -> rho coupling.
37670C+++Do not rescale?
37671 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
37672 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
37673 DO 280 KFL=-6,6
37674 XPQ(KFL)=VINT(281)*XPQ(KFL)
37675 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
37676 280 CONTINUE
37677 VINT(232)=VINT(281)*XPV
37678 ENDIF
37679
37680C...Simple recipes for kaons.
37681 ELSEIF(KFA.EQ.321) THEN
37682 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
37683 XPQ(-1)=XPQ(1)
37684 XPVAL(-3)=XPVAL(-1)
37685 XPVAL(-1)=0D0
37686 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
37687 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37688 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37689 XPQ(2)=XPS
37690 XPQ(-1)=XPS
37691 XPQ(1)=XPQ(1)+0.5D0*XPV
37692 XPQ(-1)=XPQ(-1)+0.5D0*XPV
37693 XPQ(3)=XPQ(3)+0.5D0*XPV
37694 XPQ(-3)=XPQ(-3)+0.5D0*XPV
37695 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
37696 XPVAL(2)=0D0
37697 XPVAL(-1)=0D0
37698 XPVAL(1)=0.5D0*XPV
37699 XPVAL(-1)=0.5D0*XPV
37700 XPVAL(3)=0.5D0*XPV
37701 XPVAL(-3)=0.5D0*XPV
37702
37703C...Isospin conjugation for neutron.
37704 ELSEIF(KFA.EQ.2112) THEN
37705 XPSV=XPQ(1)
37706 XPQ(1)=XPQ(2)
37707 XPQ(2)=XPSV
37708 XPSV=XPQ(-1)
37709 XPQ(-1)=XPQ(-2)
37710 XPQ(-2)=XPSV
37711 XPSV=XPVAL(1)
37712 XPVAL(1)=XPVAL(2)
37713 XPVAL(2)=XPSV
37714
37715C...Simple recipes for hyperon (average valence parton distribution).
37716 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
37717 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
37718 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
37719 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
37720 XPQ(1)=XPS
37721 XPQ(2)=XPS
37722 XPQ(-1)=XPS
37723 XPQ(-2)=XPS
37724 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
37725 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
37726 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
37727 XPV=(XPVAL(1)+XPVAL(2))/3D0
37728 XPVAL(1)=0D0
37729 XPVAL(2)=0D0
37730 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
37731 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
37732 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
37733 ENDIF
37734
37735C...Charge conjugation for antiparticle.
37736 IF(KF.LT.0) THEN
37737 DO 290 KFL=1,25
37738 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
37739 XPSV=XPQ(KFL)
37740 XPQ(KFL)=XPQ(-KFL)
37741 XPQ(-KFL)=XPSV
37742 290 CONTINUE
37743 DO 300 KFL=1,6
37744 XPSV=XPVAL(KFL)
37745 XPVAL(KFL)=XPVAL(-KFL)
37746 XPVAL(-KFL)=XPSV
37747 300 CONTINUE
37748 ENDIF
37749
37750C...MULTIPLE INTERACTIONS - PDF RESHAPING.
37751C...Set side.
37752 JS=MINT(30)
37753C...Only reshape PDFs for the non-first interactions;
37754C...But need valence/sea separation already from first interaction.
37755 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
37756 KFVSEL=KFIVAL(JS,1)
37757C...If valence quark kicked out of pi0 or gamma then that decides
37758C...whether we should consider state as d dbar, u ubar, s sbar, etc.
37759 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
37760 XPVL=0D0
37761 DO 310 KFL=1,6
37762 XPVL=XPVL+XPVAL(KFL)
37763 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
37764 XPVAL(KFL)=0D0
37765 310 CONTINUE
37766 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
37767 XPVAL(IABS(KFVSEL))=XPVL
37768 DO 320 KFL=1,6
37769 XPQ(-KFL)=XPQ(KFL)
37770 XPVAL(-KFL)=XPVAL(KFL)
37771 320 CONTINUE
37772
37773C...If valence quark kicked out of K0S or K0S then that decides whether
37774C...we should consider state as d sbar or s dbar.
37775 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
37776 KFS=1
37777 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
37778 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37779 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37780 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37781 XPVAL(-KFS)=0D0
37782 KFS=-3*KFS
37783 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37784 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37785 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37786 XPVAL(-KFS)=0D0
37787 ENDIF
37788
37789C...XPQ distributions are nominal for a (signed) beam particle
37790C...of KF type, with 1-Sum(x_prev) rescaled to 1.
37791 CMPFAC=1D0
37792 NRESC=0
37793 345 NRESC=NRESC+1
37794 PVCTOT(JS,-1)=0D0
37795 PVCTOT(JS, 0)=0D0
37796 PVCTOT(JS, 1)=0D0
37797 DO 350 IFL=-6,6
37798 IF(IFL.EQ.0) GOTO 350
37799
37800C...Count up number of original IFL valence quarks.
37801 IVORG=0
37802 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
37803 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
37804 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
37805C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
37806C...bookkeep as if d dbar (for total momentum sum in valence sector).
37807 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
37808C...Count down number of remaining IFL valence quarks. Skip current
37809C...interaction initiator.
37810 IVREM=IVORG
37811 DO 330 I1=1,NMI(JS)
37812 IF (I1.EQ.MINT(36)) GOTO 330
37813 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
37814 & IVREM=IVREM-1
37815 330 CONTINUE
37816
37817C...Separate out original VALENCE and SEA content.
37818 VAL=XPVAL(IFL)
37819 SEA=MAX(0D0,XPQ(IFL)-VAL)
37820 XPSVC(IFL,0)=VAL
37821 XPSVC(IFL,-1)=SEA
37822
37823C...Rescale valence content if changed.
37824 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
37825 & (VAL*IVREM)/IVORG
37826
37827C...Momentum integrals of original and removed valence quarks.
37828 IF(IVORG.NE.0) THEN
37829C...For p/n/pbar/nbar beams can split into d_val and u_val.
37830C...Isospin conjugation for neutrons
37831 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
37832 IAFLP=IABS(IFL)
37833 IF (KFA.EQ.2112) IAFLP=3-IAFLP
37834 VPAVG=PAVG(IAFLP,Q2)
37835C...For other baryons average d_val and u_val, like for PDFs.
37836 ELSEIF(KFA.GT.1000) THEN
37837 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
37838C...For mesons and photon average d_val and u_val and scale by 3/2.
37839C...Very crude, especially for photon.
37840 ELSE
37841 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
37842 ENDIF
37843 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
37844 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
37845 ENDIF
37846
37847C...Now add companions (at X with partner having been at Z=XASSOC).
37848C...NOTE: due to the assumed simple x scaling, the partner was at what
37849C...corresponds to a higher Z than XASSOC, if there were intermediate
37850C...scatterings. Nothing done about that for the moment.
37851 DO 340 IVC=1,NVC(JS,IFL)
37852C...Skip companions that have been kicked out
37853 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
37854 XPSVC(IFL,IVC)=0D0
37855 GOTO 340
37856 ELSE
37857C...Momentum fraction of the partner quark.
37858C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
37859 XS=XASSOC(JS,IFL,IVC)
37860 XREM=VINT(142+JS)
37861 YS=XS/(XREM+XS)
37862C...Momentum fraction of the companion quark.
37863C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
37864 Y=X*(1D0-YS)
37865 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
37866C...Add to momentum sum, with rescaling compensation factor.
37867 XCFAC=(XREM+XS)/XREM*CMPFAC
37868 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
37869 ENDIF
37870 340 CONTINUE
37871 350 CONTINUE
37872
37873C...Wait until all flavours treated, then rescale seas and gluon.
37874 XPSVC(0,-1)=XPQ(0)
37875 XPSVC(0,0)=0D0
37876 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
37877 IF (RSFAC.LE.0D0) THEN
37878C...First calculate factor needed to exactly restore pz cons.
37879 IF (NRESC.EQ.1) CMPFAC =
37880 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
37881C...Add a bit of headroom
37882 CMPFAC=0.99*CMPFAC
37883C...Try a few times if more headroom is needed, then print error message.
37884 IF (NRESC.LE.10) GOTO 345
37885 CALL PYERRM(15,
37886 & '(PYPDFU:) Negative reshaping factor persists!')
37887 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
37888 RSFAC=0D0
37889 ENDIF
37890 DO 370 IFL=-6,6
37891 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
37892C...Also store resulting distributions in XPQ
37893 XPQ(IFL)=0D0
37894 DO 360 ISVC=-1,NVC(JS,IFL)
37895 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
37896 360 CONTINUE
37897 370 CONTINUE
37898C...Save companion reweighting factor for PYPTIS.
37899 VINT(140)=CMPFAC
37900 ENDIF
37901
37902
37903C...Allow gluon also in position 21.
37904 XPQ(21)=XPQ(0)
37905
37906C...Check positivity and reset above maximum allowed flavour.
37907 DO 380 KFL=-25,25
37908 XPQ(KFL)=MAX(0D0,XPQ(KFL))
37909 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
37910 380 CONTINUE
37911
37912C...Formats for error printouts.
37913 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37914 5100 FORMAT(' Error: illegal particle code for parton distribution;',
37915 &' KF =',I5)
37916 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
37917 &3I5)
37918 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
37919 & ' Removed valence momentum fraction : ',F6.3/
37920 & ' Added companion momentum fraction : ',F6.3/
37921 & ' Resulting rescale factor : ',F6.3)
37922
37923C...Reset side pointer and return
37924 9999 MINT(30)=0
37925
37926 RETURN
37927 END
37928
37929C*********************************************************************
37930
37931C...PYPDFL
37932C...Gives proton parton distribution at small x and/or Q^2 according to
37933C...correct limiting behaviour.
37934
37935 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37936
37937C...Double precision and integer declarations.
37938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37939 IMPLICIT INTEGER(I-N)
37940 INTEGER PYK,PYCHGE,PYCOMP
37941C...Commonblocks.
37942 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37943 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37944 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37945 COMMON/PYINT1/MINT(400),VINT(400)
37946 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37947C...Local arrays.
37948 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37949 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37950
37951C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37952 MINT(92)=0
37953 KFA=IABS(KF)
37954 IACC=0
37955 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37956 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37957 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37958 IF(IACC.EQ.0) THEN
37959 CALL PYPDFU(KF,X,Q2,XPQ)
37960 RETURN
37961 ENDIF
37962
37963C...Reset. Check x.
37964 DO 100 KFL=-25,25
37965 XPQ(KFL)=0D0
37966 100 CONTINUE
37967 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37968 WRITE(MSTU(11),5000) X
37969 RETURN
37970 ENDIF
37971
37972C...Define valence content.
37973 KFC=KF
37974 NV1=2
37975 NV2=1
37976 IF(KF.EQ.2212) THEN
37977 KFV1=2
37978 KFV2=1
37979 ELSEIF(KF.EQ.-2212) THEN
37980 KFV1=-2
37981 KFV2=-1
37982 ELSEIF(KF.EQ.2112) THEN
37983 KFV1=1
37984 KFV2=2
37985 ELSEIF(KF.EQ.-2112) THEN
37986 KFV1=-1
37987 KFV2=-2
37988 ELSEIF(KF.EQ.211) THEN
37989 NV1=1
37990 KFV1=2
37991 KFV2=-1
37992 ELSEIF(KF.EQ.-211) THEN
37993 NV1=1
37994 KFV1=-2
37995 KFV2=1
37996 ELSEIF(MINT(105).LE.223) THEN
37997 KFV1=1
37998 WTV1=0.2D0
37999 KFV2=2
38000 WTV2=0.8D0
38001 ELSEIF(MINT(105).EQ.333) THEN
38002 KFV1=3
38003 WTV1=1.0D0
38004 KFV2=1
38005 WTV2=0.0D0
38006 ELSEIF(MINT(105).EQ.443) THEN
38007 KFV1=4
38008 WTV1=1.0D0
38009 KFV2=1
38010 WTV2=0.0D0
38011 ENDIF
38012
38013C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38014 MINT30=MINT(30)
38015 CALL PYPDFU(KFC,X,Q2,XPA)
38016 Q2MN=MAX(3D0,VINT(231))
38017 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38018 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38019
38020C...Large Q2 and large x: naive call is enough.
38021 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38022 DO 110 KFL=-25,25
38023 XPQ(KFL)=XPA(KFL)
38024 110 CONTINUE
38025 MINT(92)=1
38026
38027C...Small Q2 and large x: dampen boundary value.
38028 ELSEIF(X.GT.XMN) THEN
38029
38030C...Evaluate at boundary and define dampening factors.
38031 MINT(30)=MINT30
38032 CALL PYPDFU(KFC,X,Q2MN,XPA)
38033 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38034 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38035
38036C...Separate valence and sea parts of parton distribution.
38037 IF(KFA.NE.22) THEN
38038 XFV1=XPA(KFV1)-XPA(-KFV1)
38039 XPA(KFV1)=XPA(-KFV1)
38040 XFV2=XPA(KFV2)-XPA(-KFV2)
38041 XPA(KFV2)=XPA(-KFV2)
38042 ELSE
38043 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38044 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38045 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38046 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38047 ENDIF
38048
38049C...Dampen valence and sea separately. Put back together.
38050 DO 120 KFL=-25,25
38051 XPQ(KFL)=FS*XPA(KFL)
38052 120 CONTINUE
38053 IF(KFA.NE.22) THEN
38054 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38055 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38056 ELSE
38057 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38058 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38059 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38060 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38061 ENDIF
38062 MINT(92)=2
38063
38064C...Large Q2 and small x: interpolate behaviour.
38065 ELSEIF(Q2.GT.Q2MN) THEN
38066
38067C...Evaluate at extremes and define coefficients for interpolation.
38068 MINT(30)=MINT30
38069 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38070 VI232A=VINT(232)
38071 MINT(30)=MINT30
38072 CALL PYPDFU(KFC,X,Q2B,XPB)
38073 VI232B=VINT(232)
38074 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38075 FVA=(X/XMN)**0.45D0*FLA
38076 FSA=(X/XMN)**(-0.08D0)*FLA
38077 FB=1D0-FLA
38078
38079C...Separate valence and sea parts of parton distribution.
38080 IF(KFA.NE.22) THEN
38081 XFVA1=XPA(KFV1)-XPA(-KFV1)
38082 XPA(KFV1)=XPA(-KFV1)
38083 XFVA2=XPA(KFV2)-XPA(-KFV2)
38084 XPA(KFV2)=XPA(-KFV2)
38085 XFVB1=XPB(KFV1)-XPB(-KFV1)
38086 XPB(KFV1)=XPB(-KFV1)
38087 XFVB2=XPB(KFV2)-XPB(-KFV2)
38088 XPB(KFV2)=XPB(-KFV2)
38089 ELSE
38090 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38091 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38092 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38093 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38094 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38095 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38096 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38097 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
38098 ENDIF
38099
38100C...Interpolate for valence and sea. Put back together.
38101 DO 130 KFL=-25,25
38102 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
38103 130 CONTINUE
38104 IF(KFA.NE.22) THEN
38105 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
38106 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
38107 ELSE
38108 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38109 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38110 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38111 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38112 ENDIF
38113 MINT(92)=3
38114
38115C...Small Q2 and small x: dampen boundary value and add term.
38116 ELSE
38117
38118C...Evaluate at boundary and define dampening factors.
38119 MINT(30)=MINT30
38120 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38121 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
38122 FA=1D0-FB
38123 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
38124 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
38125 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
38126 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
38127 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
38128 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
38129
38130C...Separate valence and sea parts of parton distribution.
38131 IF(KFA.NE.22) THEN
38132 XFV1=XPA(KFV1)-XPA(-KFV1)
38133 XPA(KFV1)=XPA(-KFV1)
38134 XFV2=XPA(KFV2)-XPA(-KFV2)
38135 XPA(KFV2)=XPA(-KFV2)
38136 ELSE
38137 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38138 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38139 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38140 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38141 ENDIF
38142
38143C...Dampen valence and sea separately. Add constant terms.
38144C...Put back together.
38145 DO 140 KFL=-25,25
38146 XPQ(KFL)=FSA*XPA(KFL)
38147 140 CONTINUE
38148 IF(KFA.NE.22) THEN
38149 DO 150 KFL=-3,3
38150 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
38151 150 CONTINUE
38152 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
38153 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
38154 ELSE
38155 DO 160 KFL=-3,3
38156 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
38157 160 CONTINUE
38158 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38159 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38160 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38161 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38162 ENDIF
38163 XPQ(21)=XPQ(0)
38164 MINT(92)=4
38165 ENDIF
38166
38167C...Format for error printout.
38168 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38169
38170 RETURN
38171 END
38172
38173C*********************************************************************
38174
38175C...PYPDEL
38176C...Gives electron (or muon, or tau) parton distribution.
38177
38178 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
38179
38180C...Double precision and integer declarations.
38181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38182 IMPLICIT INTEGER(I-N)
38183 INTEGER PYK,PYCHGE,PYCOMP
38184C...Commonblocks.
38185 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38186 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38188 COMMON/PYINT1/MINT(400),VINT(400)
38189 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38190C...Local arrays.
38191 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
38192
38193C...Interface to PDFLIB.
38194 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
38195 SAVE /LW50513/
38196 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38197 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38198 CHARACTER*20 PARM(20)
38199 DATA VALUE/20*0D0/,PARM/20*' '/
38200
38201C...Some common constants.
38202 DO 100 KFL=-25,25
38203 XPEL(KFL)=0D0
38204 100 CONTINUE
38205 AEM=PARU(101)
38206 PME=PMAS(11,1)
38207 IF(KFA.EQ.13) PME=PMAS(13,1)
38208 IF(KFA.EQ.15) PME=PMAS(15,1)
38209 XL=LOG(MAX(1D-10,X))
38210 X1L=LOG(MAX(1D-10,1D0-X))
38211 HLE=LOG(MAX(3D0,Q2/PME**2))
38212 HBE2=(AEM/PARU(1))*(HLE-1D0)
38213
38214C...Electron inside electron, see R. Kleiss et al., in Z physics at
38215C...LEP 1, CERN 89-08, p. 34
38216 IF(MSTP(59).LE.1) THEN
38217 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
38218 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
38219 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
38220 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
38221 & 4D0*XL/(1D0-X)-5D0-X)
38222 ELSE
38223 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
38224 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
38225 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
38226 ENDIF
38227C...Zero distribution for very large x and rescale it for intermediate.
38228 IF(X.GT.1D0-1D-10) THEN
38229 HEE=0D0
38230 ELSEIF(X.GT.1D0-1D-7) THEN
38231 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
38232 ENDIF
38233 XPEL(KFA)=X*HEE
38234
38235C...Photon and (transverse) W- inside electron.
38236 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
38237 IF(MSTP(13).LE.1) THEN
38238 HLG=HLE
38239 ELSE
38240 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
38241 ENDIF
38242 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
38243 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
38244 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
38245
38246C...Electron or positron inside photon inside electron.
38247 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
38248 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
38249 & 2D0*X*(1D0+X)*XL)
38250 XPEL(11)=XPEL(11)+XFSEA
38251 XPEL(-11)=XFSEA
38252
38253C...Initialize PDFLIB photon parton distributions.
38254 IF(MSTP(56).EQ.2) THEN
38255 PARM(1)='NPTYPE'
38256 VALUE(1)=3
38257 PARM(2)='NGROUP'
38258 VALUE(2)=MSTP(55)/1000
38259 PARM(3)='NSET'
38260 VALUE(3)=MOD(MSTP(55),1000)
38261 IF(MINT(93).NE.3000000+MSTP(55)) THEN
257b7092 38262 CALL PDFSET_ALICE(PARM,VALUE)
b527e4b2 38263 MINT(93)=3000000+MSTP(55)
38264 ENDIF
38265 ENDIF
38266
38267C...Quarks and gluons inside photon inside electron:
38268C...numerical convolution required.
38269 DO 110 KFL=0,6
38270 SXP(KFL)=0D0
38271 110 CONTINUE
38272 SUMXPP=0D0
38273 ITER=-1
38274 120 ITER=ITER+1
38275 SUMXP=SUMXPP
38276 NSTP=2**(ITER-1)
38277 IF(ITER.EQ.0) NSTP=2
38278 DO 130 KFL=0,6
38279 SXP(KFL)=0.5D0*SXP(KFL)
38280 130 CONTINUE
38281 WTSTP=0.5D0/NSTP
38282 IF(ITER.EQ.0) WTSTP=0.5D0
38283C...Pick grid of x_{gamma} values logarithmically even.
38284 DO 150 ISTP=1,NSTP
38285 IF(ITER.EQ.0) THEN
38286 XLE=XL*(ISTP-1)
38287 ELSE
38288 XLE=XL*(ISTP-0.5D0)/NSTP
38289 ENDIF
38290 XE=MIN(1D0-1D-10,EXP(XLE))
38291 XG=MIN(1D0-1D-10,X/XE)
38292C...Evaluate photon inside electron parton distribution for convolution.
38293 XPGP=1D0+(1D0-XE)**2
38294 IF(MSTP(13).LE.1) THEN
38295 XPGP=XPGP*HLE
38296 ELSE
38297 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
38298 ENDIF
38299C...Evaluate photon parton distributions for convolution.
38300 IF(MSTP(56).EQ.1) THEN
38301 IF(MSTP(55).EQ.1) THEN
38302 CALL PYPDGA(XG,Q2,XPGA)
38303 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38304 Q2MX=Q2
38305 P2MX=0.36D0
38306 IF(MSTP(55).GE.7) P2MX=4.0D0
38307 IF(MSTP(57).EQ.0) Q2MX=P2MX
38308 P2=0D0
38309 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38310 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38311 VINT(231)=P2MX
38312 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38313 Q2MX=Q2
38314 P2MX=0.36D0
38315 IF(MSTP(55).GE.11) P2MX=4.0D0
38316 IF(MSTP(57).EQ.0) Q2MX=P2MX
38317 P2=0D0
38318 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38319 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38320 VINT(231)=P2MX
38321 ENDIF
38322 DO 140 KFL=0,5
38323 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
38324 140 CONTINUE
38325 ELSEIF(MSTP(56).EQ.2) THEN
38326C...Call PDFLIB parton distributions.
38327 XX=XG
38328 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38329 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38330 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38331 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
38332 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
38333 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
38334 SXP(3)=SXP(3)+WTSTP*XPGP*STR
38335 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
38336 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
38337 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
38338 ENDIF
38339 150 CONTINUE
38340 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
38341 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
38342 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
38343
38344C...Put convolution into output arrays.
38345 FCONV=AEMP*(-XL)
38346 XPEL(0)=FCONV*SXP(0)
38347 DO 160 KFL=1,6
38348 XPEL(KFL)=FCONV*SXP(KFL)
38349 XPEL(-KFL)=XPEL(KFL)
38350 160 CONTINUE
38351 ENDIF
38352
38353 RETURN
38354 END
38355
38356C*********************************************************************
38357
38358C...PYPDGA
38359C...Gives photon parton distribution.
38360
38361 SUBROUTINE PYPDGA(X,Q2,XPGA)
38362
38363C...Double precision and integer declarations.
38364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38365 IMPLICIT INTEGER(I-N)
38366 INTEGER PYK,PYCHGE,PYCOMP
38367C...Commonblocks.
38368 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38369 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38370 COMMON/PYINT1/MINT(400),VINT(400)
38371 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38372C...Local arrays.
38373 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
38374 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
38375 &DGCS(4,3),DGDS(4,3),DGES(4,3)
38376
38377C...The following data lines are coefficients needed in the
38378C...Drees and Grassie photon parton distribution parametrization.
38379 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
38380 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
38381 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
38382 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
38383 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
38384 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
38385 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
38386 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
38387 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
38388 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
38389 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
38390 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
38391 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
38392 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
38393 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
38394 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
38395 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
38396 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
38397 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
38398 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
38399 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
38400 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
38401 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
38402 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
38403 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
38404 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
38405
38406C...Photon parton distribution from Drees and Grassie.
38407C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
38408 DO 100 KFL=-6,6
38409 XPGA(KFL)=0D0
38410 100 CONTINUE
38411 VINT(231)=1D0
38412 IF(MSTP(57).LE.0) THEN
38413 T=LOG(1D0/0.16D0)
38414 ELSE
38415 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
38416 ENDIF
38417 X1=1D0-X
38418 NF=3
38419 IF(Q2.GT.25D0) NF=4
38420 IF(Q2.GT.300D0) NF=5
38421 NFE=NF-2
38422 AEM=PARU(101)
38423
38424C...Evaluate gluon content.
38425 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
38426 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
38427 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
38428 XPGL=DGA*X**DGB*X1**DGC
38429
38430C...Evaluate up- and down-type quark content.
38431 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
38432 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
38433 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
38434 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
38435 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
38436 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38437 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
38438 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
38439 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
38440 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
38441 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
38442 DGF=9D0
38443 IF(NF.EQ.4) DGF=10D0
38444 IF(NF.EQ.5) DGF=55D0/6D0
38445 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38446 IF(NF.LE.3) THEN
38447 XPQU=(XPQS+9D0*XPQN)/6D0
38448 XPQD=(XPQS-4.5D0*XPQN)/6D0
38449 ELSEIF(NF.EQ.4) THEN
38450 XPQU=(XPQS+6D0*XPQN)/8D0
38451 XPQD=(XPQS-6D0*XPQN)/8D0
38452 ELSE
38453 XPQU=(XPQS+7.5D0*XPQN)/10D0
38454 XPQD=(XPQS-5D0*XPQN)/10D0
38455 ENDIF
38456
38457C...Put into output arrays.
38458 XPGA(0)=AEM*XPGL
38459 XPGA(1)=AEM*XPQD
38460 XPGA(2)=AEM*XPQU
38461 XPGA(3)=AEM*XPQD
38462 IF(NF.GE.4) XPGA(4)=AEM*XPQU
38463 IF(NF.GE.5) XPGA(5)=AEM*XPQD
38464 DO 110 KFL=1,6
38465 XPGA(-KFL)=XPGA(KFL)
38466 110 CONTINUE
38467
38468 RETURN
38469 END
38470
38471C*********************************************************************
38472
38473C...PYGGAM
38474C...Constructs the F2 and parton distributions of the photon
38475C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
38476C...For F2, c and b are included by the Bethe-Heitler formula;
38477C...in the 'MSbar' scheme additionally a Cgamma term is added.
38478C...Contains the SaS sets 1D, 1M, 2D and 2M.
38479C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38480
38481 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
38482
38483C...Double precision and integer declarations.
38484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38485 IMPLICIT INTEGER(I-N)
38486 INTEGER PYK,PYCHGE,PYCOMP
38487C...Commonblocks.
38488 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38489 &XPDIR(-6:6)
38490 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38491 SAVE /PYINT8/,/PYINT9/
38492C...Local arrays.
38493 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
38494C...Charm and bottom masses (low to compensate for J/psi etc.).
38495 DATA PMC/1.3D0/, PMB/4.6D0/
38496C...alpha_em and alpha_em/(2*pi).
38497 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
38498C...Lambda value for 4 flavours.
38499 DATA ALAM/0.20D0/
38500C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
38501 DATA FRACU/0.8D0/
38502C...VMD couplings f_V**2/(4*pi).
38503 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
38504C...Masses for rho (=omega) and phi.
38505 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
38506C...Number of points in integration for IP2=1.
38507 DATA NSTEP/100/
38508
38509C...Reset output.
38510 F2GM=0D0
38511 DO 100 KFL=-6,6
38512 XPDFGM(KFL)=0D0
38513 XPVMD(KFL)=0D0
38514 XPANL(KFL)=0D0
38515 XPANH(KFL)=0D0
38516 XPBEH(KFL)=0D0
38517 XPDIR(KFL)=0D0
38518 VXPVMD(KFL)=0D0
38519 VXPANL(KFL)=0D0
38520 VXPANH(KFL)=0D0
38521 VXPDGM(KFL)=0D0
38522 100 CONTINUE
38523
38524C...Set Q0 cut-off parameter as function of set used.
38525 IF(ISET.LE.2) THEN
38526 Q0=0.6D0
38527 ELSE
38528 Q0=2D0
38529 ENDIF
38530 Q02=Q0**2
38531
38532C...Scale choice for off-shell photon; common factors.
38533 Q2A=Q2
38534 FACNOR=1D0
38535 IF(IP2.EQ.1) THEN
38536 P2MX=P2+Q02
38537 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38538 FACNOR=LOG(Q2/Q02)/NSTEP
38539 ELSEIF(IP2.EQ.2) THEN
38540 P2MX=MAX(P2,Q02)
38541 ELSEIF(IP2.EQ.3) THEN
38542 P2MX=P2+Q02
38543 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38544 ELSEIF(IP2.EQ.4) THEN
38545 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38546 & ((Q2+P2)*(Q02+P2)))
38547 ELSEIF(IP2.EQ.5) THEN
38548 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38549 & ((Q2+P2)*(Q02+P2)))
38550 P2MX=Q0*SQRT(P2MXA)
38551 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
38552 ELSEIF(IP2.EQ.6) THEN
38553 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38554 & ((Q2+P2)*(Q02+P2)))
38555 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38556 ELSE
38557 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38558 & ((Q2+P2)*(Q02+P2)))
38559 P2MX=Q0*SQRT(P2MXA)
38560 P2MXB=P2MX
38561 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38562 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
38563 IF(ABS(Q2-Q02).GT.1D-6) THEN
38564 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
38565 ELSEIF(P2.LT.Q02) THEN
38566 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
38567 ELSE
38568 FACNOR=1D0
38569 ENDIF
38570 ENDIF
38571
38572C...Call VMD parametrization for d quark and use to give rho, omega,
38573C...phi. Note dipole dampening for off-shell photon.
38574 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38575 XFVAL=VXPGA(1)
38576 XPGA(1)=XPGA(2)
38577 XPGA(-1)=XPGA(-2)
38578 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
38579 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
38580 DO 110 KFL=-5,5
38581 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
38582 110 CONTINUE
38583 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
38584 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
38585 XPVMD(3)=XPVMD(3)+FACS*XFVAL
38586 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
38587 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
38588 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
38589 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
38590 VXPVMD(2)=FRACU*FACUD*XFVAL
38591 VXPVMD(3)=FACS*XFVAL
38592 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
38593 VXPVMD(-2)=FRACU*FACUD*XFVAL
38594 VXPVMD(-3)=FACS*XFVAL
38595
38596 IF(IP2.NE.1) THEN
38597C...Anomalous parametrizations for different strategies
38598C...for off-shell photons; except full integration.
38599
38600C...Call anomalous parametrization for d + u + s.
38601 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38602 DO 120 KFL=-5,5
38603 XPANL(KFL)=FACNOR*XPGA(KFL)
38604 VXPANL(KFL)=FACNOR*VXPGA(KFL)
38605 120 CONTINUE
38606
38607C...Call anomalous parametrization for c and b.
38608 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38609 DO 130 KFL=-5,5
38610 XPANH(KFL)=FACNOR*XPGA(KFL)
38611 VXPANH(KFL)=FACNOR*VXPGA(KFL)
38612 130 CONTINUE
38613 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38614 DO 140 KFL=-5,5
38615 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
38616 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
38617 140 CONTINUE
38618
38619 ELSE
38620C...Special option: loop over flavours and integrate over k2.
38621 DO 170 KF=1,5
38622 DO 160 ISTEP=1,NSTEP
38623 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
38624 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
38625 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
38626 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
38627 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
38628 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
38629 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
38630 DO 150 KFL=-5,5
38631 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
38632 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
38633 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
38634 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
38635 150 CONTINUE
38636 160 CONTINUE
38637 170 CONTINUE
38638 ENDIF
38639
38640C...Call Bethe-Heitler term expression for charm and bottom.
38641 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
38642 XPBEH(4)=XPBH
38643 XPBEH(-4)=XPBH
38644 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
38645 XPBEH(5)=XPBH
38646 XPBEH(-5)=XPBH
38647
38648C...For MSbar subtraction call C^gamma term expression for d, u, s.
38649 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
38650 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
38651 DO 180 KFL=-5,5
38652 XPDIR(KFL)=XPGA(KFL)
38653 180 CONTINUE
38654 ENDIF
38655
38656C...Store result in output array.
38657 DO 190 KFL=-5,5
38658 CHSQ=1D0/9D0
38659 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
38660 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38661 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
38662 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
38663 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
38664 190 CONTINUE
38665
38666 RETURN
38667 END
38668
38669C*********************************************************************
38670
38671C...PYGVMD
38672C...Evaluates the VMD parton distributions of a photon,
38673C...evolved homogeneously from an initial scale P2 to Q2.
38674C...Does not include dipole suppression factor.
38675C...ISET is parton distribution set, see above;
38676C...additionally ISET=0 is used for the evolution of an anomalous photon
38677C...which branched at a scale P2 and then evolved homogeneously to Q2.
38678C...ALAM is the 4-flavour Lambda, which is automatically converted
38679C...to 3- and 5-flavour equivalents as needed.
38680C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38681
38682 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38683
38684C...Double precision and integer declarations.
38685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38686 IMPLICIT INTEGER(I-N)
38687 INTEGER PYK,PYCHGE,PYCOMP
38688C...Local arrays and data.
38689 DIMENSION XPGA(-6:6), VXPGA(-6:6)
38690 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38691
38692C...Reset output.
38693 DO 100 KFL=-6,6
38694 XPGA(KFL)=0D0
38695 VXPGA(KFL)=0D0
38696 100 CONTINUE
38697 KFA=IABS(KF)
38698
38699C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38700 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
38701 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
38702 P2EFF=MAX(P2,1.2D0*ALAM3**2)
38703 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38704 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38705 Q2EFF=MAX(Q2,P2EFF)
38706
38707C...Find number of flavours at lower and upper scale.
38708 NFP=4
38709 IF(P2EFF.LT.PMC**2) NFP=3
38710 IF(P2EFF.GT.PMB**2) NFP=5
38711 NFQ=4
38712 IF(Q2EFF.LT.PMC**2) NFQ=3
38713 IF(Q2EFF.GT.PMB**2) NFQ=5
38714
38715C...Find s as sum of 3-, 4- and 5-flavour parts.
38716 S=0D0
38717 IF(NFP.EQ.3) THEN
38718 Q2DIV=PMC**2
38719 IF(NFQ.EQ.3) Q2DIV=Q2EFF
38720 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
38721 ENDIF
38722 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
38723 P2DIV=P2EFF
38724 IF(NFP.EQ.3) P2DIV=PMC**2
38725 Q2DIV=Q2EFF
38726 IF(NFQ.EQ.5) Q2DIV=PMB**2
38727 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
38728 ENDIF
38729 IF(NFQ.EQ.5) THEN
38730 P2DIV=PMB**2
38731 IF(NFP.EQ.5) P2DIV=P2EFF
38732 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
38733 ENDIF
38734
38735C...Calculate frequent combinations of x and s.
38736 X1=1D0-X
38737 XL=-LOG(X)
38738 S2=S**2
38739 S3=S**3
38740 S4=S**4
38741
38742C...Evaluate homogeneous anomalous parton distributions below or
38743C...above threshold.
38744 IF(ISET.EQ.0) THEN
38745 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38746 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38747 XVAL = X * 1.5D0 * (X**2+X1**2)
38748 XGLU = 0D0
38749 XSEA = 0D0
38750 ELSE
38751 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
38752 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
38753 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
38754 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
38755 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
38756 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
38757 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
38758 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
38759 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
38760 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
38761 & (2D0*X-1D0)*X*XL**2)
38762 ENDIF
38763
38764C...Evaluate set 1D parton distributions below or above threshold.
38765 ELSEIF(ISET.EQ.1) THEN
38766 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38767 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38768 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
38769 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
38770 XSEA = 0.100D0 * X1**3.76D0
38771 ELSE
38772 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
38773 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
38774 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
38775 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
38776 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
38777 & X**0.40D0 * X1**(1.76D0+3D0*S)
38778 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
38779 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
38780 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
38781 XSEA0 = 0.100D0 * X1**3.76D0
38782 ENDIF
38783
38784C...Evaluate set 1M parton distributions below or above threshold.
38785 ELSEIF(ISET.EQ.2) THEN
38786 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38787 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38788 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
38789 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
38790 XSEA = 0D0
38791 ELSE
38792 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
38793 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
38794 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
38795 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
38796 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
38797 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
38798 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
38799 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
38800 & XL**(2.8D0*S)
38801 XSEA0 = 0D0
38802 ENDIF
38803
38804C...Evaluate set 2D parton distributions below or above threshold.
38805 ELSEIF(ISET.EQ.3) THEN
38806 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38807 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38808 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
38809 XGLU = 1.925D0 * X1**2
38810 XSEA = 0.242D0 * X1**4
38811 ELSE
38812 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
38813 & X**(0.46D0+0.25D0*S) *
38814 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
38815 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
38816 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
38817 & EXP(-18.67D0*S) *
38818 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
38819 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
38820 & XL**(9.3D0*S/(1D0+1.7D0*S))
38821 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
38822 & (1D0-0.607D0*S+21.95D0*S2) *
38823 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
38824 XSEA0 = 0.242D0 * X1**4
38825 ENDIF
38826
38827C...Evaluate set 2M parton distributions below or above threshold.
38828 ELSEIF(ISET.EQ.4) THEN
38829 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38830 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38831 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
38832 XGLU = 1.808D0 * X1**2
38833 XSEA = 0.209D0 * X1**4
38834 ELSE
38835 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
38836 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
38837 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
38838 & XL**(5.15D0*S/(1D0+2D0*S)) +
38839 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
38840 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
38841 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
38842 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
38843 & XL**(10.9D0*S/(1D0+2.5D0*S))
38844 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
38845 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
38846 & X1**(4D0+S) * XL**(0.45D0*S)
38847 XSEA0 = 0.209D0 * X1**4
38848 ENDIF
38849 ENDIF
38850
38851C...Threshold factors for c and b sea.
38852 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38853 XCHM=0D0
38854 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38855 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38856 IF(ISET.EQ.0) THEN
38857 XCHM=XSEA*(1D0-(SCH/SLL)**2)
38858 ELSE
38859 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
38860 ENDIF
38861 ENDIF
38862 XBOT=0D0
38863 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38864 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38865 IF(ISET.EQ.0) THEN
38866 XBOT=XSEA*(1D0-(SBT/SLL)**2)
38867 ELSE
38868 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
38869 ENDIF
38870 ENDIF
38871
38872C...Fill parton distributions.
38873 XPGA(0)=XGLU
38874 XPGA(1)=XSEA
38875 XPGA(2)=XSEA
38876 XPGA(3)=XSEA
38877 XPGA(4)=XCHM
38878 XPGA(5)=XBOT
38879 XPGA(KFA)=XPGA(KFA)+XVAL
38880 DO 110 KFL=1,5
38881 XPGA(-KFL)=XPGA(KFL)
38882 110 CONTINUE
38883 VXPGA(KFA)=XVAL
38884 VXPGA(-KFA)=XVAL
38885
38886 RETURN
38887 END
38888
38889C*********************************************************************
38890
38891C...PYGANO
38892C...Evaluates the parton distributions of the anomalous photon,
38893C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
38894C...KF=0 gives the sum over (up to) 5 flavours,
38895C...KF<0 limits to flavours up to abs(KF),
38896C...KF>0 is for flavour KF only.
38897C...ALAM is the 4-flavour Lambda, which is automatically converted
38898C...to 3- and 5-flavour equivalents as needed.
38899C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38900
38901 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38902
38903C...Double precision and integer declarations.
38904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38905 IMPLICIT INTEGER(I-N)
38906 INTEGER PYK,PYCHGE,PYCOMP
38907C...Local arrays and data.
38908 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
38909 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38910
38911C...Reset output.
38912 DO 100 KFL=-6,6
38913 XPGA(KFL)=0D0
38914 VXPGA(KFL)=0D0
38915 100 CONTINUE
38916 IF(Q2.LE.P2) RETURN
38917 KFA=IABS(KF)
38918
38919C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38920 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
38921 ALAMSQ(4)=ALAM**2
38922 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
38923 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
38924 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38925 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38926 Q2EFF=MAX(Q2,P2EFF)
38927 XL=-LOG(X)
38928
38929C...Find number of flavours at lower and upper scale.
38930 NFP=4
38931 IF(P2EFF.LT.PMC**2) NFP=3
38932 IF(P2EFF.GT.PMB**2) NFP=5
38933 NFQ=4
38934 IF(Q2EFF.LT.PMC**2) NFQ=3
38935 IF(Q2EFF.GT.PMB**2) NFQ=5
38936
38937C...Define range of flavour loop.
38938 IF(KF.EQ.0) THEN
38939 KFLMN=1
38940 KFLMX=5
38941 ELSEIF(KF.LT.0) THEN
38942 KFLMN=1
38943 KFLMX=KFA
38944 ELSE
38945 KFLMN=KFA
38946 KFLMX=KFA
38947 ENDIF
38948
38949C...Loop over flavours the photon can branch into.
38950 DO 110 KFL=KFLMN,KFLMX
38951
38952C...Light flavours: calculate t range and (approximate) s range.
38953 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38954 TDIFF=LOG(Q2EFF/P2EFF)
38955 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38956 & LOG(P2EFF/ALAMSQ(NFQ)))
38957 IF(NFQ.GT.NFP) THEN
38958 Q2DIV=PMB**2
38959 IF(NFQ.EQ.4) Q2DIV=PMC**2
38960 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38961 & LOG(P2EFF/ALAMSQ(NFQ)))
38962 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38963 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38964 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38965 ENDIF
38966 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38967 Q2DIV=PMC**2
38968 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38969 & LOG(P2EFF/ALAMSQ(4)))
38970 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38971 & LOG(P2EFF/ALAMSQ(3)))
38972 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38973 ENDIF
38974
38975C...u and s quark do not need a separate treatment when d has been done.
38976 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38977
38978C...Charm: as above, but only include range above c threshold.
38979 ELSEIF(KFL.EQ.4) THEN
38980 IF(Q2.LE.PMC**2) GOTO 110
38981 P2EFF=MAX(P2EFF,PMC**2)
38982 Q2EFF=MAX(Q2EFF,P2EFF)
38983 TDIFF=LOG(Q2EFF/P2EFF)
38984 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38985 & LOG(P2EFF/ALAMSQ(NFQ)))
38986 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38987 Q2DIV=PMB**2
38988 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38989 & LOG(P2EFF/ALAMSQ(NFQ)))
38990 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38991 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38992 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38993 ENDIF
38994
38995C...Bottom: as above, but only include range above b threshold.
38996 ELSEIF(KFL.EQ.5) THEN
38997 IF(Q2.LE.PMB**2) GOTO 110
38998 P2EFF=MAX(P2EFF,PMB**2)
38999 Q2EFF=MAX(Q2,P2EFF)
39000 TDIFF=LOG(Q2EFF/P2EFF)
39001 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39002 & LOG(P2EFF/ALAMSQ(NFQ)))
39003 ENDIF
39004
39005C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39006 CHSQ=1D0/9D0
39007 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39008 FAC=AEM2PI*2D0*CHSQ*TDIFF
39009
39010C...Evaluate parton distributions (normalized to unit momentum sum).
39011 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39012 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39013 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39014 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39015 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39016 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39017 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39018 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39019 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39020 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39021 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39022 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39023
39024C...Threshold factors for c and b sea.
39025 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39026 XCHM=0D0
39027 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39028 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39029 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39030 ENDIF
39031 XBOT=0D0
39032 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39033 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39034 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39035 ENDIF
39036 ENDIF
39037
39038C...Add contribution of each valence flavour.
39039 XPGA(0)=XPGA(0)+FAC*XGLU
39040 XPGA(1)=XPGA(1)+FAC*XSEA
39041 XPGA(2)=XPGA(2)+FAC*XSEA
39042 XPGA(3)=XPGA(3)+FAC*XSEA
39043 XPGA(4)=XPGA(4)+FAC*XCHM
39044 XPGA(5)=XPGA(5)+FAC*XBOT
39045 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39046 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39047 110 CONTINUE
39048 DO 120 KFL=1,5
39049 XPGA(-KFL)=XPGA(KFL)
39050 VXPGA(-KFL)=VXPGA(KFL)
39051 120 CONTINUE
39052
39053 RETURN
39054 END
39055
39056
39057C*********************************************************************
39058
39059C...PYGBEH
39060C...Evaluates the Bethe-Heitler cross section for heavy flavour
39061C...production.
39062C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39063
39064 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39065
39066C...Double precision and integer declarations.
39067 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39068 IMPLICIT INTEGER(I-N)
39069 INTEGER PYK,PYCHGE,PYCOMP
39070
39071C...Local data.
39072 DATA AEM2PI/0.0011614D0/
39073
39074C...Reset output.
39075 XPBH=0D0
39076 SIGBH=0D0
39077
39078C...Check kinematics limits.
39079 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39080 W2=Q2*(1D0-X)/X-P2
39081 BETA2=1D0-4D0*PM2/W2
39082 IF(BETA2.LT.1D-10) RETURN
39083 BETA=SQRT(BETA2)
39084 RMQ=4D0*PM2/Q2
39085
39086C...Simple case: P2 = 0.
39087 IF(P2.LT.1D-4) THEN
39088 IF(BETA.LT.0.99D0) THEN
39089 XBL=LOG((1D0+BETA)/(1D0-BETA))
39090 ELSE
39091 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39092 ENDIF
39093 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39094 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39095
39096C...Complicated case: P2 > 0, based on approximation of
39097C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39098 ELSE
39099 RPQ=1D0-4D0*X**2*P2/Q2
39100 IF(RPQ.GT.1D-10) THEN
39101 RPBE=SQRT(RPQ*BETA2)
39102 IF(RPBE.LT.0.99D0) THEN
39103 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
39104 XBI=2D0*RPBE/(1D0-RPBE**2)
39105 ELSE
39106 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
39107 XBL=LOG((1D0+RPBE)**2/RPBESN)
39108 XBI=2D0*RPBE/RPBESN
39109 ENDIF
39110 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
39111 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
39112 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
39113 ENDIF
39114 ENDIF
39115
39116C...Multiply by charge-squared etc. to get parton distribution.
39117 CHSQ=1D0/9D0
39118 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
39119 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
39120
39121 RETURN
39122 END
39123
39124C*********************************************************************
39125
39126C...PYGDIR
39127C...Evaluates the direct contribution, i.e. the C^gamma term,
39128C...as needed in MSbar parametrizations.
39129C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39130
39131 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
39132
39133C...Double precision and integer declarations.
39134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39135 IMPLICIT INTEGER(I-N)
39136 INTEGER PYK,PYCHGE,PYCOMP
39137C...Local array and data.
39138 DIMENSION XPGA(-6:6)
39139 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
39140
39141C...Reset output.
39142 DO 100 KFL=-6,6
39143 XPGA(KFL)=0D0
39144 100 CONTINUE
39145
39146C...Evaluate common x-dependent expression.
39147 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
39148 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
39149
39150C...d, u, s part by simple charge factor.
39151 XPGA(1)=(1D0/9D0)*CGAM
39152 XPGA(2)=(4D0/9D0)*CGAM
39153 XPGA(3)=(1D0/9D0)*CGAM
39154
39155C...Also fill for antiquarks.
39156 DO 110 KF=1,5
39157 XPGA(-KF)=XPGA(KF)
39158 110 CONTINUE
39159
39160 RETURN
39161 END
39162
39163C*********************************************************************
39164
39165C...PYPDPI
39166C...Gives pi+ parton distribution according to two different
39167C...parametrizations.
39168
39169 SUBROUTINE PYPDPI(X,Q2,XPPI)
39170
39171C...Double precision and integer declarations.
39172 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39173 IMPLICIT INTEGER(I-N)
39174 INTEGER PYK,PYCHGE,PYCOMP
39175C...Commonblocks.
39176 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39177 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39178 COMMON/PYINT1/MINT(400),VINT(400)
39179 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39180C...Local arrays.
39181 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
39182
39183C...The following data lines are coefficients needed in the
39184C...Owens pion parton distribution parametrizations, see below.
39185C...Expansion coefficients for up and down valence quark distributions.
39186 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
39187 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39188 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39189 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39190 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
39191 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39192 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39193 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39194C...Expansion coefficients for gluon distribution.
39195 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
39196 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
39197 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
39198 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
39199 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
39200 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
39201 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
39202 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
39203C...Expansion coefficients for (up+down+strange) quark sea distribution.
39204 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
39205 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39206 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
39207 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
39208 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
39209 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39210 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
39211 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
39212C...Expansion coefficients for charm quark sea distribution.
39213 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
39214 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
39215 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
39216 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
39217 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
39218 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
39219 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
39220 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
39221
39222C...Euler's beta function, requires ordinary Gamma function
39223 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
39224
39225C...Reset output array.
39226 DO 100 KFL=-6,6
39227 XPPI(KFL)=0D0
39228 100 CONTINUE
39229
39230 IF(MSTP(53).LE.2) THEN
39231C...Pion parton distributions from Owens.
39232C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
39233
39234C...Determine set, Lambda and s expansion variable.
39235 NSET=MSTP(53)
39236 IF(NSET.EQ.1) ALAM=0.2D0
39237 IF(NSET.EQ.2) ALAM=0.4D0
39238 VINT(231)=4D0
39239 IF(MSTP(57).LE.0) THEN
39240 SD=0D0
39241 ELSE
39242 Q2IN=MIN(2D3,MAX(4D0,Q2))
39243 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
39244 ENDIF
39245
39246C...Calculate parton distributions.
39247 DO 120 KFL=1,4
39248 DO 110 IS=1,5
39249 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
39250 & COW(3,IS,KFL,NSET)*SD**2
39251 110 CONTINUE
39252 IF(KFL.EQ.1) THEN
39253 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
39254 ELSE
39255 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
39256 & TS(5)*X**2)
39257 ENDIF
39258 120 CONTINUE
39259
39260C...Put into output array.
39261 XPPI(0)=XQ(2)
39262 XPPI(1)=XQ(3)/6D0
39263 XPPI(2)=XQ(1)+XQ(3)/6D0
39264 XPPI(3)=XQ(3)/6D0
39265 XPPI(4)=XQ(4)
39266 XPPI(-1)=XQ(1)+XQ(3)/6D0
39267 XPPI(-2)=XQ(3)/6D0
39268 XPPI(-3)=XQ(3)/6D0
39269 XPPI(-4)=XQ(4)
39270
39271C...Leading order pion parton distributions from Glueck, Reya and Vogt.
39272C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
39273C...10^-5 < x < 1.
39274 ELSE
39275
39276C...Determine s expansion variable and some x expressions.
39277 VINT(231)=0.25D0
39278 IF(MSTP(57).LE.0) THEN
39279 SD=0D0
39280 ELSE
39281 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
39282 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
39283 ENDIF
39284 SD2=SD**2
39285 XL=-LOG(X)
39286 XS=SQRT(X)
39287
39288C...Evaluate valence, gluon and sea distributions.
39289 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
39290 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
39291 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
39292 & SD-0.175D0*SD2)+
39293 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
39294 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
39295 & XL)))*
39296 & (1D0-X)**(0.390D0+1.053D0*SD)
39297 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
39298 & X)**3.359D0*
39299 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
39300 & XL))/
39301 & XL**(2.538D0-0.763D0*SD)
39302 IF(SD.LE.0.888D0) THEN
39303 XFCHM=0D0
39304 ELSE
39305 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
39306 & 0.771D0*SD)*
39307 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
39308 & XL))
39309 ENDIF
39310 IF(SD.LE.1.351D0) THEN
39311 XFBOT=0D0
39312 ELSE
39313 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
39314 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
39315 & XL))
39316 ENDIF
39317
39318C...Put into output array.
39319 XPPI(0)=XFGLU
39320 XPPI(1)=XFSEA
39321 XPPI(2)=XFSEA
39322 XPPI(3)=XFSEA
39323 XPPI(4)=XFCHM
39324 XPPI(5)=XFBOT
39325 DO 130 KFL=1,5
39326 XPPI(-KFL)=XPPI(KFL)
39327 130 CONTINUE
39328 XPPI(2)=XPPI(2)+XFVAL
39329 XPPI(-1)=XPPI(-1)+XFVAL
39330 ENDIF
39331
39332 RETURN
39333 END
39334
39335C*********************************************************************
39336
39337C...PYPDPR
39338C...Gives proton parton distributions according to a few different
39339C...parametrizations.
39340
39341 SUBROUTINE PYPDPR(X,Q2,XPPR)
39342
39343C...Double precision and integer declarations.
39344 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39345 IMPLICIT INTEGER(I-N)
39346 INTEGER PYK,PYCHGE,PYCOMP
39347C...Commonblocks.
39348 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39349 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39350 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39351 COMMON/PYINT1/MINT(400),VINT(400)
39352 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39353C...Arrays and data.
39354 DIMENSION XPPR(-6:6),Q2MIN(16)
39355 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
39356 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
39357
39358C...Reset output array.
39359 DO 100 KFL=-6,6
39360 XPPR(KFL)=0D0
39361 100 CONTINUE
39362
39363C...Common preliminaries.
39364 NSET=MAX(1,MIN(16,MSTP(51)))
39365 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
39366 VINT(231)=Q2MIN(NSET)
39367 IF(MSTP(57).EQ.0) THEN
39368 Q2L=Q2MIN(NSET)
39369 ELSE
39370 Q2L=MAX(Q2MIN(NSET),Q2)
39371 ENDIF
39372
39373 IF(NSET.GE.1.AND.NSET.LE.3) THEN
39374C...Interface to the CTEQ 3 parton distributions.
39375 QRT=SQRT(MAX(1D0,Q2L))
39376
39377C...Loop over flavours.
39378 DO 110 I=-6,6
39379 IF(I.LE.0) THEN
39380 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
39381 ELSEIF(I.LE.2) THEN
39382 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
39383 ELSE
39384 XPPR(I)=XPPR(-I)
39385 ENDIF
39386 110 CONTINUE
39387
39388 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
39389C...Interface to the GRV 94 distributions.
39390 IF(NSET.EQ.4) THEN
39391 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39392 ELSEIF(NSET.EQ.5) THEN
39393 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39394 ELSE
39395 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39396 ENDIF
39397
39398C...Put into output array.
39399 XPPR(0)=GL
39400 XPPR(-1)=0.5D0*(UDB+DEL)
39401 XPPR(-2)=0.5D0*(UDB-DEL)
39402 XPPR(-3)=SB
39403 XPPR(-4)=CHM
39404 XPPR(-5)=BOT
39405 XPPR(1)=DV+XPPR(-1)
39406 XPPR(2)=UV+XPPR(-2)
39407 XPPR(3)=SB
39408 XPPR(4)=CHM
39409 XPPR(5)=BOT
39410
39411 ELSEIF(NSET.EQ.7) THEN
39412C...Interface to the CTEQ 5L parton distributions.
39413C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
39414C...freezing x*f(x,Q2) at borders.
39415 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39416 XIN=MAX(1D-6,MIN(1D0,X))
39417
39418C...Loop over flavours (with u <-> d notation mismatch).
39419 SUMUDB=PYCT5L(-1,XIN,QRT)
39420 RATUDB=PYCT5L(-2,XIN,QRT)
39421 DO 120 I=-5,2
39422 IF(I.EQ.1) THEN
39423 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
39424 ELSEIF(I.EQ.2) THEN
39425 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
39426 ELSEIF(I.EQ.-1) THEN
39427 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39428 ELSEIF(I.EQ.-2) THEN
39429 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39430 ELSE
39431 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
39432 IF(I.LT.0) XPPR(-I)=XPPR(I)
39433 ENDIF
39434 120 CONTINUE
39435
39436 ELSEIF(NSET.EQ.8) THEN
39437C...Interface to the CTEQ 5M1 parton distributions.
39438 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39439 XIN=MAX(1D-6,MIN(1D0,X))
39440
39441C...Loop over flavours (with u <-> d notation mismatch).
39442 SUMUDB=PYCT5M(-1,XIN,QRT)
39443 RATUDB=PYCT5M(-2,XIN,QRT)
39444 DO 130 I=-5,2
39445 IF(I.EQ.1) THEN
39446 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
39447 ELSEIF(I.EQ.2) THEN
39448 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
39449 ELSEIF(I.EQ.-1) THEN
39450 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39451 ELSEIF(I.EQ.-2) THEN
39452 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39453 ELSE
39454 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
39455 IF(I.LT.0) XPPR(-I)=XPPR(I)
39456 ENDIF
39457 130 CONTINUE
39458
39459 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
39460C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
39461C...obsolete but offers backwards compatibility.
39462 CALL PYPDPO(X,Q2L,XPPR)
39463
39464C...Symmetric choice for debugging only
39465 ELSEIF(NSET.EQ.16) THEN
39466 XPPR(0)=.5D0/X
39467 XPPR(1)=.05D0/X
39468 XPPR(2)=.05D0/X
39469 XPPR(3)=.05D0/X
39470 XPPR(4)=.05D0/X
39471 XPPR(5)=.05D0/X
39472 XPPR(-1)=.05D0/X
39473 XPPR(-2)=.05D0/X
39474 XPPR(-3)=.05D0/X
39475 XPPR(-4)=.05D0/X
39476 XPPR(-5)=.05D0/X
39477
39478 ENDIF
39479
39480 RETURN
39481 END
39482
39483C*********************************************************************
39484
39485C...PYCTEQ
39486C...Gives the CTEQ 3 parton distribution function sets in
39487C...parametrized form, of October 24, 1994.
39488C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
39489C...J. Qiu, W.K. Tung and H. Weerts.
39490
39491 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
39492
39493C...Double precision declaration.
39494 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39495 IMPLICIT INTEGER(I-N)
39496
39497C...Data on Lambda values of fits, minimum Q and quark masses.
39498 DIMENSION ALM(3), QMS(4:6)
39499 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
39500 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
39501
39502C....Check flavour thresholds. Set up QI for SB.
39503 IP = IABS(IPRT)
39504 IF(IP .GE. 4) THEN
39505 IF(Q .LE. QMS(IP)) THEN
39506 PYCTEQ = 0D0
39507 RETURN
39508 ENDIF
39509 QI = QMS(IP)
39510 ELSE
39511 QI = QMN
39512 ENDIF
39513
39514C...Use "standard lambda" of parametrization program for expansion.
39515 ALAM = ALM (ISET)
39516 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
39517 SB = LOG (SBL)
39518 SB2 = SB*SB
39519 SB3 = SB2*SB
39520
39521C...Expansion for CTEQ3L.
39522 IF(ISET .EQ. 1) THEN
39523 IF(IPRT .EQ. 2) THEN
39524 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
39525 & 0.3171D+00*SB3)
39526 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
39527 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
39528 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
39529 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
39530 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
39531 ELSEIF(IPRT .EQ. 1) THEN
39532 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
39533 & 0.7728D+00*SB3)
39534 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
39535 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
39536 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
39537 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
39538 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
39539 ELSEIF(IPRT .EQ. 0) THEN
39540 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
39541 & 0.5343D+00*SB3)
39542 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
39543 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
39544 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
39545 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
39546 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
39547 ELSEIF(IPRT .EQ. -1) THEN
39548 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
39549 & 0.2031D+01*SB3)
39550 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
39551 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
39552 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
39553 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
39554 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
39555 ELSEIF(IPRT .EQ. -2) THEN
39556 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
39557 & 0.9872D-01*SB3)
39558 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
39559 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
39560 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
39561 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
39562 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
39563 ELSEIF(IPRT .EQ. -3) THEN
39564 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
39565 & 0.8390D+00*SB3)
39566 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
39567 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
39568 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
39569 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
39570 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
39571 ELSEIF(IPRT .EQ. -4) THEN
39572 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
39573 & 0.1651D-01*SB2)
39574 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
39575 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
39576 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
39577 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
39578 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
39579 ELSEIF(IPRT .EQ. -5) THEN
39580 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
39581 & 0.3702D+01*SB2)
39582 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
39583 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
39584 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
39585 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
39586 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
39587 ELSEIF(IPRT .EQ. -6) THEN
39588 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
39589 & 0.6943D+00*SB2)
39590 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
39591 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
39592 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
39593 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
39594 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
39595 ENDIF
39596
39597C...Expansion for CTEQ3M.
39598 ELSEIF(ISET .EQ. 2) THEN
39599 IF(IPRT .EQ. 2) THEN
39600 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
39601 & 0.2935D+00*SB3)
39602 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
39603 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
39604 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
39605 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
39606 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
39607 ELSEIF(IPRT .EQ. 1) THEN
39608 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
39609 & 0.4305D-01*SB3)
39610 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
39611 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
39612 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
39613 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
39614 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
39615 ELSEIF(IPRT .EQ. 0) THEN
39616 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
39617 & 0.1037D-01*SB3)
39618 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
39619 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
39620 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
39621 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
39622 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
39623 ELSEIF(IPRT .EQ. -1) THEN
39624 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
39625 & 0.1602D+01*SB3)
39626 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
39627 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
39628 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
39629 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
39630 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
39631 ELSEIF(IPRT .EQ. -2) THEN
39632 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
39633 & 0.2496D+00*SB3)
39634 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
39635 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
39636 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
39637 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
39638 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
39639 ELSEIF(IPRT .EQ. -3) THEN
39640 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
39641 & 0.1936D+01*SB3)
39642 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
39643 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
39644 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
39645 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
39646 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
39647 ELSEIF(IPRT .EQ. -4) THEN
39648 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
39649 & 0.5348D+00*SB2)
39650 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
39651 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
39652 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
39653 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
39654 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
39655 ELSEIF(IPRT .EQ. -5) THEN
39656 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
39657 & 0.1569D+01*SB2)
39658 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
39659 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
39660 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
39661 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
39662 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
39663 ELSEIF(IPRT .EQ. -6) THEN
39664 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
39665 & 0.8838D+01*SB2)
39666 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
39667 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
39668 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
39669 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
39670 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
39671 ENDIF
39672
39673C...Expansion for CTEQ3D.
39674 ELSEIF(ISET .EQ. 3) THEN
39675 IF(IPRT .EQ. 2) THEN
39676 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
39677 & 0.2902D+00*SB3)
39678 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
39679 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
39680 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
39681 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
39682 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
39683 ELSEIF(IPRT .EQ. 1) THEN
39684 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
39685 & 0.7257D+00*SB3)
39686 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
39687 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
39688 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
39689 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
39690 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
39691 ELSEIF(IPRT .EQ. 0) THEN
39692 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
39693 & 0.2734D-04*SB3)
39694 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
39695 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
39696 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
39697 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
39698 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
39699 ELSEIF(IPRT .EQ. -1) THEN
39700 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
39701 & 0.1671D+01*SB3)
39702 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
39703 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
39704 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
39705 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
39706 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
39707 ELSEIF(IPRT .EQ. -2) THEN
39708 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
39709 & 0.2223D+00*SB3)
39710 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
39711 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
39712 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
39713 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
39714 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
39715 ELSEIF(IPRT .EQ. -3) THEN
39716 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
39717 & 0.1937D+01*SB3)
39718 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
39719 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
39720 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
39721 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
39722 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
39723 ELSEIF(IPRT .EQ. -4) THEN
39724 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
39725 & 0.5137D+00*SB2)
39726 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
39727 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
39728 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
39729 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
39730 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
39731 ELSEIF(IPRT .EQ. -5) THEN
39732 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
39733 & 0.2143D+01*SB2)
39734 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
39735 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
39736 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
39737 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
39738 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
39739 ELSEIF(IPRT .EQ. -6) THEN
39740 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
39741 & 0.9998D+01*SB2)
39742 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
39743 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
39744 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
39745 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
39746 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
39747 ENDIF
39748 ENDIF
39749
39750C...Calculation of x * f(x, Q).
39751 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
39752 & *(LOG(1D0+1D0/X))**A5 )
39753
39754 RETURN
39755 END
39756
39757C*********************************************************************
39758
39759C...PYGRVL
39760C...Gives the GRV 94 L (leading order) parton distribution function set
39761C...in parametrized form.
39762C...Authors: M. Glueck, E. Reya and A. Vogt.
39763
39764 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39765
39766C...Double precision declaration.
39767 IMPLICIT DOUBLE PRECISION (A - Z)
39768
39769C...Common expressions.
39770 MU2 = 0.23D0
39771 LAM2 = 0.2322D0 * 0.2322D0
39772 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39773 DS = SQRT (S)
39774 S2 = S * S
39775 S3 = S2 * S
39776
39777C...uv :
39778 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
39779 AKU = 0.590D0 - 0.024D0 * S
39780 BKU = 0.131D0 + 0.063D0 * S
39781 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
39782 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
39783 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
39784 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
39785 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39786
39787C...dv :
39788 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
39789 AKD = 0.376D0
39790 BKD = 0.486D0 + 0.062D0 * S
39791 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
39792 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
39793 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
39794 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
39795 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39796
39797C...del :
39798 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
39799 AKE = 0.409D0 - 0.005D0 * S
39800 BKE = 0.799D0 + 0.071D0 * S
39801 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
39802 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
39803 CE = 0.0D0
39804 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
39805 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39806
39807C...udb :
39808 ALX = 1.451D0
39809 BEX = 0.271D0
39810 AKX = 0.410D0 - 0.232D0 * S
39811 BKX = 0.534D0 - 0.457D0 * S
39812 AGX = 0.890D0 - 0.140D0 * S
39813 BGX = -0.981D0
39814 CX = 0.320D0 + 0.683D0 * S
39815 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
39816 EX = 4.119D0 + 1.713D0 * S
39817 ESX = 0.682D0 + 2.978D0 * S
39818 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39819 & DX, EX, ESX)
39820
39821C...sb :
39822 STS = 0D0
39823 ALS = 0.914D0
39824 BES = 0.577D0
39825 AKS = 1.798D0 - 0.596D0 * S
39826 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
39827 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
39828 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
39829 EST = 3.981D0 + 1.638D0 * S
39830 ESS = 6.402D0
39831 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39832
39833C...cb :
39834 STC = 0.888D0
39835 ALC = 1.01D0
39836 BEC = 0.37D0
39837 AKC = 0D0
39838 AC = 0D0
39839 BC = 4.24D0 - 0.804D0 * S
39840 DCT = 3.46D0 - 1.076D0 * S
39841 ECT = 4.61D0 + 1.49D0 * S
39842 ESC = 2.555D0 + 1.961D0 * S
39843 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39844
39845C...bb :
39846 STB = 1.351D0
39847 ALB = 1.00D0
39848 BEB = 0.51D0
39849 AKB = 0D0
39850 AB = 0D0
39851 BB = 1.848D0
39852 DBT = 2.929D0 + 1.396D0 * S
39853 EBT = 4.71D0 + 1.514D0 * S
39854 ESB = 4.02D0 + 1.239D0 * S
39855 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39856
39857C...gl :
39858 ALG = 0.524D0
39859 BEG = 1.088D0
39860 AKG = 1.742D0 - 0.930D0 * S
39861 BKG = - 0.399D0 * S2
39862 AG = 7.486D0 - 2.185D0 * S
39863 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
39864 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
39865 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
39866 EG = 0.807D0 + 2.005D0 * S
39867 ESG = 3.841D0 + 0.316D0 * S
39868 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
39869 & DG, EG, ESG)
39870
39871 RETURN
39872 END
39873
39874C*********************************************************************
39875
39876C...PYGRVM
39877C...Gives the GRV 94 M (MSbar) parton distribution function set
39878C...in parametrized form.
39879C...Authors: M. Glueck, E. Reya and A. Vogt.
39880
39881 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39882
39883C...Double precision declaration.
39884 IMPLICIT DOUBLE PRECISION (A - Z)
39885
39886C...Common expressions.
39887 MU2 = 0.34D0
39888 LAM2 = 0.248D0 * 0.248D0
39889 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39890 DS = SQRT (S)
39891 S2 = S * S
39892 S3 = S2 * S
39893
39894C...uv :
39895 NU = 1.304D0 + 0.863D0 * S
39896 AKU = 0.558D0 - 0.020D0 * S
39897 BKU = 0.183D0 * S
39898 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
39899 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
39900 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
39901 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
39902 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39903
39904C...dv :
39905 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
39906 AKD = 0.270D0 - 0.019D0 * S
39907 BKD = 0.260D0
39908 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
39909 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
39910 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
39911 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
39912 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39913
39914C...del :
39915 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
39916 AKE = 0.409D0 - 0.007D0 * S
39917 BKE = 0.782D0 + 0.082D0 * S
39918 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
39919 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
39920 CE = 0.0D0
39921 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
39922 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39923
39924C...udb :
39925 ALX = 0.877D0
39926 BEX = 0.561D0
39927 AKX = 0.275D0
39928 BKX = 0.0D0
39929 AGX = 0.997D0
39930 BGX = 3.210D0 - 1.866D0 * S
39931 CX = 7.300D0
39932 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39933 EX = 3.077D0 + 1.446D0 * S
39934 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39935 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39936 & DX, EX, ESX)
39937
39938C...sb :
39939 STS = 0D0
39940 ALS = 0.756D0
39941 BES = 0.216D0
39942 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39943 AS = -4.329D0 + 1.131D0 * S
39944 BS = 9.568D0 - 1.744D0 * S
39945 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39946 EST = 3.031D0 + 1.639D0 * S
39947 ESS = 5.837D0 + 0.815D0 * S
39948 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39949
39950C...cb :
39951 STC = 0.820D0
39952 ALC = 0.98D0
39953 BEC = 0D0
39954 AKC = -0.625D0 - 0.523D0 * S
39955 AC = 0D0
39956 BC = 1.896D0 + 1.616D0 * S
39957 DCT = 4.12D0 + 0.683D0 * S
39958 ECT = 4.36D0 + 1.328D0 * S
39959 ESC = 0.677D0 + 0.679D0 * S
39960 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39961
39962C...bb :
39963 STB = 1.297D0
39964 ALB = 0.99D0
39965 BEB = 0D0
39966 AKB = - 0.193D0 * S
39967 AB = 0D0
39968 BB = 0D0
39969 DBT = 3.447D0 + 0.927D0 * S
39970 EBT = 4.68D0 + 1.259D0 * S
39971 ESB = 1.892D0 + 2.199D0 * S
39972 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39973
39974C...gl :
39975 ALG = 1.014D0
39976 BEG = 1.738D0
39977 AKG = 1.724D0 + 0.157D0 * S
39978 BKG = 0.800D0 + 1.016D0 * S
39979 AG = 7.517D0 - 2.547D0 * S
39980 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39981 CG = 4.039D0 + 1.491D0 * S
39982 DG = 3.404D0 + 0.830D0 * S
39983 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39984 ESG = 3.256D0 - 0.436D0 * S
39985 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39986
39987 RETURN
39988 END
39989
39990C*********************************************************************
39991
39992C...PYGRVD
39993C...Gives the GRV 94 D (DIS) parton distribution function set
39994C...in parametrized form.
39995C...Authors: M. Glueck, E. Reya and A. Vogt.
39996
39997 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39998
39999C...Double precision declaration.
40000 IMPLICIT DOUBLE PRECISION (A - Z)
40001
40002C...Common expressions.
40003 MU2 = 0.34D0
40004 LAM2 = 0.248D0 * 0.248D0
40005 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40006 DS = SQRT (S)
40007 S2 = S * S
40008 S3 = S2 * S
40009
40010C...uv :
40011 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40012 AKU = 0.563D0 - 0.025D0 * S
40013 BKU = 0.054D0 + 0.154D0 * S
40014 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40015 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40016 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40017 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40018 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40019
40020C...dv :
40021 ND = 0.156D0 - 0.017D0 * S
40022 AKD = 0.299D0 - 0.022D0 * S
40023 BKD = 0.259D0 - 0.015D0 * S
40024 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40025 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40026 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40027 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40028 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40029
40030C...del :
40031 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40032 AKE = 0.419D0 - 0.013D0 * S
40033 BKE = 1.064D0 - 0.038D0 * S
40034 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40035 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40036 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40037 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40038 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40039
40040C...udb :
40041 ALX = 1.215D0
40042 BEX = 0.466D0
40043 AKX = 0.326D0 + 0.150D0 * S
40044 BKX = 0.956D0 + 0.405D0 * S
40045 AGX = 0.272D0
40046 BGX = 3.794D0 - 2.359D0 * DS
40047 CX = 2.014D0
40048 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40049 EX = 3.049D0 + 1.597D0 * S
40050 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40051 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40052 & DX, EX, ESX)
40053
40054C...sb :
40055 STS = 0D0
40056 ALS = 0.175D0
40057 BES = 0.344D0
40058 AKS = 1.415D0 - 0.641D0 * DS
40059 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40060 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40061 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40062 EST = 4.546D0 + 0.372D0 * S2
40063 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40064 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40065
40066C...cb :
40067 STC = 0.820D0
40068 ALC = 0.98D0
40069 BEC = 0D0
40070 AKC = -0.625D0 - 0.523D0 * S
40071 AC = 0D0
40072 BC = 1.896D0 + 1.616D0 * S
40073 DCT = 4.12D0 + 0.683D0 * S
40074 ECT = 4.36D0 + 1.328D0 * S
40075 ESC = 0.677D0 + 0.679D0 * S
40076 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40077
40078C...bb :
40079 STB = 1.297D0
40080 ALB = 0.99D0
40081 BEB = 0D0
40082 AKB = - 0.193D0 * S
40083 AB = 0D0
40084 BB = 0D0
40085 DBT = 3.447D0 + 0.927D0 * S
40086 EBT = 4.68D0 + 1.259D0 * S
40087 ESB = 1.892D0 + 2.199D0 * S
40088 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40089
40090C...gl :
40091 ALG = 1.258D0
40092 BEG = 1.846D0
40093 AKG = 2.423D0
40094 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40095 AG = 25.09D0 - 7.935D0 * S
40096 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
40097 CG = 590.3D0 - 173.8D0 * S
40098 DG = 5.196D0 + 1.857D0 * S
40099 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
40100 ESG = 3.232D0 - 0.542D0 * S
40101 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40102
40103 RETURN
40104 END
40105
40106C*********************************************************************
40107
40108C...PYGRVV
40109C...Auxiliary for the GRV 94 parton distribution functions
40110C...for u and d valence and d-u sea.
40111C...Authors: M. Glueck, E. Reya and A. Vogt.
40112
40113 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
40114
40115C...Double precision declaration.
40116 IMPLICIT DOUBLE PRECISION (A - Z)
40117
40118C...Evaluation.
40119 DX = SQRT (X)
40120 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
40121 & (1D0- X)**D
40122
40123 RETURN
40124 END
40125
40126C*********************************************************************
40127
40128C...PYGRVW
40129C...Auxiliary for the GRV 94 parton distribution functions
40130C...for d+u sea and gluon.
40131C...Authors: M. Glueck, E. Reya and A. Vogt.
40132
40133 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40134
40135C...Double precision declaration.
40136 IMPLICIT DOUBLE PRECISION (A - Z)
40137
40138C...Evaluation.
40139 LX = LOG (1D0/X)
40140 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
40141 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
40142
40143 RETURN
40144 END
40145
40146C*********************************************************************
40147
40148C...PYGRVS
40149C...Auxiliary for the GRV 94 parton distribution functions
40150C...for s, c and b sea.
40151C...Authors: M. Glueck, E. Reya and A. Vogt.
40152
40153 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40154
40155C...Double precision declaration.
40156 IMPLICIT DOUBLE PRECISION (A - Z)
40157
40158C...Evaluation.
40159 IF(S.LE.STH) THEN
40160 PYGRVS = 0D0
40161 ELSE
40162 DX = SQRT (X)
40163 LX = LOG (1D0/X)
40164 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
40165 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
40166 ENDIF
40167
40168 RETURN
40169 END
40170
40171C*********************************************************************
40172
40173C...PYCT5L
40174C...Auxiliary function for parametrization of CTEQ5L.
40175C...Author: J. Pumplin 9/99.
40176
40177C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40178C...in Parametrized Form
40179C... September 15, 1999
40180C
40181C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40182C... CTEQ5 PPARTON DISTRIBUTIONS"
40183C...hep-ph/9903282
40184
40185C...The CTEQ5M1 set given here is an updated version of the original
40186C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40187C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40188C...almost all applications.
40189C...The improvement is in the QCD evolution which is now more
40190C...accurate, and which agrees completely with the benchmark work
40191C...of the HERA 96/97 Workshop.
40192C...The differences between the parametrized and the corresponding
40193C...table versions (on which it is based) are of similar order as
40194C...between the two version.
40195
40196C...!! Because accurate parametrizations over a wide range of (x,Q)
40197C...is hard to obtain, only the most widely used sets CTEQ5M and
40198C...CTEQ5L are available in parametrized form for now.
40199
40200C...These parametrizations were obtained by Jon Pumplin.
40201
40202C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
40203C -------------------------------------------------------------------
40204C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
40205C 3 CTEQ5L Leading Order 0.127 192 146
40206C -------------------------------------------------------------------
40207C...Note the Qcd-lambda values given for CTEQ5L is for the leading
40208C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
40209C...calibration.
40210
40211C...The two Iset value are adopted to agree with the standard table
40212C...versions.
40213
40214C...Range of validity:
40215C...The range of (x, Q) covered by this parametrization of the QCD
40216C...evolved parton distributions is 1E-6 < x < 1 ;
40217C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
40218C...data only in a subset of that region; and the assumed DGLAP
40219C...evolution is unlikely to be valid for all of it either.
40220
40221C...The range of (x, Q) used in the CTEQ5 round of global analysis is
40222C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
40223C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
40224C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
40225
40226 FUNCTION PYCT5L(IFL,X,Q)
40227
40228C...Double precision declaration.
40229 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40230 IMPLICIT INTEGER(I-N)
40231
40232 PARAMETER (NEX=8, NLF=2)
40233 DIMENSION AM(0:NEX,0:NLF,-5:2)
40234 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40235 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40236 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40237 DIMENSION AF(0:NEX)
40238
40239 DATA MEXVEC( 2) / 8 /
40240 DATA MLFVEC( 2) / 2 /
40241 DATA UT1VEC( 2) / 0.4971265E+01 /
40242 DATA UT2VEC( 2) / -0.1105128E+01 /
40243 DATA ALFVEC( 2) / 0.2987216E+00 /
40244 DATA QMAVEC( 2) / 0.0000000E+00 /
40245 DATA (AM( 0,K, 2),K=0, 2)
40246 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
40247 DATA (AM( 1,K, 2),K=0, 2)
40248 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
40249 DATA (AM( 2,K, 2),K=0, 2)
40250 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
40251 DATA (AM( 3,K, 2),K=0, 2)
40252 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
40253 DATA (AM( 4,K, 2),K=0, 2)
40254 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
40255 DATA (AM( 5,K, 2),K=0, 2)
40256 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
40257 DATA (AM( 6,K, 2),K=0, 2)
40258 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
40259 DATA (AM( 7,K, 2),K=0, 2)
40260 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
40261 DATA (AM( 8,K, 2),K=0, 2)
40262 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
40263
40264 DATA MEXVEC( 1) / 8 /
40265 DATA MLFVEC( 1) / 2 /
40266 DATA UT1VEC( 1) / 0.2612618E+01 /
40267 DATA UT2VEC( 1) / -0.1258304E+06 /
40268 DATA ALFVEC( 1) / 0.3407552E+00 /
40269 DATA QMAVEC( 1) / 0.0000000E+00 /
40270 DATA (AM( 0,K, 1),K=0, 2)
40271 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
40272 DATA (AM( 1,K, 1),K=0, 2)
40273 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
40274 DATA (AM( 2,K, 1),K=0, 2)
40275 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
40276 DATA (AM( 3,K, 1),K=0, 2)
40277 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
40278 DATA (AM( 4,K, 1),K=0, 2)
40279 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
40280 DATA (AM( 5,K, 1),K=0, 2)
40281 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
40282 DATA (AM( 6,K, 1),K=0, 2)
40283 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
40284 DATA (AM( 7,K, 1),K=0, 2)
40285 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
40286 DATA (AM( 8,K, 1),K=0, 2)
40287 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
40288
40289 DATA MEXVEC( 0) / 8 /
40290 DATA MLFVEC( 0) / 2 /
40291 DATA UT1VEC( 0) / -0.4656819E+00 /
40292 DATA UT2VEC( 0) / -0.2742390E+03 /
40293 DATA ALFVEC( 0) / 0.4491863E+00 /
40294 DATA QMAVEC( 0) / 0.0000000E+00 /
40295 DATA (AM( 0,K, 0),K=0, 2)
40296 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
40297 DATA (AM( 1,K, 0),K=0, 2)
40298 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
40299 DATA (AM( 2,K, 0),K=0, 2)
40300 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
40301 DATA (AM( 3,K, 0),K=0, 2)
40302 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
40303 DATA (AM( 4,K, 0),K=0, 2)
40304 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
40305 DATA (AM( 5,K, 0),K=0, 2)
40306 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
40307 DATA (AM( 6,K, 0),K=0, 2)
40308 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
40309 DATA (AM( 7,K, 0),K=0, 2)
40310 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
40311 DATA (AM( 8,K, 0),K=0, 2)
40312 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
40313
40314 DATA MEXVEC(-1) / 8 /
40315 DATA MLFVEC(-1) / 2 /
40316 DATA UT1VEC(-1) / 0.3862583E+01 /
40317 DATA UT2VEC(-1) / -0.1265969E+01 /
40318 DATA ALFVEC(-1) / 0.2457668E+00 /
40319 DATA QMAVEC(-1) / 0.0000000E+00 /
40320 DATA (AM( 0,K,-1),K=0, 2)
40321 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
40322 DATA (AM( 1,K,-1),K=0, 2)
40323 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
40324 DATA (AM( 2,K,-1),K=0, 2)
40325 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
40326 DATA (AM( 3,K,-1),K=0, 2)
40327 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
40328 DATA (AM( 4,K,-1),K=0, 2)
40329 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
40330 DATA (AM( 5,K,-1),K=0, 2)
40331 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
40332 DATA (AM( 6,K,-1),K=0, 2)
40333 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
40334 DATA (AM( 7,K,-1),K=0, 2)
40335 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
40336 DATA (AM( 8,K,-1),K=0, 2)
40337 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
40338
40339 DATA MEXVEC(-2) / 7 /
40340 DATA MLFVEC(-2) / 2 /
40341 DATA UT1VEC(-2) / 0.1895615E+00 /
40342 DATA UT2VEC(-2) / -0.3069097E+01 /
40343 DATA ALFVEC(-2) / 0.5293999E+00 /
40344 DATA QMAVEC(-2) / 0.0000000E+00 /
40345 DATA (AM( 0,K,-2),K=0, 2)
40346 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
40347 DATA (AM( 1,K,-2),K=0, 2)
40348 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
40349 DATA (AM( 2,K,-2),K=0, 2)
40350 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
40351 DATA (AM( 3,K,-2),K=0, 2)
40352 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
40353 DATA (AM( 4,K,-2),K=0, 2)
40354 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
40355 DATA (AM( 5,K,-2),K=0, 2)
40356 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
40357 DATA (AM( 6,K,-2),K=0, 2)
40358 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
40359 DATA (AM( 7,K,-2),K=0, 2)
40360 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
40361
40362 DATA MEXVEC(-3) / 7 /
40363 DATA MLFVEC(-3) / 2 /
40364 DATA UT1VEC(-3) / 0.3753257E+01 /
40365 DATA UT2VEC(-3) / -0.1113085E+01 /
40366 DATA ALFVEC(-3) / 0.3713141E+00 /
40367 DATA QMAVEC(-3) / 0.0000000E+00 /
40368 DATA (AM( 0,K,-3),K=0, 2)
40369 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
40370 DATA (AM( 1,K,-3),K=0, 2)
40371 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
40372 DATA (AM( 2,K,-3),K=0, 2)
40373 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
40374 DATA (AM( 3,K,-3),K=0, 2)
40375 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
40376 DATA (AM( 4,K,-3),K=0, 2)
40377 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
40378 DATA (AM( 5,K,-3),K=0, 2)
40379 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
40380 DATA (AM( 6,K,-3),K=0, 2)
40381 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
40382 DATA (AM( 7,K,-3),K=0, 2)
40383 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
40384
40385 DATA MEXVEC(-4) / 7 /
40386 DATA MLFVEC(-4) / 2 /
40387 DATA UT1VEC(-4) / 0.4400772E+01 /
40388 DATA UT2VEC(-4) / -0.1356116E+01 /
40389 DATA ALFVEC(-4) / 0.3712017E-01 /
40390 DATA QMAVEC(-4) / 0.1300000E+01 /
40391 DATA (AM( 0,K,-4),K=0, 2)
40392 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
40393 DATA (AM( 1,K,-4),K=0, 2)
40394 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
40395 DATA (AM( 2,K,-4),K=0, 2)
40396 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
40397 DATA (AM( 3,K,-4),K=0, 2)
40398 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
40399 DATA (AM( 4,K,-4),K=0, 2)
40400 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
40401 DATA (AM( 5,K,-4),K=0, 2)
40402 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
40403 DATA (AM( 6,K,-4),K=0, 2)
40404 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
40405 DATA (AM( 7,K,-4),K=0, 2)
40406 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
40407
40408 DATA MEXVEC(-5) / 6 /
40409 DATA MLFVEC(-5) / 2 /
40410 DATA UT1VEC(-5) / 0.5562568E+01 /
40411 DATA UT2VEC(-5) / -0.1801317E+01 /
40412 DATA ALFVEC(-5) / 0.4952010E-02 /
40413 DATA QMAVEC(-5) / 0.4500000E+01 /
40414 DATA (AM( 0,K,-5),K=0, 2)
40415 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
40416 DATA (AM( 1,K,-5),K=0, 2)
40417 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
40418 DATA (AM( 2,K,-5),K=0, 2)
40419 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
40420 DATA (AM( 3,K,-5),K=0, 2)
40421 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
40422 DATA (AM( 4,K,-5),K=0, 2)
40423 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
40424 DATA (AM( 5,K,-5),K=0, 2)
40425 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
40426 DATA (AM( 6,K,-5),K=0, 2)
40427 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
40428
40429 IF(Q .LE. QMAVEC(IFL)) THEN
40430 PYCT5L = 0.D0
40431 RETURN
40432 ENDIF
40433
40434 IF(X .GE. 1.D0) THEN
40435 PYCT5L = 0.D0
40436 RETURN
40437 ENDIF
40438
40439 TMP = LOG(Q/ALFVEC(IFL))
40440 IF(TMP .LE. 0.D0) THEN
40441 PYCT5L = 0.D0
40442 RETURN
40443 ENDIF
40444
40445 SB = LOG(TMP)
40446 SB1 = SB - 1.2D0
40447 SB2 = SB1*SB1
40448
40449 DO 110 I = 0, NEX
40450 AF(I) = 0.D0
40451 SBX = 1.D0
40452 DO 100 K = 0, MLFVEC(IFL)
40453 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40454 SBX = SB1*SBX
40455 100 CONTINUE
40456 110 CONTINUE
40457
40458 Y = -LOG(X)
40459 U = LOG(X/0.00001D0)
40460
40461 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40462 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40463 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40464 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40465 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40466
40467 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40468
40469C...Include threshold factor.
40470 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
40471
40472 RETURN
40473 END
40474
40475C*********************************************************************
40476
40477C...PYCT5M
40478C...Auxiliary function for parametrization of CTEQ5M1.
40479C...Author: J. Pumplin 9/99.
40480
40481 FUNCTION PYCT5M(IFL,X,Q)
40482
40483C...Double precision declaration.
40484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40485 IMPLICIT INTEGER(I-N)
40486
40487 PARAMETER (NEX=8, NLF=2)
40488 DIMENSION AM(0:NEX,0:NLF,-5:2)
40489 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40490 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40491 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40492 DIMENSION AF(0:NEX)
40493
40494 DATA MEXVEC( 2) / 8 /
40495 DATA MLFVEC( 2) / 2 /
40496 DATA UT1VEC( 2) / 0.5141718E+01 /
40497 DATA UT2VEC( 2) / -0.1346944E+01 /
40498 DATA ALFVEC( 2) / 0.5260555E+00 /
40499 DATA QMAVEC( 2) / 0.0000000E+00 /
40500 DATA (AM( 0,K, 2),K=0, 2)
40501 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
40502 DATA (AM( 1,K, 2),K=0, 2)
40503 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
40504 DATA (AM( 2,K, 2),K=0, 2)
40505 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
40506 DATA (AM( 3,K, 2),K=0, 2)
40507 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
40508 DATA (AM( 4,K, 2),K=0, 2)
40509 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
40510 DATA (AM( 5,K, 2),K=0, 2)
40511 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
40512 DATA (AM( 6,K, 2),K=0, 2)
40513 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
40514 DATA (AM( 7,K, 2),K=0, 2)
40515 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
40516 DATA (AM( 8,K, 2),K=0, 2)
40517 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
40518
40519 DATA MEXVEC( 1) / 8 /
40520 DATA MLFVEC( 1) / 2 /
40521 DATA UT1VEC( 1) / 0.4138426E+01 /
40522 DATA UT2VEC( 1) / -0.3221374E+01 /
40523 DATA ALFVEC( 1) / 0.4960962E+00 /
40524 DATA QMAVEC( 1) / 0.0000000E+00 /
40525 DATA (AM( 0,K, 1),K=0, 2)
40526 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
40527 DATA (AM( 1,K, 1),K=0, 2)
40528 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
40529 DATA (AM( 2,K, 1),K=0, 2)
40530 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
40531 DATA (AM( 3,K, 1),K=0, 2)
40532 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
40533 DATA (AM( 4,K, 1),K=0, 2)
40534 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
40535 DATA (AM( 5,K, 1),K=0, 2)
40536 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
40537 DATA (AM( 6,K, 1),K=0, 2)
40538 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
40539 DATA (AM( 7,K, 1),K=0, 2)
40540 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
40541 DATA (AM( 8,K, 1),K=0, 2)
40542 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
40543
40544 DATA MEXVEC( 0) / 8 /
40545 DATA MLFVEC( 0) / 2 /
40546 DATA UT1VEC( 0) / -0.1026789E+01 /
40547 DATA UT2VEC( 0) / -0.9051707E+01 /
40548 DATA ALFVEC( 0) / 0.9462977E+00 /
40549 DATA QMAVEC( 0) / 0.0000000E+00 /
40550 DATA (AM( 0,K, 0),K=0, 2)
40551 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
40552 DATA (AM( 1,K, 0),K=0, 2)
40553 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
40554 DATA (AM( 2,K, 0),K=0, 2)
40555 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
40556 DATA (AM( 3,K, 0),K=0, 2)
40557 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
40558 DATA (AM( 4,K, 0),K=0, 2)
40559 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
40560 DATA (AM( 5,K, 0),K=0, 2)
40561 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
40562 DATA (AM( 6,K, 0),K=0, 2)
40563 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
40564 DATA (AM( 7,K, 0),K=0, 2)
40565 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
40566 DATA (AM( 8,K, 0),K=0, 2)
40567 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
40568
40569 DATA MEXVEC(-1) / 8 /
40570 DATA MLFVEC(-1) / 2 /
40571 DATA UT1VEC(-1) / 0.5243571E+01 /
40572 DATA UT2VEC(-1) / -0.2870513E+01 /
40573 DATA ALFVEC(-1) / 0.6701448E+00 /
40574 DATA QMAVEC(-1) / 0.0000000E+00 /
40575 DATA (AM( 0,K,-1),K=0, 2)
40576 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
40577 DATA (AM( 1,K,-1),K=0, 2)
40578 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
40579 DATA (AM( 2,K,-1),K=0, 2)
40580 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
40581 DATA (AM( 3,K,-1),K=0, 2)
40582 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
40583 DATA (AM( 4,K,-1),K=0, 2)
40584 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
40585 DATA (AM( 5,K,-1),K=0, 2)
40586 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
40587 DATA (AM( 6,K,-1),K=0, 2)
40588 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
40589 DATA (AM( 7,K,-1),K=0, 2)
40590 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
40591 DATA (AM( 8,K,-1),K=0, 2)
40592 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
40593
40594 DATA MEXVEC(-2) / 7 /
40595 DATA MLFVEC(-2) / 2 /
40596 DATA UT1VEC(-2) / 0.4782210E+01 /
40597 DATA UT2VEC(-2) / -0.1976856E+02 /
40598 DATA ALFVEC(-2) / 0.7558374E+00 /
40599 DATA QMAVEC(-2) / 0.0000000E+00 /
40600 DATA (AM( 0,K,-2),K=0, 2)
40601 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
40602 DATA (AM( 1,K,-2),K=0, 2)
40603 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
40604 DATA (AM( 2,K,-2),K=0, 2)
40605 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
40606 DATA (AM( 3,K,-2),K=0, 2)
40607 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
40608 DATA (AM( 4,K,-2),K=0, 2)
40609 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
40610 DATA (AM( 5,K,-2),K=0, 2)
40611 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
40612 DATA (AM( 6,K,-2),K=0, 2)
40613 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
40614 DATA (AM( 7,K,-2),K=0, 2)
40615 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
40616
40617 DATA MEXVEC(-3) / 7 /
40618 DATA MLFVEC(-3) / 2 /
40619 DATA UT1VEC(-3) / 0.4518239E+01 /
40620 DATA UT2VEC(-3) / -0.2690590E+01 /
40621 DATA ALFVEC(-3) / 0.6124079E+00 /
40622 DATA QMAVEC(-3) / 0.0000000E+00 /
40623 DATA (AM( 0,K,-3),K=0, 2)
40624 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
40625 DATA (AM( 1,K,-3),K=0, 2)
40626 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
40627 DATA (AM( 2,K,-3),K=0, 2)
40628 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
40629 DATA (AM( 3,K,-3),K=0, 2)
40630 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
40631 DATA (AM( 4,K,-3),K=0, 2)
40632 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
40633 DATA (AM( 5,K,-3),K=0, 2)
40634 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
40635 DATA (AM( 6,K,-3),K=0, 2)
40636 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
40637 DATA (AM( 7,K,-3),K=0, 2)
40638 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
40639
40640 DATA MEXVEC(-4) / 7 /
40641 DATA MLFVEC(-4) / 2 /
40642 DATA UT1VEC(-4) / 0.2783230E+01 /
40643 DATA UT2VEC(-4) / -0.1746328E+01 /
40644 DATA ALFVEC(-4) / 0.1115653E+01 /
40645 DATA QMAVEC(-4) / 0.1300000E+01 /
40646 DATA (AM( 0,K,-4),K=0, 2)
40647 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
40648 DATA (AM( 1,K,-4),K=0, 2)
40649 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
40650 DATA (AM( 2,K,-4),K=0, 2)
40651 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
40652 DATA (AM( 3,K,-4),K=0, 2)
40653 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
40654 DATA (AM( 4,K,-4),K=0, 2)
40655 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
40656 DATA (AM( 5,K,-4),K=0, 2)
40657 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
40658 DATA (AM( 6,K,-4),K=0, 2)
40659 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
40660 DATA (AM( 7,K,-4),K=0, 2)
40661 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
40662
40663 DATA MEXVEC(-5) / 6 /
40664 DATA MLFVEC(-5) / 2 /
40665 DATA UT1VEC(-5) / 0.1619654E+02 /
40666 DATA UT2VEC(-5) / -0.3367346E+01 /
40667 DATA ALFVEC(-5) / 0.5109891E-02 /
40668 DATA QMAVEC(-5) / 0.4500000E+01 /
40669 DATA (AM( 0,K,-5),K=0, 2)
40670 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
40671 DATA (AM( 1,K,-5),K=0, 2)
40672 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
40673 DATA (AM( 2,K,-5),K=0, 2)
40674 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
40675 DATA (AM( 3,K,-5),K=0, 2)
40676 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
40677 DATA (AM( 4,K,-5),K=0, 2)
40678 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
40679 DATA (AM( 5,K,-5),K=0, 2)
40680 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
40681 DATA (AM( 6,K,-5),K=0, 2)
40682 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
40683
40684 IF(Q .LE. QMAVEC(IFL)) THEN
40685 PYCT5M = 0.D0
40686 RETURN
40687 ENDIF
40688
40689 IF(X .GE. 1.D0) THEN
40690 PYCT5M = 0.D0
40691 RETURN
40692 ENDIF
40693
40694 TMP = LOG(Q/ALFVEC(IFL))
40695 IF(TMP .LE. 0.D0) THEN
40696 PYCT5M = 0.D0
40697 RETURN
40698 ENDIF
40699
40700 SB = LOG(TMP)
40701 SB1 = SB - 1.2D0
40702 SB2 = SB1*SB1
40703
40704 DO 110 I = 0, NEX
40705 AF(I) = 0.D0
40706 SBX = 1.D0
40707 DO 100 K = 0, MLFVEC(IFL)
40708 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40709 SBX = SB1*SBX
40710 100 CONTINUE
40711 110 CONTINUE
40712
40713 Y = -LOG(X)
40714 U = LOG(X/0.00001D0)
40715
40716 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40717 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40718 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40719 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40720 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40721
40722 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40723
40724C...Include threshold factor.
40725 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
40726
40727 RETURN
40728 END
40729
40730C*********************************************************************
40731
40732C...PYPDPO
40733C...Auxiliary to PYPDPR. Gives proton parton distributions according to
40734C...a few older parametrizations, now obsolete but convenient for
40735C...backwards checks.
40736
40737 SUBROUTINE PYPDPO(X,Q2,XPPR)
40738
40739C...Double precision and integer declarations.
40740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40741 IMPLICIT INTEGER(I-N)
40742 INTEGER PYK,PYCHGE,PYCOMP
40743C...Commonblocks.
40744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40747 COMMON/PYINT1/MINT(400),VINT(400)
40748 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40749 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
40750 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
40751
40752
40753C...The following data lines are coefficients needed in the
40754C...Eichten, Hinchliffe, Lane, Quigg proton structure function
40755C...parametrizations, see below.
40756C...Powers of 1-x in different cases.
40757 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
40758C...Expansion coefficients for up valence quark distribution.
40759 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
40760 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
40761 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
40762 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
40763 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
40764 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
40765 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
40766 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
40767 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
40768 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
40769 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
40770 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
40771 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
40772 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
40773 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
40774 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
40775 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
40776 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
40777 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
40778 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
40779 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
40780 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
40781 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
40782 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
40783 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
40784 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
40785C...Expansion coefficients for down valence quark distribution.
40786 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
40787 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
40788 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
40789 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
40790 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
40791 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
40792 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
40793 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
40794 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
40795 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
40796 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
40797 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
40798 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
40799 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
40800 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
40801 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
40802 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
40803 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
40804 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
40805 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
40806 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
40807 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
40808 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
40809 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
40810 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
40811 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
40812C...Expansion coefficients for up and down sea quark distributions.
40813 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
40814 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
40815 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
40816 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
40817 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
40818 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
40819 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
40820 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
40821 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
40822 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
40823 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
40824 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
40825 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
40826 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
40827 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
40828 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
40829 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
40830 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
40831 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
40832 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
40833 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
40834 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
40835 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
40836 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
40837 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
40838 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
40839C...Expansion coefficients for gluon distribution.
40840 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
40841 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
40842 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
40843 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
40844 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
40845 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
40846 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
40847 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
40848 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
40849 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
40850 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
40851 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
40852 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
40853 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
40854 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
40855 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
40856 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
40857 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
40858 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
40859 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
40860 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
40861 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
40862 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
40863 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
40864 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
40865 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
40866C...Expansion coefficients for strange sea quark distribution.
40867 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
40868 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
40869 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
40870 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
40871 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
40872 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
40873 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
40874 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
40875 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
40876 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
40877 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
40878 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
40879 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
40880 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
40881 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
40882 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
40883 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
40884 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
40885 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
40886 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
40887 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
40888 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
40889 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
40890 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
40891 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
40892 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
40893C...Expansion coefficients for charm sea quark distribution.
40894 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
40895 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
40896 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
40897 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
40898 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
40899 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
40900 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
40901 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
40902 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
40903 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
40904 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
40905 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
40906 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
40907 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
40908 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
40909 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
40910 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
40911 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
40912 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
40913 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
40914 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
40915 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
40916 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
40917 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
40918 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
40919 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
40920C...Expansion coefficients for bottom sea quark distribution.
40921 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
40922 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
40923 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
40924 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
40925 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
40926 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
40927 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
40928 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
40929 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
40930 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
40931 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40932 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40933 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40934 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40935 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40936 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40937 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40938 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40939 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40940 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40941 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40942 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40943 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40944 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40945 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40946 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40947C...Expansion coefficients for top sea quark distribution.
40948 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40949 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40950 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40951 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40952 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40953 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40954 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40955 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40956 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40957 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40958 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40959 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40960 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40961 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40962 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40963 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40964 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40965 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40966 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40967 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40968 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40969 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40970 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40971 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40972 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40973 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40974
40975C...The following data lines are coefficients needed in the
40976C...Duke, Owens proton structure function parametrizations, see below.
40977C...Expansion coefficients for (up+down) valence quark distribution.
40978 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40979 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40980 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40981 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40982 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40983 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40984 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40985 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40986C...Expansion coefficients for down valence quark distribution.
40987 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40988 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40989 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40990 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40991 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40992 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40993 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40994 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40995C...Expansion coefficients for (up+down+strange) sea quark distribution.
40996 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40997 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40998 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40999 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41000 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41001 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41002 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41003 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41004C...Expansion coefficients for charm sea quark distribution.
41005 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41006 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41007 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41008 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41009 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41010 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41011 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41012 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41013C...Expansion coefficients for gluon distribution.
41014 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41015 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41016 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41017 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41018 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41019 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41020 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41021 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41022
41023C...Euler's beta function, requires ordinary Gamma function
41024 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41025
41026C...Leading order proton parton distributions from Glueck, Reya and
41027C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41028C...10^-5 < x < 1.
41029 IF(MSTP(51).EQ.11) THEN
41030
41031C...Determine s expansion variable and some x expressions.
41032 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41033 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41034 SD2=SD**2
41035 XL=-LOG(X)
41036 XS=SQRT(X)
41037
41038C...Evaluate valence, gluon and sea distributions.
41039 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41040 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41041 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41042 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41043 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41044 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41045 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41046 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41047 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41048 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41049 & SQRT(4.066D0*SD**1.218D0*XL)))*
41050 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41051 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41052 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41053 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41054 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41055 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41056 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41057 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41058 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41059 IF(SD.LE.0.888D0) THEN
41060 XFCHM=0D0
41061 ELSE
41062 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41063 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41064 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41065 ENDIF
41066 IF(SD.LE.1.351D0) THEN
41067 XFBOT=0D0
41068 ELSE
41069 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41070 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41071 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41072 ENDIF
41073
41074C...Put into output array.
41075 XPPR(0)=XFGLU
41076 XPPR(1)=XFVDD+XFSEA
41077 XPPR(2)=XFVUD-XFVDD+XFSEA
41078 XPPR(3)=XFSTR
41079 XPPR(4)=XFCHM
41080 XPPR(5)=XFBOT
41081 XPPR(-1)=XFSEA
41082 XPPR(-2)=XFSEA
41083 XPPR(-3)=XFSTR
41084 XPPR(-4)=XFCHM
41085 XPPR(-5)=XFBOT
41086
41087C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41088C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41089 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41090
41091C...Determine set, Lambda and x and t expansion variables.
41092 NSET=MSTP(51)-11
41093 IF(NSET.EQ.1) ALAM=0.2D0
41094 IF(NSET.EQ.2) ALAM=0.29D0
41095 TMIN=LOG(5D0/ALAM**2)
41096 TMAX=LOG(1D8/ALAM**2)
41097 T=LOG(MAX(1D0,Q2/ALAM**2))
41098 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41099 NX=1
41100 IF(X.LE.0.1D0) NX=2
41101 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
41102 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
41103
41104C...Chebyshev polynomials for x and t expansion.
41105 TX(1)=1D0
41106 TX(2)=VX
41107 TX(3)=2D0*VX**2-1D0
41108 TX(4)=4D0*VX**3-3D0*VX
41109 TX(5)=8D0*VX**4-8D0*VX**2+1D0
41110 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
41111 TT(1)=1D0
41112 TT(2)=VT
41113 TT(3)=2D0*VT**2-1D0
41114 TT(4)=4D0*VT**3-3D0*VT
41115 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41116 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41117
41118C...Calculate structure functions.
41119 DO 120 KFL=1,6
41120 XQSUM=0D0
41121 DO 110 IT=1,6
41122 DO 100 IX=1,6
41123 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
41124 100 CONTINUE
41125 110 CONTINUE
41126 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
41127 120 CONTINUE
41128
41129C...Put into output array.
41130 XPPR(0)=XQ(4)
41131 XPPR(1)=XQ(2)+XQ(3)
41132 XPPR(2)=XQ(1)+XQ(3)
41133 XPPR(3)=XQ(5)
41134 XPPR(4)=XQ(6)
41135 XPPR(-1)=XQ(3)
41136 XPPR(-2)=XQ(3)
41137 XPPR(-3)=XQ(5)
41138 XPPR(-4)=XQ(6)
41139
41140C...Special expansion for bottom (threshold effects).
41141 IF(MSTP(58).GE.5) THEN
41142 IF(NSET.EQ.1) TMIN=8.1905D0
41143 IF(NSET.EQ.2) TMIN=7.4474D0
41144 IF(T.GT.TMIN) THEN
41145 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41146 TT(1)=1D0
41147 TT(2)=VT
41148 TT(3)=2D0*VT**2-1D0
41149 TT(4)=4D0*VT**3-3D0*VT
41150 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41151 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41152 XQSUM=0D0
41153 DO 140 IT=1,6
41154 DO 130 IX=1,6
41155 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
41156 130 CONTINUE
41157 140 CONTINUE
41158 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
41159 XPPR(-5)=XPPR(5)
41160 ENDIF
41161 ENDIF
41162
41163C...Special expansion for top (threshold effects).
41164 IF(MSTP(58).GE.6) THEN
41165 IF(NSET.EQ.1) TMIN=11.5528D0
41166 IF(NSET.EQ.2) TMIN=10.8097D0
41167 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
41168 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
41169 IF(T.GT.TMIN) THEN
41170 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41171 TT(1)=1D0
41172 TT(2)=VT
41173 TT(3)=2D0*VT**2-1D0
41174 TT(4)=4D0*VT**3-3D0*VT
41175 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41176 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41177 XQSUM=0D0
41178 DO 160 IT=1,6
41179 DO 150 IX=1,6
41180 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
41181 150 CONTINUE
41182 160 CONTINUE
41183 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
41184 XPPR(-6)=XPPR(6)
41185 ENDIF
41186 ENDIF
41187
41188C...Proton parton distributions from Duke, Owens.
41189C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
41190 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
41191
41192C...Determine set, Lambda and s expansion parameter.
41193 NSET=MSTP(51)-13
41194 IF(NSET.EQ.1) ALAM=0.2D0
41195 IF(NSET.EQ.2) ALAM=0.4D0
41196 Q2IN=MIN(1D6,MAX(4D0,Q2))
41197 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
41198
41199C...Calculate structure functions.
41200 DO 180 KFL=1,5
41201 DO 170 IS=1,6
41202 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
41203 & CDO(3,IS,KFL,NSET)*SD**2
41204 170 CONTINUE
41205 IF(KFL.LE.2) THEN
41206 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
41207 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
41208 ELSE
41209 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
41210 & TS(5)*X**2+TS(6)*X**3)
41211 ENDIF
41212 180 CONTINUE
41213
41214C...Put into output arrays.
41215 XPPR(0)=XQ(5)
41216 XPPR(1)=XQ(2)+XQ(3)/6D0
41217 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
41218 XPPR(3)=XQ(3)/6D0
41219 XPPR(4)=XQ(4)
41220 XPPR(-1)=XQ(3)/6D0
41221 XPPR(-2)=XQ(3)/6D0
41222 XPPR(-3)=XQ(3)/6D0
41223 XPPR(-4)=XQ(4)
41224
41225 ENDIF
41226
41227 RETURN
41228 END
41229
41230C*********************************************************************
41231
41232C...PYHFTH
41233C...Gives threshold attractive/repulsive factor for heavy flavour
41234C...production.
41235
41236 FUNCTION PYHFTH(SH,SQM,FRATT)
41237
41238C...Double precision and integer declarations.
41239 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41240 IMPLICIT INTEGER(I-N)
41241 INTEGER PYK,PYCHGE,PYCOMP
41242C...Commonblocks.
41243 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41244 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41245 COMMON/PYINT1/MINT(400),VINT(400)
41246 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
41247
41248C...Value for alpha_strong.
41249 IF(MSTP(35).LE.1) THEN
41250 ALSSG=PARP(35)
41251 ELSE
41252 MST115=MSTU(115)
41253 MSTU(115)=MSTP(36)
41254 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
41255 & PARP(36)**2)))
41256 ALSSG=PYALPS(Q2BN)
41257 MSTU(115)=MST115
41258 ENDIF
41259
41260C...Evaluate attractive and repulsive factors.
41261 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41262 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
41263 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41264 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
41265 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
41266 VINT(138)=PYHFTH
41267
41268 RETURN
41269 END
41270
41271C*********************************************************************
41272
41273C...PYSPLI
41274C...Splits a hadron remnant into two (partons or hadron + parton)
41275C...in case it is more complicated than just a quark or a diquark.
41276
41277 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
41278
41279C...Double precision and integer declarations.
41280 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41281 IMPLICIT INTEGER(I-N)
41282 INTEGER PYK,PYCHGE,PYCOMP
41283C...Commonblocks. PYDAT1 temporary
41284 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41285 COMMON/PYINT1/MINT(400),VINT(400)
41286 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41287 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
41288C...Local array.
41289 DIMENSION KFL(3)
41290
41291C...Preliminaries. Parton composition.
41292 KFA=IABS(KF)
41293 KFS=ISIGN(1,KF)
41294 KFL(1)=MOD(KFA/1000,10)
41295 KFL(2)=MOD(KFA/100,10)
41296 KFL(3)=MOD(KFA/10,10)
41297 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
41298 KFL(2)=INT(1.5D0+PYR(0))
41299 IF(MINT(105).EQ.333) KFL(2)=3
41300 IF(MINT(105).EQ.443) KFL(2)=4
41301 KFL(3)=KFL(2)
41302 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
41303 KFL(2)=2
41304 KFL(3)=2
41305 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
41306 KFL(2)=1
41307 KFL(3)=1
41308 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
41309 KFL(2)=MOD(KFA/10,10)
41310 KFL(3)=MOD(KFA/100,10)
41311 ENDIF
41312 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
41313 KFLR=KFLIN*KFS
41314 ELSE
41315 KFLR=KFLIN
41316 ENDIF
41317 KFLCH=0
41318
41319C...Subdivide lepton.
41320 IF(KFA.GE.11.AND.KFA.LE.18) THEN
41321 IF(KFLR.EQ.KFA) THEN
41322 KFLSP=KFS*22
41323 ELSEIF(KFLR.EQ.22) THEN
41324 KFLSP=KFA
41325 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
41326 KFLSP=KFA+1
41327 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
41328 KFLSP=KFA-1
41329 ELSEIF(KFLR.EQ.21) THEN
41330 KFLSP=KFA
41331 KFLCH=KFS*21
41332 ELSE
41333 KFLSP=KFA
41334 KFLCH=-KFLR
41335 ENDIF
41336
41337C...Subdivide photon.
41338 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
41339 IF(KFLR.NE.21) THEN
41340 KFLSP=-KFLR
41341 ELSE
41342 RAGR=0.75D0*PYR(0)
41343 KFLSP=1
41344 IF(RAGR.GT.0.125D0) KFLSP=2
41345 IF(RAGR.GT.0.625D0) KFLSP=3
41346 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
41347 KFLCH=-KFLSP
41348 ENDIF
41349
41350C...Subdivide Reggeon or Pomeron.
41351 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
41352 IF(KFLIN.EQ.21) THEN
41353 KFLSP=KFS*21
41354 ELSE
41355 KFLSP=-KFLIN
41356 ENDIF
41357
41358C...Subdivide meson.
41359 ELSEIF(KFL(1).EQ.0) THEN
41360 KFL(2)=KFL(2)*(-1)**KFL(2)
41361 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
41362 IF(KFLR.EQ.KFL(2)) THEN
41363 KFLSP=KFL(3)
41364 ELSEIF(KFLR.EQ.KFL(3)) THEN
41365 KFLSP=KFL(2)
41366 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
41367 KFLSP=KFL(2)
41368 KFLCH=KFL(3)
41369 ELSEIF(KFLR.EQ.21) THEN
41370 KFLSP=KFL(3)
41371 KFLCH=KFL(2)
41372 ELSEIF(KFLR*KFL(2).GT.0) THEN
41373 NTRY=0
41374 100 NTRY=NTRY+1
41375 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
41376 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41377 GOTO 100
41378 ELSEIF(KFLCH.EQ.0) THEN
41379 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41380 MINT(51)=1
41381 RETURN
41382 ENDIF
41383 KFLSP=KFL(3)
41384 ELSE
41385 NTRY=0
41386 110 NTRY=NTRY+1
41387 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
41388 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41389 GOTO 110
41390 ELSEIF(KFLCH.EQ.0) THEN
41391 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41392 MINT(51)=1
41393 RETURN
41394 ENDIF
41395 KFLSP=KFL(2)
41396 ENDIF
41397
41398C...Special case for extracting photon from baryon without splitting
41399C...the latter. (Currently only used by external programs.)
41400 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
41401 KFLSP=KFA
41402 KFLCH=0
41403
41404C...Subdivide baryon.
41405 ELSE
41406 NAGR=0
41407 DO 120 J=1,3
41408 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
41409 120 CONTINUE
41410 IF(NAGR.GE.1) THEN
41411 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
41412 IAGR=0
41413 DO 130 J=1,3
41414 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
41415 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
41416 130 CONTINUE
41417 ELSE
41418 IAGR=1.00001D0+2.99998D0*PYR(0)
41419 ENDIF
41420 ID1=1
41421 IF(IAGR.EQ.1) ID1=2
41422 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
41423 ID2=6-IAGR-ID1
41424 KSP=3
41425 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
41426 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
41427 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
41428 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
41429 ELSEIF(MOD(KFA,10).EQ.2) THEN
41430 IF(IAGR.EQ.1) KSP=1
41431 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
41432 ENDIF
41433 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
41434 IF(KFLR.EQ.21) THEN
41435 KFLCH=KFL(IAGR)
41436 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
41437 NTRY=0
41438 140 NTRY=NTRY+1
41439 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
41440 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41441 GOTO 140
41442 ELSEIF(KFLCH.EQ.0) THEN
41443 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41444 MINT(51)=1
41445 RETURN
41446 ENDIF
41447 ELSEIF(NAGR.EQ.0) THEN
41448 NTRY=0
41449 150 NTRY=NTRY+1
41450 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
41451 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41452 GOTO 150
41453 ELSEIF(KFLCH.EQ.0) THEN
41454 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41455 MINT(51)=1
41456 RETURN
41457 ENDIF
41458 KFLSP=KFL(IAGR)
41459 ENDIF
41460 ENDIF
41461
41462C...Add on correct sign for result.
41463 KFLCH=KFLCH*KFS
41464 KFLSP=KFLSP*KFS
41465
41466 RETURN
41467 END
41468
41469C*********************************************************************
41470
41471C...PYGAMM
41472C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
41473C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
41474C...(Dover, 1965) 6.1.36.
41475
41476 FUNCTION PYGAMM(X)
41477
41478C...Double precision and integer declarations.
41479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41480 IMPLICIT INTEGER(I-N)
41481 INTEGER PYK,PYCHGE,PYCOMP
41482C...Local array and data.
41483 DIMENSION B(8)
41484 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
41485 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
41486
41487 NX=INT(X)
41488 DX=X-NX
41489
41490 PYGAMM=1D0
41491 DXP=1D0
41492 DO 100 I=1,8
41493 DXP=DXP*DX
41494 PYGAMM=PYGAMM+B(I)*DXP
41495 100 CONTINUE
41496 IF(X.LT.1D0) THEN
41497 PYGAMM=PYGAMM/X
41498 ELSE
41499 DO 110 IX=1,NX-1
41500 PYGAMM=(X-IX)*PYGAMM
41501 110 CONTINUE
41502 ENDIF
41503
41504 RETURN
41505 END
41506
41507C***********************************************************************
41508
41509C...PYWAUX
41510C...Calculates real and imaginary parts of the auxiliary functions W1
41511C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
41512C...der Bij, Nucl. Phys. B297 (1988) 221.
41513
41514 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
41515
41516C...Double precision and integer declarations.
41517 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41518 IMPLICIT INTEGER(I-N)
41519 INTEGER PYK,PYCHGE,PYCOMP
41520C...Commonblocks.
41521 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41522 SAVE /PYDAT1/
41523
41524 ASINH(X)=LOG(X+SQRT(X**2+1D0))
41525 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
41526
41527 IF(EPS.LT.0D0) THEN
41528 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
41529 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
41530 WIM=0D0
41531 ELSEIF(EPS.LT.1D0) THEN
41532 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
41533 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
41534 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
41535 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
41536 ELSE
41537 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
41538 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
41539 WIM=0D0
41540 ENDIF
41541
41542 RETURN
41543 END
41544
41545C***********************************************************************
41546
41547C...PYI3AU
41548C...Calculates real and imaginary parts of the auxiliary function I3;
41549C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
41550C...Nucl. Phys. B297 (1988) 221.
41551
41552 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
41553
41554C...Double precision and integer declarations.
41555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41556 IMPLICIT INTEGER(I-N)
41557 INTEGER PYK,PYCHGE,PYCOMP
41558C...Commonblocks.
41559 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41560 SAVE /PYDAT1/
41561
41562 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
41563 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
41564
41565 IF(EPS.LT.0D0) THEN
41566 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41567 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41568 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41569 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
41570 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
41571 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
41572 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
41573 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
41574 & EPS))
41575 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41576 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41577 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41578 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
41579 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
41580 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
41581 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
41582 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
41583 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41584 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41585 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41586 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
41587 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
41588 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
41589 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
41590 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
41591 ELSE
41592 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41593 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
41594 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
41595 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
41596 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
41597 ENDIF
41598 F3IM=0D0
41599 ELSEIF(EPS.LT.1D0) THEN
41600 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41601 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41602 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41603 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
41604 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
41605 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41606 & (0.25D0*(RAT+1D0)*EPS))
41607 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41608 & (0.25D0*(RAT+1D0)*EPS))
41609 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41610 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41611 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41612 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
41613 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
41614 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
41615 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41616 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41617 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41618 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41619 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41620 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
41621 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
41622 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
41623 & (1D0+0.25D0*RAT*EPS-GA))
41624 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
41625 & (1D0+0.25D0*RAT*EPS-GA))
41626 ELSE
41627 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41628 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
41629 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
41630 & LOG((GA+BE-1D0)/(BE-GA))
41631 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
41632 ENDIF
41633 ELSE
41634 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
41635 RCTHE=RSQ*(1D0-2D0*BE/EPS)
41636 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
41637 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
41638 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
41639 R=SQRT(RSQ)
41640 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
41641 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
41642 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
41643 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
41644 & (PHI-THE)*(PHI+THE-PARU(1))
41645 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
41646 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
41647 ENDIF
41648
41649 Y3RE=2D0/(2D0*BE-1D0)*F3RE
41650 Y3IM=2D0/(2D0*BE-1D0)*F3IM
41651
41652 RETURN
41653 END
41654
41655C***********************************************************************
41656
41657C...PYSPEN
41658C...Calculates real and imaginary part of Spence function; see
41659C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
41660
41661 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
41662
41663C...Double precision and integer declarations.
41664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41665 IMPLICIT INTEGER(I-N)
41666 INTEGER PYK,PYCHGE,PYCOMP
41667C...Commonblocks.
41668 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41669 SAVE /PYDAT1/
41670C...Local array and data.
41671 DIMENSION B(0:14)
41672 DATA B/
41673 &1.000000D+00, -5.000000D-01, 1.666667D-01,
41674 &0.000000D+00, -3.333333D-02, 0.000000D+00,
41675 &2.380952D-02, 0.000000D+00, -3.333333D-02,
41676 &0.000000D+00, 7.575757D-02, 0.000000D+00,
41677 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
41678
41679 XRE=XREIN
41680 XIM=XIMIN
41681 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
41682 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
41683 IF(IREIM.EQ.2) PYSPEN=0D0
41684 RETURN
41685 ENDIF
41686
41687 XMOD=SQRT(XRE**2+XIM**2)
41688 IF(XMOD.LT.1D-6) THEN
41689 IF(IREIM.EQ.1) PYSPEN=0D0
41690 IF(IREIM.EQ.2) PYSPEN=0D0
41691 RETURN
41692 ENDIF
41693
41694 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41695 SP0RE=0D0
41696 SP0IM=0D0
41697 SGN=1D0
41698 IF(XMOD.GT.1D0) THEN
41699 ALGXRE=LOG(XMOD)
41700 ALGXIM=XARG-SIGN(PARU(1),XARG)
41701 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
41702 SP0IM=-ALGXRE*ALGXIM
41703 SGN=-1D0
41704 XMOD=1D0/XMOD
41705 XARG=-XARG
41706 XRE=XMOD*COS(XARG)
41707 XIM=XMOD*SIN(XARG)
41708 ENDIF
41709 IF(XRE.GT.0.5D0) THEN
41710 ALGXRE=LOG(XMOD)
41711 ALGXIM=XARG
41712 XRE=1D0-XRE
41713 XIM=-XIM
41714 XMOD=SQRT(XRE**2+XIM**2)
41715 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41716 ALGYRE=LOG(XMOD)
41717 ALGYIM=XARG
41718 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
41719 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
41720 SGN=-SGN
41721 ENDIF
41722
41723 XRE=1D0-XRE
41724 XIM=-XIM
41725 XMOD=SQRT(XRE**2+XIM**2)
41726 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41727 ZRE=-LOG(XMOD)
41728 ZIM=-XARG
41729
41730 SPRE=0D0
41731 SPIM=0D0
41732 SAVERE=1D0
41733 SAVEIM=0D0
41734 DO 100 I=0,14
41735 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
41736 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
41737 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
41738 SAVERE=TERMRE
41739 SAVEIM=TERMIM
41740 SPRE=SPRE+B(I)*TERMRE
41741 SPIM=SPIM+B(I)*TERMIM
41742 100 CONTINUE
41743
41744 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
41745 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
41746
41747 RETURN
41748 END
41749
41750C***********************************************************************
41751
41752C...PYQQBH
41753C...Calculates the matrix element for the processes
41754C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
41755C...REDUCE output and part of the rest courtesy Z. Kunszt, see
41756C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
41757
41758 SUBROUTINE PYQQBH(WTQQBH)
41759
41760C...Double precision and integer declarations.
41761 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41762 IMPLICIT INTEGER(I-N)
41763 INTEGER PYK,PYCHGE,PYCOMP
41764C...Commonblocks.
41765 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41766 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41767 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41768 COMMON/PYINT1/MINT(400),VINT(400)
41769 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41770 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
41771C...Local arrays and function.
41772 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
41773 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
41774 &PP(I,3)*PP(J,3)
41775
41776C...Mass parameters.
41777 WTQQBH=0D0
41778 ISUB=MINT(1)
41779 SHPR=SQRT(VINT(26))*VINT(1)
41780 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
41781 PH=SQRT(VINT(21))*VINT(1)
41782 SPQ=PQ**2
41783 SPH=PH**2
41784
41785C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
41786 DO 100 I=1,2
41787 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41788 PP(I,1)=PT*COS(VINT(198+5*I))
41789 PP(I,2)=PT*SIN(VINT(198+5*I))
41790 100 CONTINUE
41791 PP(3,1)=-PP(1,1)-PP(2,1)
41792 PP(3,2)=-PP(1,2)-PP(2,2)
41793 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
41794 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
41795 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
41796 PMT3=SQRT(PMS3)
41797 PP(3,3)=PMT3*SINH(VINT(211))
41798 PP(3,4)=PMT3*COSH(VINT(211))
41799 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
41800 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41801 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
41802 PP(2,3)=-PP(1,3)-PP(3,3)
41803 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
41804 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
41805
41806C...Set up incoming kinematics and derived momentum combinations.
41807 DO 110 I=4,5
41808 PP(I,1)=0D0
41809 PP(I,2)=0D0
41810 PP(I,3)=-0.5D0*SHPR*(-1)**I
41811 PP(I,4)=-0.5D0*SHPR
41812 110 CONTINUE
41813 DO 120 J=1,4
41814 PP(6,J)=PP(1,J)+PP(2,J)
41815 PP(7,J)=PP(1,J)+PP(3,J)
41816 PP(8,J)=PP(1,J)+PP(4,J)
41817 PP(9,J)=PP(1,J)+PP(5,J)
41818 PP(10,J)=-PP(2,J)-PP(3,J)
41819 PP(11,J)=-PP(2,J)-PP(4,J)
41820 PP(12,J)=-PP(2,J)-PP(5,J)
41821 PP(13,J)=-PP(4,J)-PP(5,J)
41822 120 CONTINUE
41823
41824C...Derived kinematics invariants.
41825 X1=DOT(1,2)
41826 X2=DOT(1,3)
41827 X3=DOT(1,4)
41828 X4=DOT(1,5)
41829 X5=DOT(2,3)
41830 X6=DOT(2,4)
41831 X7=DOT(2,5)
41832 X8=DOT(3,4)
41833 X9=DOT(3,5)
41834 X10=DOT(4,5)
41835
41836C...Propagators.
41837 SS1=DOT(7,7)-SPQ
41838 SS2=DOT(8,8)-SPQ
41839 SS3=DOT(9,9)-SPQ
41840 SS4=DOT(10,10)-SPQ
41841 SS5=DOT(11,11)-SPQ
41842 SS6=DOT(12,12)-SPQ
41843 SS7=DOT(13,13)
41844 DX(1)=SS1*SS6
41845 DX(2)=SS2*SS6
41846 DX(3)=SS2*SS4
41847 DX(4)=SS1*SS5
41848 DX(5)=SS3*SS5
41849 DX(6)=SS3*SS4
41850 DX(7)=SS7*SS1
41851 DX(8)=SS7*SS4
41852
41853C...Define colour coefficients for g + g -> Q + Qbar + H.
41854 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
41855 DO 140 I=1,3
41856 DO 130 J=1,3
41857 CLR(I,J)=16D0/3D0
41858 CLR(I+3,J+3)=16D0/3D0
41859 CLR(I,J+3)=-2D0/3D0
41860 CLR(I+3,J)=-2D0/3D0
41861 130 CONTINUE
41862 140 CONTINUE
41863 DO 160 L=1,2
41864 DO 150 I=1,3
41865 CLR(I,6+L)=-6D0
41866 CLR(I+3,6+L)=6D0
41867 CLR(6+L,I)=-6D0
41868 CLR(6+L,I+3)=6D0
41869 150 CONTINUE
41870 160 CONTINUE
41871 DO 180 K1=1,2
41872 DO 170 K2=1,2
41873 CLR(6+K1,6+K2)=12D0
41874 170 CONTINUE
41875 180 CONTINUE
41876
41877C...Evaluate matrix elements for g + g -> Q + Qbar + H.
41878 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
41879 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
41880 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
41881 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
41882 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
41883 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
41884 & X10)
41885 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
41886 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
41887 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41888 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
41889 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
41890 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
41891 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
41892 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
41893 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
41894 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
41895 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
41896 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
41897 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41898 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
41899 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
41900 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
41901 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
41902 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
41903 & X4*X6*X5)
41904 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
41905 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
41906 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
41907 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
41908 & +X4*X9*X5+X4*X5**2)
41909 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
41910 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
41911 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
41912 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
41913 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
41914 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
41915 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
41916 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
41917 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
41918 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
41919 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
41920 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
41921 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
41922 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
41923 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
41924 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
41925 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
41926 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
41927 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
41928 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
41929 & X6)
41930 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
41931 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41932 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
41933 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
41934 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
41935 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
41936 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
41937 & X5+X4*X6*X5)
41938 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41939 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41940 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41941 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41942 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41943 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41944 & X6**2)
41945 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41946 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41947 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41948 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41949 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41950 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41951 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41952 & X4*X6*X5)
41953 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41954 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41955 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41956 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41957 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41958 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41959 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41960 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41961 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41962 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41963 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41964 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41965 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41966 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41967 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41968 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41969 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41970 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41971 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41972 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41973 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41974 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41975 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41976 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41977 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41978 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41979 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41980 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41981 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41982 & +X3*X8*X5+X3*X5**2)
41983 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41984 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41985 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41986 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41987 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41988 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41989 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41990 & X5+X4*X6*X5)
41991 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41992 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41993 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41994 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41995 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41996 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41997 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41998 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41999 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42000 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42001 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42002 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42003 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42004 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42005 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42006 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42007 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42008 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42009 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42010 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42011 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42012 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42013 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42014 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42015 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42016 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42017 & X10)
42018 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42019 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42020 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42021 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42022 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42023 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42024 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42025 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42026 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42027 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42028 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42029 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42030 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42031 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42032 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42033 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42034 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42035 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42036 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42037 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42038 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42039 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42040 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42041 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42042 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42043 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42044 & X7)
42045 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42046 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42047 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42048 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42049 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42050 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42051 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42052 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42053 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42054 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42055 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42056 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42057 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42058 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42059 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42060 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42061 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42062 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42063 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42064 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42065 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42066 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42067 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42068 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42069 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42070 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42071 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42072 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42073 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42074 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42075 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42076 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42077 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42078 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42079 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42080 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42081 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42082 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42083 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42084 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42085 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42086 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42087 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42088 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42089 & *X6)
42090 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42091 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42092 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42093 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42094 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42095 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42096 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
42097 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
42098 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
42099 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
42100 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
42101 & X8)
42102 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42103 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
42104 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
42105 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42106 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
42107 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
42108 & X9*X5)
42109 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42110 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
42111 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
42112 & X8*X5)
42113 FM(9,10)=0.5D0*(FMXX+FM(9,10))
42114 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42115 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
42116 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
42117
42118C...Repackage matrix elements.
42119 DO 200 I=1,8
42120 DO 190 J=I,8
42121 RM(I,J)=FM(I,J)
42122 190 CONTINUE
42123 200 CONTINUE
42124 RM(7,7)=FM(7,7)-2D0*FM(9,9)
42125 RM(7,8)=FM(7,8)-2D0*FM(9,10)
42126 RM(8,8)=FM(8,8)-2D0*FM(10,10)
42127
42128C...Produce final result: matrix elements * colours * propagators.
42129 DO 220 I=1,8
42130 DO 210 J=I,8
42131 FAC=8D0
42132 IF(I.EQ.J)FAC=4D0
42133 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
42134 210 CONTINUE
42135 220 CONTINUE
42136 WTQQBH=-WTQQBH/256D0
42137
42138 ELSE
42139C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42140 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
42141 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
42142 & *X6+X8*X7)
42143 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
42144 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
42145 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
42146 & X5)
42147 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
42148 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
42149 & *X9+X4*X8)
42150
42151C...Produce final result: matrix elements * propagators.
42152 A11=A11/DX(7)**2
42153 A12=A12/(DX(7)*DX(8))
42154 A22=A22/DX(8)**2
42155 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
42156 ENDIF
42157
42158 RETURN
42159 END
42160
42161C*********************************************************************
42162
42163C...PYSTBH (and auxiliaries)
42164C.. Evaluates the matrix elements for t + b + H production.
42165
42166 SUBROUTINE PYSTBH(WTTBH)
42167
42168C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42169 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42170 IMPLICIT INTEGER(I-N)
42171 INTEGER PYK,PYCHGE,PYCOMP
42172
42173C...COMMONBLOCKS
42174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42176 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42177 COMMON/PYINT1/MINT(400),VINT(400)
42178 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42179 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
42180 COMMON/PYINT4/MWID(500),WIDS(500,5)
42181 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
42182 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42183 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
42184 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
42185 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
42186 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
42187 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42188 DOUBLE PRECISION MW2
42189 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
42190 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
42191
42192C...LOCAL ARRAYS AND COMPLEX VARIABLES
42193 DIMENSION QQ(4,2),PP(4,3)
42194 DATA QQ/8*0D0/
42195
42196 WTTBH=0D0
42197
42198C...KINEMATIC PARAMETERS.
42199 SHPR=SQRT(VINT(26))*VINT(1)
42200 PH=SQRT(VINT(21))*VINT(1)
42201 SPH=PH**2
42202
42203C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
42204 DO 100 I=1,2
42205 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42206 PP(1,I)=PT*COS(VINT(198+5*I))
42207 PP(2,I)=PT*SIN(VINT(198+5*I))
42208 100 CONTINUE
42209 PP(1,3)=-PP(1,1)-PP(1,2)
42210 PP(2,3)=-PP(2,1)-PP(2,2)
42211 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
42212 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
42213 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
42214 PMT3=SQRT(PMS3)
42215 PP(3,3)=PMT3*SINH(VINT(211))
42216 PP(4,3)=PMT3*COSH(VINT(211))
42217 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
42218 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42219 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
42220 PP(3,2)=-PP(3,1)-PP(3,3)
42221 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
42222 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
42223
42224C...CM SYSTEM, INGOING QUARKS/GLUONS
42225 QQ(3,1) = SHPR/2.D0
42226 QQ(4,1) = QQ(3,1)
42227 QQ(3,2) = -QQ(3,1)
42228 QQ(4,2) = QQ(4,1)
42229
42230C...PARAMETERS FOR AMPLITUDE METHOD
42231 ALPHA = AEM
42232 ALPHAS = AS
42233 SW2 = PARU(102)
42234 MW2 = PMAS(24,1)**2
42235 TANB = PARU(141)
42236 VTB = VCKM(3,3)
42237 RMB=PYMRUN(5,VINT(52))
42238
42239 ISUB=MINT(1)
42240
42241 IF (ISUB.EQ.401) THEN
42242 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42243 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42244 ELSE IF (ISUB.EQ.402) THEN
42245 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42246 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42247 END IF
42248
42249 RETURN
42250 END
42251C------------------------------------------------------------------
42252 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
42253C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
42254 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42255 IMPLICIT INTEGER(I-N)
42256 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
42257 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42258 SAVE /PYCTBH/
42259
42260C TOP WIDTH CALCULATION
42261C VTB = 0.99
42262 MW=DSQRT(MW2)
42263 XB=(MB/MT)**2
42264 XW=(MW/MT)**2
42265 XH =(MHP/MT)**2
42266 GAMTBH = 0D0
42267 IF (MT .LT. (MHP+MB)) THEN
42268C T ->B W ONLY
42269 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42270 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42271 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42272 GAMT = GAMTBW
42273 ELSE
42274C T ->BW +T ->B H^+
42275 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42276 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42277 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42278C
42279 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
42280 & -4.D0*(MHP*MB/MT**2)**2 )
42281 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
42282 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
42283 GAMT = GAMTBW+GAMTBH
42284 ENDIF
42285C THUS BR IS
42286 BR=GAMTBH/GAMT
42287 RETURN
42288 END
42289
42290C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
42291C GG->TBH^+, QQBAR->TBH^+
42292C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
42293C (FOR INSTANCE WITH PYTHIA)
42294C------------------------------------------------------------
42295C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
42296C PHYS REV. D 60 (1999) 115011
42297C (THESE FILES PREPARED BY J.-L. KNEUR)
42298C------------------------------------------------------------
42299C 1) GG->TBH^+
42300 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42301C
42302C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
42303C
42304C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
42305C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
42306C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
42307C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
42308C "PHYSICAL PARAMETERS" INPUT:
42309C MT,MB TOP AND BOTTOM MASSES;
42310C MHP CHARGED HIGGS MASS
42311C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
42312C
42313C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
42314C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
42315C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
42316C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
42317C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
42318C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
42319C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
42320C
42321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42322 IMPLICIT INTEGER(I-N)
42323 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42324 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42326 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42327 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42328
42329 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42330 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42331C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42332C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42333C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42334C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
42335C (TAN BETA) VALUES
42336C
42337C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42338C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42339
42340 PI = 4*DATAN(1.D0)
42341 MW = DSQRT(MW2)
42342C
42343C COLLECTING THE RELEVANT OVERALL FACTORS:
42344C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
42345 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
42346C COUPLING CONSTANT (OVERALL NORMALIZATION)
42347 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42348C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42349C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42350C ALPHAS IS ALPHA_STRONG;
42351C SW2 IS SIN(THETA_W)**2.
42352C
42353C VTB=.998D0
42354C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42355C
42356 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42357 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42358C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42359C
42360C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42361C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42362 DO 100 KK=1,4
42363 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42364 100 CONTINUE
42365C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42366 S = 2*PYTBHS(Q1,Q2)
42367 P1Q1=PYTBHS(Q1,P1)
42368 P1Q2=PYTBHS(P1,Q2)
42369 P2Q1=PYTBHS(P2,Q1)
42370 P2Q2=PYTBHS(P2,Q2)
42371 P1P2=PYTBHS(P1,P2)
42372C
42373C TOP WIDTH CALCULATION
42374 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42375C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42376C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42377 A1INV= S -2*P1Q1 -2*P1Q2
42378 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42379C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42380C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
42381C THE TOP WIDTH
42382 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42383 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42384C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42385C NOW COMES THE AMP**2:
42386C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
42387C THE EXPRESSIONS BELOW
42388 V18=0.D0
42389 A18=0.D0
42390 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
42391 &512*A1*A2*MB*MT/3-
42392 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42393 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
42394 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
42395 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42396 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
42397 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
42398 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
42399 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
42400 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42401 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42402 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
42403 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
42404 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42405 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42406 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
42407 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
42408 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
42409 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
42410 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42411 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
42412 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
42413 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42414 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42415 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42416 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
42417 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42418 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42419 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42420 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42421 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42422 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
42423 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42424 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42425 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
42426 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
42427 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42428 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
42429 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42430 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42431 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
42432 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
42433 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42434 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
42435 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42436 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42437 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42438 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42439 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
42440 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
42441 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42442 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
42443 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42444 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42445 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42446 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42447 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42448 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
42449 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
42450 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
42451 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42452 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42453 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42454 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42455 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42456 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
42457 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42458 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42459 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42460 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
42461 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42462 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
42463 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42464 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42465 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
42466 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42467 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42468 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42469 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
42470 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42471 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42472 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42473 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42474 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42475 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42476 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
42477 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42478 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42479 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
42480 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42481 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42482 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42483 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42484 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42485 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42486 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
42487 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42488 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42489 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42490 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
42491 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42492 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42493 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42494 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42495 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42496 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
42497 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42498 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
42499 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42500 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
42501 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
42502 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42503 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42504 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42505 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42506 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
42507 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42508 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42509 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42510 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42511 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42512 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
42513 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42514 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42515 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42516 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42517 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42518 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
42519 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
42520 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42521 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42522 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42523 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
42524 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42525 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42526 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42527 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42528 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42529 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
42530 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42531 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
42532 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42533 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42534 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
42535 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42536 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42537 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42538 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42539 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42540 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
42541 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42542 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42543 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42544 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42545 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42546 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42547 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42548 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
42549 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42550 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42551 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42552 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42553 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42554 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
42555 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42556 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42557 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42558 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42559 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42560 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42561 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
42562 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42563 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
42564 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42565 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42566 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42567 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42568 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42569 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42570 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42571 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42572 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
42573 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42574 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42575 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
42576 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42577 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42578 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42579 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42580 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42581 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
42582 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42583 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42584 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42585 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
42586 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42587 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42588 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
42589 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42590 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42591 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42592 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42593 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42594 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42595 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42596 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42597 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42598 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42599 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42600 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42601 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42602 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42603 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42604 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42605 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42606 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42607 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42608 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
42609 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42610 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42611 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42612 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42613 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42614 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42615 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42616 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42617 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
42618 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42619 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42620 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42621 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42622 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42623 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42624 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42625 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42626 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
42627 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42628 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42629 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42630 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42631 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42632 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
42633 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42634 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42635 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42636 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42637 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42638 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42639 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42640 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42641 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
42642 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42643 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42644 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42645 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42646 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42647 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42648 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42649 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42650 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42651 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42652 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42653 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42654 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42655 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42656 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42657 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42658 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
42659 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42660 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42661 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42662 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
42663 &384*A12*MB*MT*P1Q1**2/S**2+
42664 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42665 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
42666 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42667 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42668 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42669 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42670 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
42671 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42672 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42673 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42674 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42675 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42676 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42677 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42678 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42679 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
42680 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42681 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
42682 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
42683 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
42684 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
42685 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
42686 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42687 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
42688 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
42689 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
42690 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
42691 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
42692 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
42693 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42694 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
42695 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42696 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
42697 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
42698 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42699 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42700 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
42701 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
42702 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
42703 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
42704 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42705 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42706 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42707 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42708 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
42709 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42710 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
42711 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
42712 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
42713 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
42714 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
42715 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42716 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
42717 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42718 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42719 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42720 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42721 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42722 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42723 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42724 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42725 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42726 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42727 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
42728 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
42729 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
42730 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
42731 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
42732 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
42733 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42734 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42735 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42736 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
42737 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42738 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
42739 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42740 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42741 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42742 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42743 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42744 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42745 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
42746 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42747 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
42748 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42749 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
42750 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42751 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42752 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
42753 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
42754 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42755 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42756 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42757 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42758 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
42759 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42760 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
42761 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42762 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42763 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42764 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
42765 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42766 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
42767 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42768 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
42769 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
42770 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
42771 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42772 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
42773 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
42774 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42775 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42776 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42777 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42778 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42779 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42780 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42781 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42782 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42783 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
42784 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42785 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42786 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42787 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42788 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42789 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42790 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42791 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42792 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42793 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
42794 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42795 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
42796 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42797 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42798 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42799 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42800 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
42801 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
42802 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42803 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
42804 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
42805 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42806 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42807 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
42808 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42809 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42810 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
42811 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42812 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42813 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42814 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
42815 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
42816 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42817 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
42818 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
42819 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42820 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42821 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42822 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42823 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42824 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42825 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
42826 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
42827 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
42828 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42829 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42830 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42831 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42832 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42833 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
42834 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
42835 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42836 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42837 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42838 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
42839 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
42840
42841 V18BIS=
42842 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42843 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42844 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42845 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42846 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42847 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42848 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42849 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42850 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42851 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42852 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
42853 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42854 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42855 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
42856 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42857 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
42858 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
42859 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
42860 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42861 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42862 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42863 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42864 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42865 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42866 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
42867 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
42868 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42869 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42870 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
42871 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
42872 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42873 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
42874 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
42875 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
42876 &272*A1*A2*P1Q1*S/(3*P1Q2)+
42877 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
42878 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42879 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
42880 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42881 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42882 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42883 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42884 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42885 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
42886 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42887 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42888 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
42889 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42890 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
42891 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
42892 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42893 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42894 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
42895 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
42896 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
42897 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42898 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
42899 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42900 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
42901 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42902 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42903 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
42904 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42905 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42906 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
42907 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42908 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
42909 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
42910 &32*A12*P2Q1*S/(3*P1Q1)-
42911 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42912 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
42913 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
42914 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42915 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42916 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42917 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42918 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42919 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
42920 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42921 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42922 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
42923 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42924 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42925 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
42926 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
42927 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
42928 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42929 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
42930 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42931 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42932 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
42933 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42934 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
42935 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42936 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
42937 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42938 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42939 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42940 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42941 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42942 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42943 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42944 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42945 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42946 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42947 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42948 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42949 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42950 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42951 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42952 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42953 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42954 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42955 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42956 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42957 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42958 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42959 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42960 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42961 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42962 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42963 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42964 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42965 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42966 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42967 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42968 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42969 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42970 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42971 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42972 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42973 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42974 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42975 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42976 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42977 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42978 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42979 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42980 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42981 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42982 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42983 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42984 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42985C
42986
42987 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42988 &512*A1*A2*MB*MT/3+
42989 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42990 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42991 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42992 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42993 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42994 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42995 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42996 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42997 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42998 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42999 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43000 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43001 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43002 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43003 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43004 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43005 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43006 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43007 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43008 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43009 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43010 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43011 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43012 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43013 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43014 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43015 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43016 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43017 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43018 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43019 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43020 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43021 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43022 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43023 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43024 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43025 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43026 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43027 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43028 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43029 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43030 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43031 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43032 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43033 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43034 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43035 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43036 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43037 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43038 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43039 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43040 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43041 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43042 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43043 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43044 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43045 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43046 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43047 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43048 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43049 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43050 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43051 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43052 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43053 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43054 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43055 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43056 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43057 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43058 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43059 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43060 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43061 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43062 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43063 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43064 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43065 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43066 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43067 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43068 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43069 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43070 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43071 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43072 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43073 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43074 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43075 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43076 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43077 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43078 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43079 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43080 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43081 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43082 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43083 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43084 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43085 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43086 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43087 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43088 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43089 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43090 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43091 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43092 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43093 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43094 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43095 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43096 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43097 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
43098 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
43099 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43100 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43101 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43102 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43103 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
43104 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43105 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43106 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43107 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43108 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43109 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
43110 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43111 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43112 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43113 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43114 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43115 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
43116 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
43117 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43118 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43119 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43120 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
43121 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43122 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43123 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43124 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43125 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43126 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
43127 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43128 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
43129 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43130 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43131 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
43132 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43133 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43134 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43135 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43136 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43137 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43138 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43139 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43140 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43141 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43142 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
43143 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43144 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43145 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
43146 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43147 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43148 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
43149 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43150 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43151 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
43152 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43153 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43154 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
43155 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43156 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43157 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43158 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
43159 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43160 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
43161 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43162 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43163 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43164 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43165 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43166 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43167 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43168 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43169 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43170 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43171 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43172 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43173 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43174 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43175 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43176 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43177 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43178 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
43179 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43180 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43181 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43182 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
43183 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43184 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43185 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
43186 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43187 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43188 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43189 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43190 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43191 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43192 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43193 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43194 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43195 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43196 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43197 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43198 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43199 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
43200 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43201 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43202 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43203 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43204 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43205 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
43206 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43207 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43208 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43209 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43210 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43211 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43212 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43213 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43214 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
43215 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43216 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43217 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43218 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43219 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43220 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43221 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43222 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43223 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
43224 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43225 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43226 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43227 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43228 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43229 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
43230 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43231 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43232 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
43233 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43234 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43235 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43236 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43237 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43238 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
43239 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43240 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43241 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43242 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43243 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43244 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43245 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43246 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43247 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
43248 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43249 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43250 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43251 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43252 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43253 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43254 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43255 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
43256 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43257 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43258 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43259 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
43260 &384*A12*MB*MT*P1Q1**2/S**2+
43261 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43262 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
43263 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43264 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43265 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43266 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43267 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
43268 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43269 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43270 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43271 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43272 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43273 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43274 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43275 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
43276 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
43277 &384*A2**2*MB*MT*P2Q2**2/S**2+
43278 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43279 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
43280 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
43281 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
43282 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
43283 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
43284 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43285 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
43286 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
43287 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
43288 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
43289 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
43290 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
43291 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43292 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
43293 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43294 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
43295 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43296 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43297 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
43298 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
43299 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
43300 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
43301 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43302 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43303 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43304 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43305 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
43306 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43307 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
43308 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
43309 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
43310 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
43311 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
43312 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43313 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
43314 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43315 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
43316 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43317 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43318 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43319 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
43320 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43321 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43322 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43323 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43324 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
43325 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
43326 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
43327 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
43328 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
43329 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43330 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43331 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43332 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
43333 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43334 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
43335 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43336 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43337 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43338 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43339 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43340 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43341 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
43342 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43343 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
43344 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43345 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
43346 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43347 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43348 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
43349 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
43350 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43351 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43352 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43353 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43354 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
43355 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43356 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
43357 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43358 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
43359 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43360 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
43361 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43362 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
43363 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43364 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
43365 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
43366 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
43367 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43368 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
43369 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
43370 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43371 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43372 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43373 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43374 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
43375 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43376 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43377 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
43378 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
43379 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
43380 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43381 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43382 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43383 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43384 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43385 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43386 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43387 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43388 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43389 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
43390 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43391 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
43392 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43393 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43394 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
43395 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
43396 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43397 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
43398 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43399 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
43400 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
43401 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43402 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43403 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
43404 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43405 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43406 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
43407 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43408 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43409 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43410 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
43411 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
43412 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43413 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
43414 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43415 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43416 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43417 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43418 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43419 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43420 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
43421 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
43422 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
43423 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43424 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43425 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43426 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
43427 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43428 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
43429 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
43430 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43431 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43432 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43433 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43434 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43435 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43436 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43437 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43438 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43439 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43440 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43441 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
43442 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43443 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43444 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43445 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
43446 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43447 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43448 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
43449 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43450 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
43451 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
43452 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43453 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43454 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43455 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43456 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43457 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43458 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
43459 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
43460 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43461 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43462 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
43463 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
43464 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43465 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
43466 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
43467 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
43468 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
43469 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43470 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
43471
43472 A18BIS=
43473 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43474 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43475 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43476 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43477 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43478 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
43479 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43480 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43481 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
43482 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43483 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
43484 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
43485 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43486 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43487 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
43488 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
43489 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
43490 &12*S/(P1Q2*P2Q1)+
43491 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43492 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
43493 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43494 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
43495 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43496 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43497 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43498 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43499 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43500 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
43501 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43502 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
43503 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
43504 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43505 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
43506 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
43507 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
43508 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43509 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43510 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43511 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43512 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43513 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
43514 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43515 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43516 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
43517 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43518 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43519 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
43520 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
43521 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43522 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
43523 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43524 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43525 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
43526 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43527 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
43528 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43529 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
43530 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43531 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43532 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43533 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43534 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43535 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
43536 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
43537 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43538 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
43539 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
43540 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43541 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43542 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43543 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43544 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43545 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43546 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43547 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43548 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43549 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43550 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43551 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43552 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
43553 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
43554 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
43555 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43556 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
43557 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43558 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43559 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43560 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43561 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43562 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43563 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43564 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
43565 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43566 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43567 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43568 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
43569 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
43570 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43571 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43572 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
43573 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
43574 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43575 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43576 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43577C
43578 V18=V18+V18BIS
43579 A18=A18+A18BIS
43580 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
43581 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
43582 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43583 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43584 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43585 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
43586 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43587 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43588 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43589 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43590 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43591 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43592 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
43593 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
43594 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
43595 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
43596 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
43597 V910=V910+96*A1*A2*P1P2*P2Q1/S-
43598 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43599 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
43600 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
43601 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43602 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43603C
43604 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
43605 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
43606 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43607 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43608 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43609 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
43610 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43611 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43612 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
43613 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43614 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43615 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43616 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
43617 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
43618 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
43619 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
43620 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
43621 A910=A910+96*A1*A2*P1P2*P2Q1/S-
43622 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43623 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
43624 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
43625 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43626 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43627C
43628C FINAL RESULT;
43629C
43630 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
43631
43632 END
43633C---------------------------------------------------------
43634C 2) Q QBAR ->TBH^+
43635 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43636C
43637C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
43638C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
43639 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43640 IMPLICIT INTEGER(I-N)
43641 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43642 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43643 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43644 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43645 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43646 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43647 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43648C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43649C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43650C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43651C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
43652C
43653C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43654C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43655C
43656 DIMENSION YY(2,2)
43657
43658 PI = 4*DATAN(1.D0)
43659 MW = DSQRT(MW2)
43660
43661C COLLECTING THE RELEVANT OVERALL FACTORS:
43662C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
43663 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
43664C COUPLING CONSTANT (OVERALL NORMALIZATION)
43665 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43666C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43667C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43668C ALPHAS IS ALPHA_STRONG;
43669C SW2 IS SIN(THETA_W)**2.
43670C
43671C VTB=.998D0
43672C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43673C
43674 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43675 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43676C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43677C
43678C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43679C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43680 DO 100 KK=1,4
43681 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43682 100 CONTINUE
43683C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43684 S = 2*PYTBHS(Q1,Q2)
43685 P1Q1=PYTBHS(Q1,P1)
43686 P1Q2=PYTBHS(P1,Q2)
43687 P2Q1=PYTBHS(P2,Q1)
43688 P2Q2=PYTBHS(P2,Q2)
43689 P1P2=PYTBHS(P1,P2)
43690C
43691C TOP WIDTH CALCULATION
43692 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43693C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43694C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43695 A1INV= S -2*P1Q1 -2*P1Q2
43696 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43697C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43698C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
43699 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43700 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43701C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43702C NOW COMES THE AMP**2:
43703C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
43704C THE EXPRESSIONS BELOW
43705 YY(1, 1) = -16*A**2*A2**2*MB*MT+
43706 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
43707 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
43708 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
43709 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43710 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43711 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
43712 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
43713 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
43714 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
43715 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
43716 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
43717 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
43718 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
43719 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43720 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43721 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
43722 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
43723 &32*A2**2*MB**2*P1P2*V**2/S+
43724 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
43725 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
43726 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
43727 YY(1, 1)=2*YY(1, 1)
43728
43729 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
43730 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
43731 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43732 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43733 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
43734 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
43735 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
43736 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43737 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
43738 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43739 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
43740 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43741 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
43742 &64*A**2*A1*A2*MB*MT*P1P2/S+
43743 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
43744 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
43745 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
43746 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
43747 &64*A**2*A1*A2*P1Q1*P2Q1/S-
43748 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
43749 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
43750 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
43751 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
43752 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
43753 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
43754 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
43755 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
43756 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
43757 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
43758 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
43759 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43760 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43761 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
43762 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
43763 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
43764 &32*A1*A2*P1P2*P1Q1*V**2/S+
43765 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
43766 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
43767 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
43768 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
43769
43770
43771 YY(2, 2) =-16*A**2*A12*MB*MT+
43772 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
43773 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
43774 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
43775 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
43776 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
43777 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
43778 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
43779 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
43780 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
43781 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
43782 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
43783 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
43784 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
43785 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
43786 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
43787 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
43788 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
43789 &32*A12*MT**2*P2Q2*V**2/S-
43790 &32*A12*P1Q2*P2Q2*V**2/S
43791 YY(2, 2)=2*YY(2, 2)
43792
43793 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
43794 AMP2= FACT*PS*VTB**2*RES
43795
43796 END
43797C=====================================================================
43798C ************* FUNCTION SCALAR PRODUCTS *************************
43799 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
43800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43801 IMPLICIT INTEGER(I-N)
43802 DIMENSION A(4),B(4)
43803 DUM=A(4)*B(4)
43804 DO 100 ID=1,3
43805 DUM=DUM-A(ID)*B(ID)
43806 100 CONTINUE
43807 PYTBHS=DUM
43808 RETURN
43809 END
43810
43811C*********************************************************************
43812
43813C...PYMSIN
43814C...Initializes supersymmetry: finds sparticle masses and
43815C...branching ratios and stores this information.
43816C...AUTHOR: STEPHEN MRENNA
43817C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
43818
43819 SUBROUTINE PYMSIN
43820
43821C...Double precision and integer declarations.
43822 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43823 IMPLICIT INTEGER(I-N)
43824 INTEGER PYK,PYCHGE,PYCOMP
43825C...Parameter statement to help give large particle numbers.
43826 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43827 &KEXCIT=4000000,KDIMEN=5000000)
43828C...Commonblocks.
43829 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43830 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43831 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43832 COMMON/PYDAT4/CHAF(500,2)
43833 CHARACTER CHAF*16
43834 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43835 COMMON/PYINT4/MWID(500),WIDS(500,5)
43836 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43837 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43838 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43839 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43840 COMMON/PYHTRI/HHH(7)
43841 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
43842 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
43843 &/PYMSSM/,/PYMSRV/,/PYSSMT/
43844
43845C...Local variables.
43846 DOUBLE PRECISION ALFA,BETA
43847 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
43848 INTEGER I,J,J1,I1,K1
43849 INTEGER KC,LKNT,IDLAM(400,3)
43850 DOUBLE PRECISION XLAM(0:400)
43851 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
43852 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
43853 DOUBLE PRECISION DELM,XMDIF
43854 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
43855 DOUBLE PRECISION ARG,SGNMU,R
43856 INTEGER IMSSM
43857 INTEGER IRPRTY
43858 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
43859 SAVE MWIDSU,MDCYSU
43860 DATA KFSUSY/
43861 &1000001,2000001,1000002,2000002,1000003,2000003,
43862 &1000004,2000004,1000005,2000005,1000006,2000006,
43863 &1000011,2000011,1000012,2000012,1000013,2000013,
43864 &1000014,2000014,1000015,2000015,1000016,2000016,
43865 &1000021,1000022,1000023,1000025,1000035,1000024,
43866 &1000037,1000039, 25, 35, 36, 37,
43867 & 6, 24, 45, 46,1000045, 9*0/
43868 DATA INIT/0/
43869
43870C...Automatically read QNUMBERS, MASS, and DECAY tables
43871 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
43872 NQNUM=0
43873 CALL PYSLHA(0,0,IFAIL)
43874 CALL PYSLHA(5,0,IFAIL)
43875 ENDIF
43876 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
43877
43878C...Do nothing further if SUSY not requested
43879 IMSSM=IMSS(1)
43880 IF(IMSSM.EQ.0) RETURN
43881
43882C...Save copy of MWID(KC) and MDCY(KC,1) values before
43883C...they are set to zero for the LSP.
43884 IF(INIT.EQ.0) THEN
43885 INIT=1
43886 DO 100 I=1,36
43887 KF=KFSUSY(I)
43888 KC=PYCOMP(KF)
43889 MWIDSU(I)=MWID(KC)
43890 MDCYSU(I)=MDCY(KC,1)
43891 100 CONTINUE
43892 ENDIF
43893
43894C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
43895 DO 110 I=1,36
43896 KF=KFSUSY(I)
43897 KC=PYCOMP(KF)
43898 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
43899 MWID(KC)=MWIDSU(I)
43900 MDCY(KC,1)=MDCYSU(I)
43901 ENDIF
43902 110 CONTINUE
43903
43904C...First part of routine: set masses and couplings.
43905
43906C...Reset mixing values in sfermion sector to pure left/right.
43907 DO 120 I=1,16
43908 SFMIX(I,1)=1D0
43909 SFMIX(I,4)=1D0
43910 SFMIX(I,2)=0D0
43911 SFMIX(I,3)=0D0
43912 120 CONTINUE
43913
43914C...Add NMSSM states if NMSSM switched on, and change old names.
43915 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
43916C... Switch on NMSSM
43917 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
43918
43919 KFN=25
43920 KCN=KFN
43921 CHAF(KCN,1)='h_10'
43922 CHAF(KCN,2)=' '
43923
43924 KFN=35
43925 KCN=KFN
43926 CHAF(KCN,1)='h_20'
43927 CHAF(KCN,2)=' '
43928
43929 KFN=45
43930 KCN=KFN
43931 CHAF(KCN,1)='h_30'
43932 CHAF(KCN,2)=' '
43933
43934 KFN=36
43935 KCN=KFN
43936 CHAF(KCN,1)='A_10'
43937 CHAF(KCN,2)=' '
43938
43939 KFN=46
43940 KCN=KFN
43941 CHAF(KCN,1)='A_20'
43942 CHAF(KCN,2)=' '
43943
43944 KFN=1000045
43945 KCN=PYCOMP(KFN)
43946 IF (KCN.EQ.0) THEN
43947 DO 123 KCT=100,MSTU(6)
43948 IF(KCHG(KCT,4).GT.100) KCN=KCT
43949 123 CONTINUE
43950 KCN=KCN+1
43951 KCHG(KCN,4)=KFN
43952 MSTU(20)=0
43953 ENDIF
43954C... Set stable for now
43955 PMAS(KCN,2)=1D-6
43956 MWID(KCN)=0
43957 MDCY(KCN,1)=0
43958 MDCY(KCN,2)=0
43959 MDCY(KCN,3)=0
43960 CHAF(KCN,1)='~chi_50'
43961 CHAF(KCN,2)=' '
43962 ENDIF
43963
43964C...Read spectrum from SLHA file.
43965 IF (IMSSM.EQ.11) THEN
43966 CALL PYSLHA(1,0,IFAIL)
43967 ENDIF
43968
43969C...Common couplings.
43970 TANB=RMSS(5)
43971 BETA=ATAN(TANB)
43972 COSB=COS(BETA)
43973 SINB=TANB*COSB
43974 COS2B=COS(2D0*BETA)
43975 ALFA=RMSS(18)
43976 XMW2=PMAS(24,1)**2
43977 XMZ2=PMAS(23,1)**2
43978 XW=PARU(102)
43979
43980C...Define sparticle masses for a general MSSM simulation.
43981 IF(IMSSM.EQ.1) THEN
43982 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43983 DO 130 I=1,5,2
43984 KC=PYCOMP(KSUSY1+I)
43985 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43986 KC=PYCOMP(KSUSY2+I)
43987 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43988 KC=PYCOMP(KSUSY1+I+1)
43989 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43990 KC=PYCOMP(KSUSY2+I+1)
43991 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43992 130 CONTINUE
43993 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43994 IF(XARG.LT.0D0) THEN
43995 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43996 & ' FROM THE SUM RULE. '
43997 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
43998 RETURN
43999 ELSE
44000 XARG=SQRT(XARG)
44001 ENDIF
44002 DO 140 I=11,15,2
44003 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44004 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44005 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44006 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44007 140 CONTINUE
44008 IF(IMSS(8).EQ.1) THEN
44009 RMSS(13)=RMSS(6)
44010 RMSS(14)=RMSS(7)
44011 ENDIF
44012
44013C...Alternatively derive masses from SUGRA relations.
44014 ELSEIF(IMSSM.EQ.2) THEN
44015 RMSS(36)=RMSS(16)
44016 CALL PYAPPS
44017C...Or use ISASUSY
44018 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44019 RMSS(36)=RMSS(16)
44020 CALL PYSUGI
44021 ALFA=RMSS(18)
44022 GOTO 170
44023 ELSE
44024 GOTO 170
44025 ENDIF
44026
44027C...Add in extra D-term contributions.
44028 IF(IMSS(7).EQ.1) THEN
44029 R=0.43D0
44030 DX=RMSS(23)
44031 DY=RMSS(24)
44032 DS=RMSS(25)
44033 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44034 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44035 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44036 WRITE(MSTU(11),*) 'C DX = ',DX
44037 WRITE(MSTU(11),*) 'C DY = ',DY
44038 WRITE(MSTU(11),*) 'C DS = ',DS
44039 WRITE(MSTU(11),*) 'C '
44040 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44041 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44042 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44043 DQ2=DY/6D0-DX/3D0-DS/3D0
44044 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44045 DD2=DY/3D0+DX-2D0*DS/3D0
44046 DL2=-DY/2D0+DX-2D0*DS/3D0
44047 DE2=DY-DX/3D0-DS/3D0
44048 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44049 DHD2=-DY/2D0-2D0*DX/3D0+DS
44050 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44051 & /ABS(COS2B)
44052 DMA2 = 2D0*DMU2+DHU2+DHD2
44053 DO 150 I=1,5,2
44054 KC=PYCOMP(KSUSY1+I)
44055 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44056 KC=PYCOMP(KSUSY2+I)
44057 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44058 KC=PYCOMP(KSUSY1+I+1)
44059 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44060 KC=PYCOMP(KSUSY2+I+1)
44061 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44062 150 CONTINUE
44063 DO 160 I=11,15,2
44064 KC=PYCOMP(KSUSY1+I)
44065 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44066 KC=PYCOMP(KSUSY2+I)
44067 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44068 KC=PYCOMP(KSUSY1+I+1)
44069 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44070 160 CONTINUE
44071 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44072 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44073 CALL PYSTOP(104)
44074 ENDIF
44075 SGNMU=SIGN(1D0,RMSS(4))
44076 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44077 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44078 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44079 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44080 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44081 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44082 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44083 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44084 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44085 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44086 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44087 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44088 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44089 CALL PYSTOP(104)
44090 ENDIF
44091 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44092 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44093 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44094 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44095 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44096 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
44097 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
44098 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
44099 ENDIF
44100
44101C...Fix the third generation sfermions.
44102 CALL PYTHRG
44103
44104C...Fix the neutralino--chargino--gluino sector.
44105 CALL PYINOM
44106
44107C...Fix the Higgs sector.
44108 CALL PYHGGM(ALFA)
44109
44110C...Choose the Gunion-Haber convention.
44111 ALFA=-ALFA
44112 RMSS(18)=ALFA
44113
44114C...Print information on mass parameters.
44115 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
44116 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44117 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44118 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
44119 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
44120 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
44121 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
44122 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
44123 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
44124 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
44125 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44126 ENDIF
44127 IF(IMSS(20).EQ.1) THEN
44128 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44129 WRITE(MSTU(11),*) ' DEBUG MODE '
44130 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
44131 & UMIX(2,1),UMIX(2,2)
44132 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
44133 & UMIXI(2,1),UMIXI(2,2)
44134 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
44135 & VMIX(2,1),VMIX(2,2)
44136 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
44137 & VMIXI(2,1),VMIXI(2,2)
44138 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
44139 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
44140 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
44141 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
44142 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
44143 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
44144 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
44145 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
44146 WRITE(MSTU(11),*) ' ALFA = ',ALFA
44147 WRITE(MSTU(11),*) ' BETA = ',BETA
44148 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
44149 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
44150 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44151 ENDIF
44152
44153C...Set up the Higgs couplings - needed here since initialization
44154C...in PYINRE did not yet occur when PYWIDT is called below.
44155 170 AL=ALFA
44156 BE=BETA
44157 SINA=SIN(AL)
44158 COSA=COS(AL)
44159 COSB=COS(BE)
44160 SINB=TANB*COSB
44161 SBMA=SIN(BE-AL)
44162 SAPB=SIN(AL+BE)
44163 CAPB=COS(AL+BE)
44164 CBMA=COS(BE-AL)
44165 C2A=COS(2D0*AL)
44166 C2B=COSB**2-SINB**2
44167C...tanb (used for H+)
44168 PARU(141)=TANB
44169
44170C...Firstly: h
44171C...Coupling to d-type quarks
44172 PARU(161)=SINA/COSB
44173C...Coupling to u-type quarks
44174 PARU(162)=-COSA/SINB
44175C...Coupling to leptons
44176 PARU(163)=PARU(161)
44177C...Coupling to Z
44178 PARU(164)=SBMA
44179C...Coupling to W
44180 PARU(165)=PARU(164)
44181
44182C...Secondly: H
44183C...Coupling to d-type quarks
44184 PARU(171)=-COSA/COSB
44185C...Coupling to u-type quarks
44186 PARU(172)=-SINA/SINB
44187C...Coupling to leptons
44188 PARU(173)=PARU(171)
44189C...Coupling to Z
44190 PARU(174)=CBMA
44191C...Coupling to W
44192 PARU(175)=PARU(174)
44193C...Coupling to h
44194 IF(IMSS(4).GE.2) THEN
44195 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
44196 ELSE
44197 HHH(3)=HHH(3)+HHH(4)+HHH(5)
44198 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
44199 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
44200 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
44201 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
44202 ENDIF
44203C...Coupling to H+
44204C...Define later
44205 IF(IMSS(4).GE.2) THEN
44206 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
44207 ELSE
44208 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
44209 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
44210 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
44211 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
44212 ENDIF
44213C...Coupling to A
44214 IF(IMSS(4).GE.2) THEN
44215 PARU(177)=COS(2D0*BE)*COS(BE+AL)
44216 ELSE
44217 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
44218 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
44219 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
44220 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
44221 ENDIF
44222C...Coupling to H+
44223 IF(IMSS(4).GE.2) THEN
44224 PARU(178)=PARU(177)
44225 ELSE
44226 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
44227 ENDIF
44228C...Thirdly, A
44229C...Coupling to d-type quarks
44230 PARU(181)=TANB
44231C...Coupling to u-type quarks
44232 PARU(182)=1D0/PARU(181)
44233C...Coupling to leptons
44234 PARU(183)=PARU(181)
44235 PARU(184)=0D0
44236 PARU(185)=0D0
44237C...Coupling to Z h
44238 PARU(186)=COS(BE-AL)
44239C...Coupling to Z H
44240 PARU(187)=SIN(BE-AL)
44241 PARU(188)=0D0
44242 PARU(189)=0D0
44243 PARU(190)=0D0
44244
44245C...Finally: H+
44246C...Coupling to W h
44247 PARU(195)=COS(BE-AL)
44248
44249C...Tell that all Higgs couplings have been set.
44250 MSTP(4)=1
44251
44252C...Set R-Violating couplings.
44253C...Set lambda couplings to common value or "natural values".
44254 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
44255 VIR3=1D0/(126D0)**3
44256 DO 200 IRK=1,3
44257 DO 190 IRI=1,3
44258 DO 180 IRJ=1,3
44259 IF (IRI.NE.IRJ) THEN
44260 IF (IRI.LT.IRJ) THEN
44261 RVLAM(IRI,IRJ,IRK)=RMSS(51)
44262 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
44263 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
44264 & PMAS(9+2*IRK,1)*VIR3)
44265 ELSE
44266 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
44267 ENDIF
44268 ELSE
44269 RVLAM(IRI,IRJ,IRK)=0D0
44270 ENDIF
44271 180 CONTINUE
44272 190 CONTINUE
44273 200 CONTINUE
44274 ENDIF
44275C...Set lambda' couplings to common value or "natural values".
44276 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
44277 VIR3=1D0/(126D0)**3
44278 DO 230 IRI=1,3
44279 DO 220 IRJ=1,3
44280 DO 210 IRK=1,3
44281 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
44282 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
44283 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
44284 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
44285 210 CONTINUE
44286 220 CONTINUE
44287 230 CONTINUE
44288 ENDIF
44289C...Set lambda'' couplings to common value or "natural values".
44290 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
44291 VIR3=1D0/(126D0)**3
44292 DO 260 IRI=1,3
44293 DO 250 IRJ=1,3
44294 DO 240 IRK=1,3
44295 IF (IRJ.NE.IRK) THEN
44296 IF (IRJ.LT.IRK) THEN
44297 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
44298 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
44299 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
44300 & PMAS(2*IRK-1,1)*VIR3)
44301 ELSE
44302 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
44303 ENDIF
44304 ELSE
44305 RVLAMB(IRI,IRJ,IRK) = 0D0
44306 ENDIF
44307 240 CONTINUE
44308 250 CONTINUE
44309 260 CONTINUE
44310 ENDIF
44311
44312C...Antisymmetrize couplings set by user
44313 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
44314 DO 290 IRI=1,3
44315 DO 280 IRJ=1,3
44316 DO 270 IRK=1,3
44317 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
44318 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
44319 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
44320 ENDIF
44321 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
44322 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
44323 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
44324 ENDIF
44325 270 CONTINUE
44326 280 CONTINUE
44327 290 CONTINUE
44328 ENDIF
44329
44330C...Write spectrum to SLHA file
44331 IF (IMSS(23).NE.0) THEN
44332 IFAIL=0
44333 CALL PYSLHA(3,0,IFAIL)
44334 ENDIF
44335
44336C...Second part of routine: set decay modes and branching ratios.
44337
44338C...Allow chi10 -> gravitino + gamma or not.
44339 KC=PYCOMP(KSUSY1+39)
44340 IF( IMSS(11) .NE. 0 ) THEN
44341 PMAS(KC,1)=RMSS(21)/1D9
44342 PMAS(KC,2)=0D0
44343 IRPRTY=0
44344 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
44345 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
44346 IRPRTY=0
44347 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
44348 & ' ALLOWING SUSY LLE DECAYS'
44349 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
44350 & ' ALLOWING SUSY LQD DECAYS'
44351 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
44352 & ' ALLOWING SUSY UDD DECAYS'
44353 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
44354 & ' --- Warning: R-Violating couplings possibly',
44355 & ' incompatible with proton decay'
44356 ELSE
44357 PMAS(KC,1)=9999D0
44358 IRPRTY=1
44359 ENDIF
44360
44361C...Loop over sparticle and Higgs species.
44362 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
44363C...Find the LSP or NLSP for a gravitino LSP
44364 ILSP=0
44365 PMLSP=1D20
44366 DO 300 I=1,36
44367 KF=KFSUSY(I)
44368 IF(KF.EQ.1000039) GOTO 300
44369 KC=PYCOMP(KF)
44370 IF(PMAS(KC,1).LT.PMLSP) THEN
44371 ILSP=I
44372 PMLSP=PMAS(KC,1)
44373 ENDIF
44374 300 CONTINUE
44375 DO 370 I=1,50
44376 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
44377 KF=KFSUSY(I)
44378 IF (KF.EQ.0) GOTO 370
44379 KC=PYCOMP(KF)
44380 LKNT=0
44381
44382C...Check if there are any decays listed for this sparticle
44383C...in a file
44384 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
44385 IFAIL=0
44386 CALL PYSLHA(2,KF,IFAIL)
44387 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
44388 ELSEIF (I.GE.37) THEN
44389 GOTO 370
44390 ENDIF
44391
44392C...Sfermion decays.
44393 IF(I.LE.24) THEN
44394C...First check to see if sneutrino is lighter than chi10.
44395 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
44396 & PMAS(KC,1).LT.PMCHI1) THEN
44397 ELSE
44398 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
44399 ENDIF
44400
44401C...Gluino decays.
44402 ELSEIF(I.EQ.25) THEN
44403 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
44404 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
44405
44406C...Neutralino decays.
44407 ELSEIF(I.GE.26.AND.I.LE.29) THEN
44408 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
44409C...chi10 stable or chi10 -> gravitino + gamma.
44410 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
44411 PMAS(KC,2)=1D-6
44412 MDCY(KC,1)=0
44413 MWID(KC)=0
44414 ENDIF
44415
44416C...Chargino decays.
44417 ELSEIF(I.GE.30.AND.I.LE.31) THEN
44418 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
44419
44420C...Gravitino is stable.
44421 ELSEIF(I.EQ.32) THEN
44422 MDCY(KC,1)=0
44423 MWID(KC)=0
44424
44425C...Higgs decays.
44426 ELSEIF(I.GE.33.AND.I.LE.36) THEN
44427C...Calculate decays to non-SUSY particles.
44428 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
44429 LKNT=0
44430 DO 310 I1=0,100
44431 XLAM(I1)=0D0
44432 310 CONTINUE
44433 DO 330 I1=1,MDCY(KC,3)
44434 K1=MDCY(KC,2)+I1-1
44435 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
44436 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
44437 XLAM(I1)=WDTP(I1)
44438 XLAM(0)=XLAM(0)+XLAM(I1)
44439 DO 320 J1=1,3
44440 IDLAM(I1,J1)=KFDP(K1,J1)
44441 320 CONTINUE
44442 LKNT=LKNT+1
44443 330 CONTINUE
44444C...Add the decays to SUSY particles.
44445 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
44446 ENDIF
44447C...Zero the branching ratios for use in loop mode
44448C...thanks to K. Matchev (FNAL)
44449 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44450 BRAT(IDC)=0D0
44451 340 CONTINUE
44452
44453C...Set stable particles.
44454 IF(LKNT.EQ.0) THEN
44455 MDCY(KC,1)=0
44456 MWID(KC)=0
44457 PMAS(KC,2)=1D-6
44458 PMAS(KC,3)=1D-5
44459 PMAS(KC,4)=0D0
44460
44461C...Store branching ratios in the standard tables.
44462 ELSE
44463 IDC=MDCY(KC,2)+MDCY(KC,3)-1
44464 DELM=1D6
44465 DO 360 IL=1,LKNT
44466 IDCSV=IDC
44467 350 IDC=IDC+1
44468 BRAT(IDC)=0D0
44469 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
44470 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
44471 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
44472 BRAT(IDC)=XLAM(IL)/XLAM(0)
44473 XMDIF=PMAS(KC,1)
44474 IF(MDME(IDC,1).GE.1) THEN
44475 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
44476 & PMAS(PYCOMP(KFDP(IDC,2)),1)
44477 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
44478 & PMAS(PYCOMP(KFDP(IDC,3)),1)
44479 ENDIF
44480 IF(I.LE.32) THEN
44481 IF(XMDIF.GE.0D0) THEN
44482 DELM=MIN(DELM,XMDIF)
44483 ELSE
44484 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
44485 WRITE(MSTU(11),*) ' KF = ',KF
44486 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
44487 ENDIF
44488 ENDIF
44489 GOTO 360
44490 ELSEIF(IDC.EQ.IDCSV) THEN
44491 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
44492 & 'channel not recognized:'
44493 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
44494 GOTO 360
44495 ELSE
44496 GOTO 350
44497 ENDIF
44498 360 CONTINUE
44499
44500C...Store width, cutoff and lifetime.
44501 PMAS(KC,2)=XLAM(0)
44502 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
44503 PMAS(KC,3)=PMAS(KC,2)*10D0
44504 ELSE
44505 PMAS(KC,3)=0.95D0*DELM
44506 ENDIF
44507 IF(PMAS(KC,2).NE.0D0) THEN
44508 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
44509 ENDIF
44510C...Write decays to SLHA file
44511 IF (IMSS(24).NE.0) THEN
44512 IFAIL=0
44513 CALL PYSLHA(4,KF,IFAIL)
44514 ENDIF
44515
44516 ENDIF
44517 370 CONTINUE
44518
44519 RETURN
44520 END
44521C*********************************************************************
44522
44523C...PYSLHA
44524C...Read/write spectrum or decay data from SLHA standard file(s).
44525C...P. Skands
44526
44527C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
44528C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
44529C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
44530C... (KFORIG=0 : read all decay tables)
44531C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
44532C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
44533C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
44534C... (KFORIG=0 : read all MASS entries)
44535
44536C...Recent updates:
44537C...17 Sep 2007: introduced /PYQNUM/ for QNUMBERS storage
44538C... : Corrected QNUMBERS name-formation; root only until space
44539 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
44540
44541C...Double precision and integer declarations.
44542 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44543 IMPLICIT INTEGER(I-N)
44544 INTEGER PYK,PYCHGE,PYCOMP
44545 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44546 &KEXCIT=4000000,KDIMEN=5000000)
44547C...Commonblocks.
44548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44550 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44551 COMMON/PYDAT4/CHAF(500,2)
44552 CHARACTER CHAF*16
44553 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44554 CHARACTER*40 ISAVER,VISAJE
44555 COMMON/PYINT4/MWID(500),WIDS(500,5)
44556 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
44557C...SUSY blocks
44558 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44559 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44560 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44561 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44562 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
44563
44564C...Local arrays, character variables and data.
44565 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
44566 & AU(3,3),AD(3,3),AE(3,3)
44567 COMMON/PYLH3C/CPRO(2),CVER(2)
44568C...The common block of new states (QNUMBERS / PARTICLE)
44569 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44570C...- NQNUM : Number of QNUMBERS blocks that have been read in
44571C...- KQNUM(I,0) : KF of new state
44572C...- KQNUM(I,1) : 3 times electric charge
44573C...- KQNUM(I,2) : Number of spin states: (2S + 1)
44574C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
44575C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
44576C...- KQNUM(I,5:9) : space available for further quantum numbers
44577 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
44578 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
44579C...MMOD: flags to set for each block read in.
44580C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
44581C...MSPC: Flags to set for each block read in.
44582C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
44583C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
44584C...11: AD 12: AE 13: YU 14: YD 15: YE
44585C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
44586 CHARACTER CPRO*12,CVER*12,CHNLIN*6
44587 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
44588 CHARACTER CHINL*120,CHKF*9,CHTMP*16
44589 INTEGER VERBOS
44590 SAVE VERBOS
44591C...Date of last Change
44592 PARAMETER (DOC='05 Nov 2007')
44593C...Local arrays and initial values
44594 DIMENSION IDC(5),KFSUSY(50)
44595 SAVE KFSUSY
44596 DATA NQNUM /0/
44597 DATA NDECAY /0/
44598 DATA VERBOS /1/
44599 DATA NHELLO /0/
44600 DATA MLHEF /0/
44601 DATA MLHEFD /0/
44602 DATA KFSUSY/
44603 &1000001,1000002,1000003,1000004,1000005,1000006,
44604 &2000001,2000002,2000003,2000004,2000005,2000006,
44605 &1000011,1000012,1000013,1000014,1000015,1000016,
44606 &2000011,2000012,2000013,2000014,2000015,2000016,
44607 &1000021,1000022,1000023,1000025,1000035,1000024,
44608 &1000037,1000039, 25, 35, 36, 37,
44609 & 6, 24, 45, 46,1000045, 9*0/
44610 DATA KFDEC/100*0/
44611 RMFUN(IP)=PMAS(PYCOMP(IP),1)
44612
44613C...Shorthand for spectrum and decay table unit numbers
44614 IMSS21=IMSS(21)
44615 IMSS22=IMSS(22)
44616
44617C...Default for LHEF input: read header information
44618 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
44619 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
44620 IF (IMSS21.EQ.MSTP(161)) MLHEF=1
44621 IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
44622
44623C...Hello World
44624 IF (NHELLO.EQ.0) THEN
44625 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
44626 WRITE(MSTU(11),5000) DOC
44627 NHELLO=1
44628 ENDIF
44629 ENDIF
44630
44631C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
44632C...+MUPDA).
44633 LFN=IMSS21
44634 IF (MUPDA.EQ.2) LFN=IMSS22
44635 IF (MUPDA.EQ.3) LFN=IMSS(23)
44636 IF (MUPDA.EQ.4) LFN=IMSS(24)
44637C...Flag that we have not yet found whatever we were asked to find.
44638 IRETRN=1
44639
44640C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
44641 IF (LFN.EQ.0) THEN
44642 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
44643 GOTO 9999
44644 ENDIF
44645
44646C...If reading LHEF header, start by rewinding file
44647 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
44648
44649C...If told to read spectrum, first zero all previous information.
44650 IF (MUPDA.EQ.1) THEN
44651C...Zero all block read flags
44652 DO 100 M=1,100
44653 MMOD(M)=0
44654 MSPC(M)=0
44655 100 CONTINUE
44656C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
44657 DO 110 ISUSY=1,36
44658 KC=PYCOMP(KFSUSY(ISUSY))
44659 PMAS(KC,1)=0D0
44660 110 CONTINUE
44661C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
44662 DO 130 J=1,4
44663 SFMIX(5,J) =0D0
44664 SFMIX(6,J) =0D0
44665 SFMIX(15,J)=0D0
44666 DO 120 L=1,4
44667 ZMIX(L,J) =0D0
44668 ZMIXI(L,J)=0D0
44669 IF (J.LE.2.AND.L.LE.2) THEN
44670 UMIX(L,J) =0D0
44671 UMIXI(L,J)=0D0
44672 VMIX(L,J) =0D0
44673 VMIXI(L,J)=0D0
44674 ENDIF
44675 120 CONTINUE
44676C...Zero signed masses.
44677 SMZ(J)=0D0
44678 IF (J.LE.2) SMW(J)=0D0
44679 130 CONTINUE
44680
44681C...If reading decays, reset PYTHIA decay counters.
44682 ELSEIF (MUPDA.EQ.2) THEN
44683C...Check if DECAY for this KF already read
44684 IF (KFORIG.NE.0) THEN
44685 DO 140 IDEC=1,NDECAY
44686 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
44687 IRETRN=0
44688 RETURN
44689 ENDIF
44690 140 CONTINUE
44691 ENDIF
44692 KCC=100
44693 NDC=0
44694 BRSUM=0D0
44695 DO 150 KC=1,MSTU(6)
44696 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
44697 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
44698 150 CONTINUE
44699 ELSEIF (MUPDA.EQ.5) THEN
44700C...Zero block read flags
44701 DO 160 M=1,100
44702 MSPC(M)=0
44703 160 CONTINUE
44704 ENDIF
44705
44706C............READ
44707C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
44708 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
44709C...Initialize program and version strings
44710 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
44711 CPRO(MUPDA)=' '
44712 CVER(MUPDA)=' '
44713 ENDIF
44714
44715C...Initialize read loop
44716 MERR=0
44717 NLINE=0
44718 CHBLCK=' '
44719C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
44720 170 CHINL=' '
44721 READ(LFN,'(A120)',END=400) CHINL
44722C...Count which line number we're at.
44723 NLINE=NLINE+1
44724 WRITE(CHNLIN,'(I6)') NLINE
44725
44726C...Skip comment and empty lines without processing.
44727 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
44728
44729C...We assume all upper case below. Rewrite CHINL to all upper case.
44730 INL=0
44731 IGOOD=0
44732 180 INL=INL+1
44733 IF (CHINL(INL:INL).NE.'#') THEN
44734 DO 190 ICH=97,122
44735 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
44736 190 CONTINUE
44737C...Extra safety. Chek for sensible input on line
44738 IF (IGOOD.EQ.0) THEN
44739 DO 200 ICH=48,90
44740 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
44741 200 CONTINUE
44742 ENDIF
44743 IF (INL.LT.120) GOTO 180
44744 ENDIF
44745 IF (IGOOD.EQ.0) GOTO 170
44746
44747C...Exit when first <event> tag reached in LHEF file
44748 DO 210 I1=1,10
44749 IF (CHINL(I1:I1+5).EQ.'<EVENT') THEN
44750 REWIND(LFN)
44751 GOTO 400
44752 ENDIF
44753 210 CONTINUE
44754
44755C...Check for BLOCK begin statement (spectrum).
44756 IF (CHINL(1:5).EQ.'BLOCK') THEN
44757 MERR=0
44758 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
44759C...Check if another of this type of block was already read.
44760C...(logarithmic interpolation not yet implemented, so duplicates always
44761C...give errors)
44762 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
44763 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
44764 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
44765 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
44766 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
44767 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
44768 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
44769 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
44770 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
44771 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
44772 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
44773 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
44774 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
44775 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
44776 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
44777 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
44778 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
44779C...Check for new particles
44780 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44781 & THEN
44782 MSPC(19)=MSPC(19)+1
44783C...Read PDG code
44784 READ(CHBLCK(9:60),*) KFQ
44785
44786 DO 220 MQ=1,NQNUM
44787 IF (KQNUM(MQ,0).EQ.KFQ) THEN
44788 MERR=17
44789 GOTO 380
44790 ENDIF
44791 220 CONTINUE
44792 IF (NHELLO.EQ.0) THEN
44793 WRITE(MSTU(11),5000) DOC
44794 NHELLO=1
44795 ENDIF
44796 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44797 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
44798 & ' for KF =',KFQ
44799 NQNUM=NQNUM+1
44800 KQNUM(NQNUM,0)=KFQ
44801 MSPC(19)=MSPC(19)+1
44802 KCQ=PYCOMP(KFQ)
44803C...Only read in new codes (also OK to overwrite if KF > 3000000)
44804 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
44805 IF (KCQ.EQ.0) THEN
44806 DO 230 KCT=100,MSTU(6)
44807 IF(KCHG(KCT,4).GT.100) KCQ=KCT
44808 230 CONTINUE
44809 KCQ=KCQ+1
44810 ENDIF
44811 KCC=KCQ
44812 KCHG(KCQ,4)=KFQ
44813C...First write PDG code as name
44814 WRITE(CHTMP,*) KFQ
44815 WRITE(CHTMP,'(A)') CHTMP(2:10)
44816C...Then look for real name
44817 IBEG=9
44818 240 IBEG=IBEG+1
44819 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
44820 250 IBEG=IBEG+1
44821 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
44822 IEND=IBEG-1
44823 260 IEND=IEND+1
44824 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
44825 IF (IEND.LT.59) THEN
44826 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
44827 IF (CHDUM.NE.' ') CHTMP=CHDUM
44828 ENDIF
44829 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
44830 MSTU(20)=0
44831C...Set stable for now
44832 PMAS(KCQ,2)=1D-6
44833 MWID(KCQ)=0
44834 MDCY(KCQ,1)=0
44835 MDCY(KCQ,2)=0
44836 MDCY(KCQ,3)=0
44837 ELSE
44838 WRITE(MSTU(11),*)
44839 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
44840 & CHAF(KCQ,1), '. Entry ignored.'
44841 MERR=7
44842 ENDIF
44843 ENDIF
44844C...Finalize this line and read next.
44845 GOTO 380
44846C...Check for DECAY begin statement (decays).
44847 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
44848 MERR=0
44849 BRSUM=0D0
44850 CHBLCK='DECAY'
44851C...Read KF code and WIDTH
44852 MPSIGN=1
44853 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
44854 IF (KF.LE.0) THEN
44855 KF=-KF
44856 MPSIGN=-1
44857 ENDIF
44858C...If this is not the KF we're looking for...
44859 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
44860C...Set block skip flag and read next line.
44861 MERR=16
44862 GOTO 380
44863 ELSE
44864C...Check whether decay table for this particle already read in
44865 DO 280 IDECAY=1,NDECAY
44866 IF (KFDEC(IDECAY).EQ.KF) THEN
44867 MERR=16
44868 GOTO 380
44869 ENDIF
44870 280 CONTINUE
44871 ENDIF
44872
44873C...Determine PYTHIA KC code of particle
44874 KCREP=0
44875 IF(KF.LE.100) THEN
44876 KCREP=KF
44877 ELSE
44878 DO 290 KCR=101,KCC
44879 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
44880 290 CONTINUE
44881 ENDIF
44882 KC=KCREP
44883 IF (KCREP.NE.0) THEN
44884C...Particle is already known. Don't do anything yet.
44885 ELSE
44886C... Add new particle. Actually, this should not happen.
44887C... New particles should be added already when reading the spectrum
44888C... information, so go under previously stable category.
44889 KCC=KCC+1
44890 KC=KCC
44891 ENDIF
44892
44893 IF (WIDTH.LE.0D0) THEN
44894C...Stable (i.e. LSP)
44895 WRITE(MSTU(11),*)
44896 & '* (PYSLHA:) Reading in SLHA stable particle ',
44897 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
44898 IF (WIDTH.LT.0D0) THEN
44899 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
44900 & ' zero !')
44901 WIDTH=0D0
44902 ENDIF
44903 PMAS(KC,2)=1D-6
44904 MWID(KC)=0
44905 MDCY(KC,1)=0
44906C...Ignore any decay lines that may be present for this KF
44907 MERR=16
44908 MDCY(KC,2)=0
44909 MDCY(KC,3)=0
44910C...Return ok
44911 IRETRN=0
44912 ENDIF
44913C...Finalize and start reading in decay modes.
44914 GOTO 380
44915 ELSEIF (MOD(MERR,10).GE.6) THEN
44916C...If ignore block flag set, skip directly to next line.
44917 GOTO 170
44918 ENDIF
44919
44920C...READ SPECTRUM
44921 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
44922 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44923 & THEN
44924 READ(CHINL,*) INDX, IVAL
44925 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
44926 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
44927 IF (INDX.EQ.3) KCHG(KCQ,2)=0
44928 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
44929 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
44930 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
44931 IF (INDX.EQ.4) THEN
44932 KCHG(KCQ,3)=IVAL
44933 IF (IVAL.EQ.1) THEN
44934 CHTMP=CHAF(KCQ,1)
44935 IF (CHTMP.EQ.' ') THEN
44936 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
44937 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
44938 ELSE
44939 ILAST=17
44940 300 ILAST=ILAST-1
44941 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
44942 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
44943 CHTMP(ILAST:ILAST)='-'
44944 ELSE
44945 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
44946 ENDIF
44947 CHAF(KCQ,2)=CHTMP
44948 ENDIF
44949 ENDIF
44950 ENDIF
44951 ELSE
44952 MERR=8
44953 ENDIF
44954 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
44955C...MASS: Mass spectrum
44956 IF (CHBLCK(1:4).EQ.'MASS') THEN
44957 READ(CHINL,*) KF, VAL
44958 MERR=1
44959 KC=0
44960 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
44961C...Read in masses for anything
44962 MERR=0
44963 KC=PYCOMP(KF)
44964C...Don't read in masses for the light quarks
44965 IF (IABS(KF).LE.3) THEN
44966 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44967 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
44968 & KF
44969 MERR=1
44970 ENDIF
44971 IF (KC.NE.0) THEN
44972 MSPC(1)=MSPC(1)+1
44973 PMAS(KC,1) = ABS(VAL)
44974 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
44975 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44976 & ' * (PYSLHA:) Reading in MASS entry for KF =',
44977 & KF, ', pole mass =', VAL
44978 IRETRN=0
44979 ENDIF
44980C... Signed masses
44981 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
44982 IF (KF.EQ.1000022) SMZ(1)=VAL
44983 IF (KF.EQ.1000023) SMZ(2)=VAL
44984 IF (KF.EQ.1000025) SMZ(3)=VAL
44985 IF (KF.EQ.1000035) SMZ(4)=VAL
44986 IF (KF.EQ.1000024) SMW(1)=VAL
44987 IF (KF.EQ.1000037) SMW(2)=VAL
44988 ENDIF
44989 ELSEIF (MUPDA.EQ.5) THEN
44990 MERR=0
44991 ENDIF
44992C... MODSEL: Model selection and global switches
44993 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
44994 READ(CHINL,*) INDX, IVAL
44995 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44996 IF (IMSS(1).EQ.0) IMSS(1)=11
44997 MODSEL(INDX)=IVAL
44998 MMOD(1)=MMOD(1)+1
44999 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45000C... Switch on NMSSM
45001 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45002 IMSS(13)=MAX(1,IMSS(13))
45003C... Add NMSSM states if not already done
45004
45005 KFN=25
45006 KCN=KFN
45007 CHAF(KCN,1)='h_10'
45008 CHAF(KCN,2)=' '
45009
45010 KFN=35
45011 KCN=KFN
45012 CHAF(KCN,1)='h_20'
45013 CHAF(KCN,2)=' '
45014
45015 KFN=45
45016 KCN=KFN
45017 CHAF(KCN,1)='h_30'
45018 CHAF(KCN,2)=' '
45019
45020 KFN=36
45021 KCN=KFN
45022 CHAF(KCN,1)='A_10'
45023 CHAF(KCN,2)=' '
45024
45025 KFN=46
45026 KCN=KFN
45027 CHAF(KCN,1)='A_20'
45028 CHAF(KCN,2)=' '
45029
45030 KFN=1000045
45031 KCN=PYCOMP(KFN)
45032 IF (KCN.EQ.0) THEN
45033 DO 310 KCT=100,MSTU(6)
45034 IF(KCHG(KCT,4).GT.100) KCN=KCT
45035 310 CONTINUE
45036 KCN=KCN+1
45037 KCHG(KCN,4)=KFN
45038 MSTU(20)=0
45039 ENDIF
45040C... Set stable for now
45041 PMAS(KCN,2)=1D-6
45042 MWID(KCN)=0
45043 MDCY(KCN,1)=0
45044 MDCY(KCN,2)=0
45045 MDCY(KCN,3)=0
45046 CHAF(KCN,1)='~chi_50'
45047 CHAF(KCN,2)=' '
45048 ENDIF
45049 ELSE
45050 MERR=1
45051 ENDIF
45052 ELSEIF (MUPDA.EQ.5) THEN
45053C...If MUPDA = 5, skip all except MASS, return if MODSEL
45054 MERR=8
45055 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
45056 & CHBLCK(1:8).EQ.'PARTICLE') THEN
45057C...Don't print a warning for QNUMBERS when reading spectrum
45058 MERR=8
45059C...MINPAR: Minimal model parameters
45060 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
45061 READ(CHINL,*) INDX, VAL
45062 IF (INDX.LE.100.AND.INDX.GT.0) THEN
45063 PARMIN(INDX)=VAL
45064 MMOD(2)=MMOD(2)+1
45065 ELSE
45066 MERR=1
45067 ENDIF
45068 IF (MMOD(3).NE.0) THEN
45069 WRITE(MSTU(11),*)
45070 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45071 MERR=1
45072 ENDIF
45073C...tan(beta)
45074 IF (INDX.EQ.3) RMSS(5)=VAL
45075C...EXTPAR: non-minimal model parameters.
45076 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
45077 IF (MMOD(1).NE.0) THEN
45078 READ(CHINL,*) INDX, VAL
45079 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45080 PAREXT(INDX)=VAL
45081 MMOD(3)=MMOD(3)+1
45082 ELSE
45083 MERR=1
45084 ENDIF
45085 ELSE
45086 WRITE(MSTU(11),*)
45087 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45088 MERR=1
45089 ENDIF
45090C...tan(beta)
45091 IF (INDX.EQ.25) RMSS(5)=VAL
45092 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
45093 READ(CHINL,*) INDX, VAL
45094 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
45095 MERR=1
45096 ELSEIF (INDX.EQ.4) THEN
45097 PMAS(PYCOMP(23),1)=VAL
45098 ELSEIF (INDX.EQ.6) THEN
45099 PMAS(PYCOMP(6),1)=VAL
45100 ENDIF
45101 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
45102 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
45103 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
45104 $ THEN
45105C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45106 IM=0
45107 IF (CHBLCK(5:6).EQ.'IM') IM=1
45108 320 READ(CHINL,*) INDX1, INDX2, VAL
45109 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
45110 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
45111 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
45112 MSPC(2)=MSPC(2)+1
45113 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
45114 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
45115 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
45116 MSPC(3)=MSPC(3)+1
45117 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
45118 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
45119 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
45120 MSPC(4)=MSPC(4)+1
45121 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
45122 $ .CHBLCK(1:4).EQ.'STAU') THEN
45123 IF (CHBLCK(1:4).EQ.'STOP') THEN
45124 KFSM=6
45125 ISPC=6
45126 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
45127 KFSM=5
45128 ISPC=5
45129 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
45130 KFSM=15
45131 ISPC=7
45132 ENDIF
45133C...Set SFMIX element
45134 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
45135 MSPC(ISPC)=MSPC(ISPC)+1
45136 ENDIF
45137C...Running parameters
45138 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
45139 READ(CHBLCK(8:25),*,ERR=620) Q
45140 READ(CHINL,*) INDX, VAL
45141 MSPC(8)=MSPC(8)+1
45142 IF (INDX.EQ.1) THEN
45143 RMSS(4) = VAL
45144 ELSE
45145 MERR=1
45146 MSPC(8)=MSPC(8)-1
45147 ENDIF
45148 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
45149 READ(CHINL,*,ERR=630) VAL
45150 RMSS(18)= VAL
45151 MSPC(17)=MSPC(17)+1
45152C...Higgs parameters set manually or with FeynHiggs.
45153 IMSS(4)=MAX(2,IMSS(4))
45154 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
45155 & .CHBLCK(1:2).EQ.'AE') THEN
45156 READ(CHBLCK(9:26),*,ERR=620) Q
45157 READ(CHINL,*) INDX1, INDX2, VAL
45158 IF (CHBLCK(2:2).EQ.'U') THEN
45159 AU(INDX1,INDX2)=VAL
45160 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
45161 MSPC(11)=MSPC(11)+1
45162 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
45163 AD(INDX1,INDX2)=VAL
45164 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
45165 MSPC(10)=MSPC(10)+1
45166 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
45167 AE(INDX1,INDX2)=VAL
45168 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
45169 MSPC(12)=MSPC(12)+1
45170 ELSE
45171 MERR=1
45172 ENDIF
45173 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
45174 IF (MSPC(18).EQ.0) THEN
45175 READ(CHBLCK(9:25),*,ERR=620) Q
45176 RMSOFT(0)=Q
45177 ENDIF
45178 READ(CHINL,*) INDX, VAL
45179 RMSOFT(INDX)=VAL
45180 MSPC(18)=MSPC(18)+1
45181 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
45182 MERR=8
45183 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
45184 & .CHBLCK(1:2).EQ.'YE') THEN
45185 MERR=8
45186 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
45187 READ(CHINL(1:6),*) INDX
45188 IT=0
45189 MIRD=0
45190 330 IT=IT+1
45191 IF (CHINL(IT:IT).EQ.' ') GOTO 330
45192C...Don't read index
45193 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
45194 MIRD=1
45195 GOTO 330
45196 ENDIF
45197 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
45198 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
45199 ELSE
45200C... Set unrecognized block flag.
45201 MERR=6
45202 ENDIF
45203
45204C...DECAY TABLES
45205C...Read in decay information
45206 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
45207C...Read new decay chanel
45208 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
45209 NDC=NDC+1
45210C...Read in branching ratio and number of daughters for this mode.
45211 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
45212 READ(CHINL(4:50),*,ERR=600) DUM, NDA
45213 IF (NDA.LE.5) THEN
45214 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
45215 & '(PYSLHA:) Decay data arrays full by KF ='
45216 $ //CHAF(KC,1))
45217C...If first decay channel, set decays start point in decay table
45218 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
45219 IF (KFORIG.EQ.0) WRITE(MSTU(11),*)
45220 & '* (PYSLHA:) Reading in SLHA decay table for ',
45221 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
45222C...Set particle parameters (mass set when reading BLOCK MASS above)
45223 PMAS(KC,2)=WIDTH
45224 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
45225 WRITE(MSTU(11),*)
45226 & '* Note: the Pythia gg->h/H/A cross section'//
45227 & ' is proportional to the h/H/A->gg width'
45228 ENDIF
45229 PMAS(KC,3)=0D0
45230 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
45231 MWID(KC)=2
45232 MDCY(KC,1)=1
45233 MDCY(KC,2)=NDC
45234 MDCY(KC,3)=0
45235C...Add to list of DECAY blocks currently read
45236 NDECAY=NDECAY+1
45237 KFDEC(NDECAY)=KF
45238C...Return ok
45239 IRETRN=0
45240 ENDIF
45241C... Count up number of decay modes for this particle
45242 MDCY(KC,3)=MDCY(KC,3)+1
45243C... Read in decay daughters.
45244 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
45245C... Flip sign if reading antiparticle decays (if antipartner exists)
45246 DO 340 IDA=1,NDA
45247 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
45248 & IDC(IDA)=MPSIGN*IDC(IDA)
45249 340 CONTINUE
45250C...Switch on decay channel, with products ordered in decreasing ABS(KF)
45251 MDME(NDC,1)=1
45252 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
45253 BRSUM=BRSUM+ABS(BRAT(NDC))
45254 BRAT(NDC)=ABS(BRAT(NDC))
45255 350 IFLIP=0
45256 DO 360 IDA=1,NDA-1
45257 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
45258 ITMP=IDC(IDA)
45259 IDC(IDA)=IDC(IDA+1)
45260 IDC(IDA+1)=ITMP
45261 IFLIP=IFLIP+1
45262 ENDIF
45263 360 CONTINUE
45264 IF (IFLIP.GT.0) GOTO 350
45265C...Treat as ordinary decay, no fancy stuff.
45266 MDME(NDC,2)=0
45267 DO 370 IDA=1,5
45268 IF (IDA.LE.NDA) THEN
45269 KFDP(NDC,IDA)=IDC(IDA)
45270 ELSE
45271 KFDP(NDC,IDA)=0
45272 ENDIF
45273 370 CONTINUE
45274C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
45275C & (KFDP(NDC,J),J=1,NDA)
45276 ELSE
45277 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line'//
45278 & CHNLIN)
45279 MERR=11
45280 NDC=NDC-1
45281 ENDIF
45282 ELSEIF(CHINL(1:1).EQ.'+') THEN
45283 MERR=11
45284 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
45285 MERR=16
45286 ELSE
45287 MERR=16
45288 ENDIF
45289 ENDIF
45290C... Error check.
45291 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
45292 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
45293 & //CHINL(1:40)
45294 MERR=0
45295 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
45296 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
45297 & CHBLCK(1:MIN(INL,40))//'... on line'//CHNLIN
45298 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
45299 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
45300 & //CHBLCK(1:INL)//'... on line'//CHNLIN
45301 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
45302 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
45303 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
45304 & //'... on line'//CHNLIN
45305 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
45306 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
45307 & /CHBLCK(1:INL)//'... on line'//CHNLIN
45308 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
45309 WRITE (CHTMP,*) KF
45310 WRITE(MSTU(11),*)
45311 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
45312 & CHTMP(1:9)//' on line'//CHNLIN
45313 ENDIF
45314C...Iterate read loop
45315 GOTO 170
45316C...Error catching
45317 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
45318 & ', ignoring subsequent lines.'
45319 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
45320 CHBLCK=' '
45321 GOTO 170
45322C...End of read loop
45323 400 CONTINUE
45324C...Set flag that KC codes have been rearranged.
45325 MSTU(20)=0
45326 VERBOS=0
45327
45328C...Perform possible tests that new information is consistent.
45329 IF (MUPDA.EQ.1) THEN
45330 MSTU23=MSTU(23)
45331 MSTU27=MSTU(27)
45332C...Check Z and top masses
45333 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
45334 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45335 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
45336 ENDIF
45337 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
45338 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45339 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
45340 & //CHTMP//'GeV')
45341 ENDIF
45342C...Check masses
45343 DO 410 ISUSY=1,37
45344 KF=KFSUSY(ISUSY)
45345C...Don't complain about right-handed neutrinos
45346 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
45347 & +16) GOTO 410
45348C...Only check gravitino in GMSB scenarios
45349 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
45350 KC=PYCOMP(KF)
45351 IF (PMAS(KC,1).EQ.0D0) THEN
45352 WRITE(CHTMP,*) KF
45353 CALL PYERRM(9
45354 & ,'(PYSLHA:) No mass information found for KF ='
45355 & //CHTMP)
45356 ENDIF
45357 410 CONTINUE
45358C...Check mixing matrices (MSSM only)
45359 IF (IMSS(13).EQ.0) THEN
45360 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
45361 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
45362 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
45363 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
45364 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
45365 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
45366 IF (MSPC(5).NE.4) CALL PYERRM(9
45367 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
45368 IF (MSPC(6).NE.4) CALL PYERRM(9
45369 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
45370 IF (MSPC(7).NE.4) CALL PYERRM(9
45371 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
45372 IF (MSPC(8).LT.1) CALL PYERRM(9
45373 & ,'(PYSLHA:) Too few elements in HMIX')
45374 IF (MSPC(10).EQ.0) CALL PYERRM(9
45375 & ,'(PYSLHA:) Missing A_b trilinear coupling')
45376 IF (MSPC(11).EQ.0) CALL PYERRM(9
45377 & ,'(PYSLHA:) Missing A_t trilinear coupling')
45378 IF (MSPC(12).EQ.0) CALL PYERRM(9
45379 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
45380 IF (MSPC(17).LT.1) CALL PYERRM(9
45381 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
45382 ENDIF
45383C...Check wavefunction normalizations.
45384C...Sfermions
45385 DO 420 ISPC=5,7
45386 IF (MSPC(ISPC).EQ.4) THEN
45387 KFSM=ISPC
45388 IF (ISPC.EQ.7) KFSM=15
45389 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
45390 & *SFMIX(KFSM,3))
45391 IF (ABS(1D0-CHECK).GT.1D-3) THEN
45392 KCSM=PYCOMP(KFSM)
45393 CALL PYERRM(17
45394 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
45395 & //CHAF(KCSM,1))
45396 ENDIF
45397 ENDIF
45398 420 CONTINUE
45399C...Neutralinos + charginos
45400 DO 440 J=1,4
45401 CN1=0D0
45402 CN2=0D0
45403 CU1=0D0
45404 CU2=0D0
45405 CV1=0D0
45406 CV2=0D0
45407 DO 430 L=1,4
45408 CN1=CN1+ZMIX(J,L)**2
45409 CN2=CN2+ZMIX(L,J)**2
45410 IF (J.LE.2.AND.L.LE.2) THEN
45411 CU1=CU1+UMIX(J,L)**2
45412 CU2=CU2+UMIX(L,J)**2
45413 CV1=CV1+VMIX(J,L)**2
45414 CV2=CV2+VMIX(L,J)**2
45415 ENDIF
45416 430 CONTINUE
45417C...NMIX normalization
45418 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
45419 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
45420 CALL PYERRM(19,
45421 & '(PYSLHA:) NMIX: Inconsistent normalization.')
45422 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
45423 ENDIF
45424C...UMIX, VMIX normalizations
45425 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
45426 IF (J.LE.2) THEN
45427 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
45428 CALL PYERRM(19
45429 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
45430 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
45431 & CU2
45432 ENDIF
45433 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
45434 CALL PYERRM(19,
45435 & '(PYSLHA:) VMIX: Inconsistent normalization.')
45436 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
45437 & CV2
45438 ENDIF
45439 ENDIF
45440 ENDIF
45441 440 CONTINUE
45442 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
45443 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
45444 & '* PYSLHA: No spectrum inconsistencies were found.'
45445 ELSE
45446 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
45447 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
45448 & ,' Warning: one or more (serious)'//
45449 & ' inconsistencies were found in the spectrum !'
45450 & ,' Read the error messages above and check your'//
45451 & ' input file.'
45452 ENDIF
45453C...Increase precision in Higgs sector using FeynHiggs
45454 IF (IMSS(4).EQ.3) THEN
45455C...FeynHiggs needs MSOFT.
45456 IERR=0
45457 IF (MSPC(18).EQ.0) THEN
45458 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
45459 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
45460 & ' Cannot call FeynHiggs.'
45461 IERR=-1
45462 ELSE
45463 WRITE(MSTU(11),'(1x,/1x,A/)')
45464 & '* (PYSLHA:) Now calling FeynHiggs.'
45465 CALL PYFEYN(IERR)
45466 IF (IERR.NE.0) IMSS(4)=2
45467 ENDIF
45468 ENDIF
45469 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
45470 IBEG=1
45471 IF (KFORIG.NE.0) IBEG=NDECAY
45472 DO 490 IDECAY=IBEG,NDECAY
45473 KF = KFDEC(IDECAY)
45474 KC = PYCOMP(KF)
45475 WRITE(CHKF,8300) KF
45476 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
45477 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
45478 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
45479 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
45480 $ //CHKF)
45481 BRSUM=0D0
45482 BROPN=0D0
45483 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45484 IF(MDME(IDA,2).GT.80) GOTO 460
45485 KQ=KCHG(KC,1)
45486 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
45487 MERR=0
45488 DO 450 J=1,5
45489 KP=KFDP(IDA,J)
45490 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
45491 IF(KP.EQ.81) KQ=0
45492 ELSEIF(PYCOMP(KP).EQ.0) THEN
45493 MERR=3
45494 ELSE
45495 KQ=KQ-PYCHGE(KP)
45496 KPC=PYCOMP(KP)
45497 PMS=PMS-PMAS(KPC,1)
45498 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
45499 & PMAS(KPC,3))
45500 ENDIF
45501 450 CONTINUE
45502 IF(KQ.NE.0) MERR=MAX(2,MERR)
45503 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
45504 & MERR=MAX(1,MERR)
45505 IF(MERR.EQ.3) CALL PYERRM(17,
45506 & '(PYSLHA:) Unknown particle code in decay of KF ='
45507 $ //CHKF)
45508 IF(MERR.EQ.2) CALL PYERRM(17,
45509 & '(PYSLHA:) Charge not conserved in decay of KF ='
45510 $ //CHKF)
45511 IF(MERR.EQ.1) CALL PYERRM(7,
45512 & '(PYSLHA:) Kinematically unallowed decay of KF ='
45513 $ //CHKF)
45514 BRSUM=BRSUM+BRAT(IDA)
45515 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
45516 460 CONTINUE
45517C...Check branching ratio sum.
45518 IF (BROPN.LE.0D0) THEN
45519C...If zero, set stable.
45520 WRITE(CHTMP,8500) BROPN
45521 CALL PYERRM(7
45522 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
45523 & CHTMP(9:16)//'. Changed to stable.')
45524 PMAS(KC,2)=1D-6
45525 MWID(KC)=0
45526C...If BR's > 1, rescale.
45527 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
45528 WRITE(CHTMP,8500) BRSUM
45529 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
45530 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
45531 & ' ; sum was'//CHTMP(9:16)//'.')
45532 FAC=1D0/BRSUM
45533 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45534 IF(MDME(IDA,2).GT.80) GOTO 470
45535 BRAT(IDA)=FAC*BRAT(IDA)
45536 470 CONTINUE
45537 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
45538C...If BR's < 1, insert dummy mode for proper cross section rescaling.
45539 WRITE(CHTMP,8500) BRSUM
45540 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
45541 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
45542 & CHTMP(9:16)//'. Dummy mode will be inserted.')
45543C...Move table and insert dummy mode
45544 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45545 NDC=NDC+1
45546 BRAT(NDC)=BRAT(IDA)
45547 KFDP(NDC,1)=KFDP(IDA,1)
45548 KFDP(NDC,2)=KFDP(IDA,2)
45549 KFDP(NDC,3)=KFDP(IDA,3)
45550 KFDP(NDC,4)=KFDP(IDA,4)
45551 KFDP(NDC,5)=KFDP(IDA,5)
45552 MDME(NDC,1)=MDME(IDA,1)
45553 480 CONTINUE
45554 NDC=NDC+1
45555 BRAT(NDC)=1D0-BRSUM
45556 KFDP(NDC,1)=0
45557 KFDP(NDC,2)=0
45558 KFDP(NDC,3)=0
45559 KFDP(NDC,4)=0
45560 KFDP(NDC,5)=0
45561 MDME(NDC,1)=0
45562 BRSUM=1D0
45563C...Update MDCY
45564 MDCY(KC,3)=MDCY(KC,3)+1
45565 MDCY(KC,2)=NDC-MDCY(KC,3)+1
45566 ENDIF
45567 490 CONTINUE
45568 ENDIF
45569
45570
45571C...WRITE SPECTRUM ON SLHA FILE
45572 ELSEIF(MUPDA.EQ.3) THEN
45573C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
45574 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
45575 MODSEL(1)=1
45576 PARMIN(1)=RMSS(8)
45577 PARMIN(2)=RMSS(1)
45578 PARMIN(3)=RMSS(5)
45579 PARMIN(4)=SIGN(1D0,RMSS(4))
45580 PARMIN(5)=RMSS(36)
45581 ENDIF
45582C...Write spectrum
45583 WRITE(LFN,7000) 'SLHA MSSM spectrum'
45584 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
45585 & // ' P. Skands.'
45586 WRITE(LFN,7010) 'MODSEL', 'Model selection'
45587 WRITE(LFN,7110) 1, MODSEL(1)
45588 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
45589 IF (MODSEL(1).EQ.1) THEN
45590 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
45591 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
45592 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45593 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45594 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
45595 ELSEIF(MODSEL(2).EQ.2) THEN
45596 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
45597 WRITE(LFN,7210) 2, PARMIN(2), 'M'
45598 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45599 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45600 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
45601 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
45602 ENDIF
45603 WRITE(LFN,7000) ' '
45604 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
45605 DO 500 I=1,36
45606 KF=KFSUSY(I)
45607 KC=PYCOMP(KF)
45608 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
45609 KFSM=KF-KSUSY1
45610 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
45611 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
45612 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
45613 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
45614 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
45615 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
45616 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
45617 ELSE
45618 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
45619 ENDIF
45620 500 CONTINUE
45621C...SUSY scale
45622 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
45623 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
45624 WRITE(LFN,7210) 1, RMSS(4),'mu'
45625 WRITE(LFN,7010) 'ALPHA',' '
45626 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
45627 WRITE(LFN,7020) 'AU',RMSUSY
45628 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
45629 WRITE(LFN,7020) 'AD',RMSUSY
45630 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
45631 WRITE(LFN,7020) 'AE',RMSUSY
45632 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
45633 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
45634 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
45635 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
45636 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
45637 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
45638 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
45639 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
45640 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
45641 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
45642 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
45643 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
45644 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
45645 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
45646 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
45647 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
45648 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
45649 DO 520 I1=1,4
45650 DO 510 I2=1,4
45651 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
45652 510 CONTINUE
45653 520 CONTINUE
45654 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
45655 DO 540 I1=1,2
45656 DO 530 I2=1,2
45657 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
45658 530 CONTINUE
45659 540 CONTINUE
45660 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
45661 DO 560 I1=1,2
45662 DO 550 I2=1,2
45663 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
45664 550 CONTINUE
45665 560 CONTINUE
45666 WRITE(LFN,7010) 'SPINFO'
45667 IF (IMSS(1).EQ.2) THEN
45668 CPRO(1)='PYTHIA'
45669 CVER(1)='6.4'
45670 ELSEIF (IMSS(1).EQ.12) THEN
45671 ISAVER=VISAJE()
45672 CPRO(1)='ISASUSY'
45673 CVER(1)=ISAVER(1:12)
45674 ENDIF
45675 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
45676 WRITE(LFN,7310) 2, CVER(1), 'Version number'
45677 ENDIF
45678
45679C...Print user information about spectrum
45680 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
45681 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
45682 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
45683 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
45684 IF (MUPDA.EQ.1) THEN
45685 WRITE(MSTU(11),5020) LFN
45686 ELSE
45687 WRITE(MSTU(11),5010) LFN
45688 ENDIF
45689
45690 WRITE(MSTU(11),5400)
45691 WRITE(MSTU(11),5500) 'Pole masses'
45692 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
45693 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
45694 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
45695 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
45696 IF (IMSS(13).EQ.0) THEN
45697 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
45698 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
45699 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
45700 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
45701 & CHAF(37,1), ' ', ' ',' ',' ',
45702 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
45703 ELSEIF (IMSS(13).EQ.1) THEN
45704 KF1=KSUSY1+21
45705 KF2=KSUSY1+22
45706 KF3=KSUSY1+23
45707 KF4=KSUSY1+25
45708 KF5=KSUSY1+35
45709 KF6=KSUSY1+45
45710 KF7=KSUSY1+24
45711 KF8=KSUSY1+37
45712 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
45713 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
45714 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
45715 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
45716 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
45717 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
45718 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
45719 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
45720 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
45721 & RMFUN(37)
45722 ENDIF
45723 WRITE(MSTU(11),5400)
45724 WRITE(MSTU(11),5500) 'Mixing structure'
45725 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45726 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45727 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45728 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45729 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45730 & ),(SFMIX(15,J),J=3,4)
45731 WRITE(MSTU(11),5400)
45732 WRITE(MSTU(11),5500) 'Couplings'
45733 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
45734 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
45735 WRITE(MSTU(11),5400)
45736 WRITE(MSTU(11),6500)
45737
45738 ENDIF
45739
45740C...Only rewind when reading
45741 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
45742
45743 9999 RETURN
45744
45745C...Serious error catching
45746 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
45747 write(*,*) CHINL(1:80)
45748 CALL PYSTOP(106)
45749 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
45750 WRITE(*,*) CHINL(1:72)
45751 CALL PYSTOP(106)
45752 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
45753 WRITE(*,*) CHINL(1:80)
45754 CALL PYSTOP(106)
45755 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
45756 WRITE(*,*) CHINL(1:80)
45757 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
45758 CALL PYSTOP(106)
45759 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
45760 WRITE(*,*) CHINL(1:80)
45761 CALL PYSTOP(106)
45762
45763 8300 FORMAT(I9)
45764 8500 FORMAT(F16.5)
45765
45766C...Formats for user information printout.
45767 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.10: SUSY/BSM SPECTRUM '
45768 & ,'INTERFACE',1x,17('*')/1x,'*',2x
45769 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
45770 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
45771 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
45772 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
45773 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
45774 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
45775 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45776 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45777 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
45778 & ,'----------------')
45779 5400 FORMAT(1x,'*',1x,A)
45780 5500 FORMAT(1x,'*',1x,A,':')
45781 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45782 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45783 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
45784 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
45785 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45786 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
45787 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
45788 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45789 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45790 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45791 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45792 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
45793 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45794 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45795 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45796 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45797 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45798 & ,1x,F6.3,1x),'|')
45799 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45800 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45801 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45802 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45803 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45804 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45805 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45806 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45807 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45808 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45809 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45810 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45811 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
45812 & ,'A_tau = ',F8.2)
45813 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
45814 & ,' mu = ',F8.2)
45815 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
45816
45817C...Format to use for comments
45818 7000 FORMAT('# ',A)
45819C...Format to use for block statements
45820 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
45821 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
45822C...Indexed Int
45823 7110 FORMAT(1x,I4,1x,I4,3x,'#')
45824C...Non-Indexed Double
45825 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
45826C...Indexed Double
45827 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
45828C...Long Indexed Double (PDG + double)
45829 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
45830C...Indexed Char(12)
45831 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
45832C...Single matrix
45833 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
45834C...Double Matrix
45835 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
45836C...Write Decay Table
45837 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
45838 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
45839 & 3x,'#',1x,A)
45840
45841 END
45842
45843
45844C*********************************************************************
45845
45846C...PYAPPS
45847C...Uses approximate analytical formulae to determine the full set of
45848C...MSSM parameters from SUGRA input.
45849C...See M. Drees and S.P. Martin, hep-ph/9504124
45850
45851 SUBROUTINE PYAPPS
45852
45853C...Double precision and integer declarations.
45854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45855 IMPLICIT INTEGER(I-N)
45856 INTEGER PYK,PYCHGE,PYCOMP
45857C...Parameter statement to help give large particle numbers.
45858 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45859 &KEXCIT=4000000,KDIMEN=5000000)
45860C...Commonblocks.
45861 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45862 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45863 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45864 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
45865
45866 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
45867 &' not intended for serious physics studies'
45868 IMSS(5)=0
45869 IMSS(8)=0
45870 XMT=PMAS(6,1)
45871 XMZ2=PMAS(23,1)**2
45872 XMW2=PMAS(24,1)**2
45873 TANB=RMSS(5)
45874 BETA=ATAN(TANB)
45875 XW=PARU(102)
45876 XMG=RMSS(1)
45877 XMG2=XMG*XMG
45878 XM0=RMSS(8)
45879 XM02=XM0*XM0
45880C...Temporary sign change for AT. Others unchanged.
45881 AT=-RMSS(16)
45882 RMSS(15)=RMSS(16)
45883 RMSS(17)=RMSS(16)
45884 SINB=TANB/SQRT(TANB**2+1D0)
45885 COSB=SINB/TANB
45886
45887 DTERM=XMZ2*COS(2D0*BETA)
45888 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
45889 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
45890 RMSS(6)=XMEL
45891 RMSS(7)=XMER
45892 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
45893 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
45894 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
45895 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
45896 DO 100 I=1,5,2
45897 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
45898 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
45899 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
45900 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
45901 100 CONTINUE
45902 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
45903 IF(XARG.LT.0D0) THEN
45904 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45905 & ' FROM THE SUM RULE. '
45906 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45907 RETURN
45908 ELSE
45909 XARG=SQRT(XARG)
45910 ENDIF
45911 DO 110 I=11,15,2
45912 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
45913 PMAS(PYCOMP(KSUSY2+I),1)=XMER
45914 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45915 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45916 110 CONTINUE
45917 RMT=PYMRUN(6,PMAS(6,1)**2)
45918 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
45919 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
45920 RMB=PYMRUN(5,PMAS(6,1)**2)
45921 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
45922 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
45923 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
45924 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
45925 &SINB)**2)
45926 RMSS(16)=-ATP
45927 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
45928 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
45929 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
45930 XMU=SIGN(SQRT(XMU2),RMSS(4))
45931 RMSS(4)=XMU
45932 IF(XMA2.GT.0D0) THEN
45933 RMSS(19)=SQRT(XMA2)
45934 ELSE
45935 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
45936 CALL PYSTOP(102)
45937 ENDIF
45938 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
45939 IF(ARG.GT.0D0) THEN
45940 RMSS(14)=SQRT(ARG)
45941 ELSE
45942 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
45943 CALL PYSTOP(102)
45944 ENDIF
45945 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
45946 IF(ARG.GT.0D0) THEN
45947 RMSS(13)=SQRT(ARG)
45948 ELSE
45949 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
45950 CALL PYSTOP(102)
45951 ENDIF
45952 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
45953 IF(ARG.GT.0D0) THEN
45954 RMSS(10)=SQRT(ARG)
45955 ELSE
45956 RMSS(10)=-SQRT(-ARG)
45957 ENDIF
45958 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
45959 IF(ARG.GT.0D0) THEN
45960 RMSS(12)=SQRT(ARG)
45961 ELSE
45962 RMSS(12)=-SQRT(-ARG)
45963 ENDIF
45964 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
45965 IF(ARG.GT.0D0) THEN
45966 RMSS(11)=SQRT(ARG)
45967 ELSE
45968 RMSS(11)=-SQRT(-ARG)
45969 ENDIF
45970
45971 RETURN
45972 END
45973
45974C*********************************************************************
45975
45976C...PYSUGI
45977C...Interface to ISASUSY version 7.71.
45978C...Warning: this interface should not be used with earlier versions
45979C...of ISASUSY, since common block incompatibilities may then arise.
45980C...Calls SUGRA (in ISAJET) to perform RGE evolution.
45981C...Then converts to Gunion-Haber conventions.
45982
45983 SUBROUTINE PYSUGI
45984 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45985
45986 INTEGER PYK,PYCHGE,PYCOMP
45987 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45988 &KEXCIT=4000000,KDIMEN=5000000)
45989
45990C...Date of Change
45991 CHARACTER DOC*11
45992 PARAMETER (DOC='01 May 2006')
45993
45994C...ISASUGRA Input:
45995 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
45996C...XISAIN contains the MSSMi inputs in natural order.
45997 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
45998 $XAMIN(7)
45999 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46000 SAVE /SUGXIN/
46001C...ISASUGRA Output
46002 CHARACTER*40 ISAVER,VISAJE
46003 REAL SUPER
46004 COMMON /SSPAR/ SUPER(72)
46005 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46006 $FBGUT,FTAGUT,FNGUT
46007 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46008 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46009 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46010 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46011 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46012 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46013 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46014 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46015 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46016 INTEGER IALLOW
46017 SAVE /SUGMG/,/SSPAR/
46018C SUPER: Filled by ISASUGRA.
46019C SUPER(1) = mass of ~g
46020C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46021C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46022C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46023C ,~tau_2
46024C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46025C SUPER(29) = Higgsino mass = - mu
46026C SUPER(30) = ratio v2/v1 of vev's
46027C SUPER(31:34) = Signed neutralino masses
46028C SUPER(35:50) = Neutralino mixing matrix
46029C SUPER(51:52) = Signed chargino masses
46030C SUPER(53:54) = Chargino left, right mixing angles
46031C SUPER(55:58) = mass of h0, H0, A0, H+
46032C SUPER(59) = Higgs mixing angle alpha
46033C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46034C SUPER(66) = Gravitino mass
46035C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46036C SUPER(70) = b-Yukawa at mA scale (not used)
46037C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46038C GSS: Filled by ISASUGRA
46039C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46040C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46041C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46042C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46043C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46044C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46045C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46046C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46047C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46048C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46049C GSS(31) = log(vuq)
46050C MSS: Filled by ISASUGRA
46051C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46052C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46053C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46054C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46055C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46056C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46057C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46058C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46059C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46060C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46061C MSS(31) = ha0 MSS(32) = h+
46062C Unification, filled by ISASUGRA if applicable.
46063C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46064
46065C...SPYTHIA Input/Output
46066 INTEGER IMSS
46067 DOUBLE PRECISION RMSS
46068 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46069 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46070 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46071C...SLHA Input/Output
46072 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46073 & AU(3,3),AD(3,3),AE(3,3)
46074C...PYTHIA common blocks
46075 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46076 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46077 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46078
46079 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
46080CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46081 INTEGER IMODEL
46082 REAL M0,MHF,A0,MT
46083 CHARACTER*20 CHMOD(5)
46084 CHARACTER*32 FNAME
46085
46086 COMMON /SUGNU/ XNUSUG(18)
46087 REAL XNUSUG
46088 SAVE /SUGNU/
46089
46090 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
46091 & 'truly unified SUGRA', 'non-minimal GMSB'/
46092
46093C...Start by checking for incompatibilities/inconsistencies:
46094 DO 100 ICHK=2,9
46095 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
46096 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
46097 & ,' option not used by PYSUGI'
46098 ENDIF
46099 100 CONTINUE
46100C...ISAJET works with REAL numbers.
46101 MZERO=REAL(RMSS(8))
46102 MHLF=REAL(RMSS(1))
46103 AZERO=REAL(RMSS(16))
46104 TANB=REAL(RMSS(5))
46105 SGNMU=REAL(RMSS(4))
46106 MTOP=REAL(PMAS(6,1))
46107 IMODEL=0
46108 IF (IMSS(1).EQ.12) THEN
46109 IMODEL=1
46110 GOTO 130
46111 ELSEIF(IMSS(1).EQ.13) THEN
46112C...Read from isajet par file in IMSS(20)
46113 LFN=IMSS(20)
46114C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46115 IF (LFN.EQ.0) THEN
46116 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46117 GOTO 9999
46118 ENDIF
46119 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
46120CMrenna change to allow any susy model
46121 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
46122 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
46123 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
46124 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
46125 & ' gauge couplings:'
46126 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
46127 READ(LFN,*) IMODEL
46128 IF (IMODEL.EQ.4) THEN
46129 IAL3UN=1
46130 IMODEL=1
46131 ENDIF
46132 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
46133 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46134 & //' sgn(mu), M_t:'
46135 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
46136 IF (IMODEL.EQ.3) THEN
46137 IMODEL=1
46138 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46139 & //' 0 to continue:'
46140 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
46141 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
46142 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
46143 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
46144 & //' generation masses'
46145 WRITE(MSTU(11),*)
46146 & ' NUSUG5 = GUT scale 3rd generation masses'
46147 READ(LFN,*) INUSUG
46148 IF (INUSUG.EQ.0) THEN
46149 GOTO 120
46150 ELSEIF (INUSUG.EQ.1) THEN
46151 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
46152 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
46153 IF (XNUSUG(3).LE.0.) THEN
46154 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
46155 CALL PYSTOP(109)
46156 END IF
46157 ELSEIF (INUSUG.EQ.2) THEN
46158 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
46159 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
46160 ELSEIF (INUSUG.EQ.3) THEN
46161 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
46162 READ(LFN,*) XNUSUG(7),XNUSUG(8)
46163 ELSEIF (INUSUG.EQ.4) THEN
46164 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
46165 & //' M(ur), M(el), M(er):'
46166 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
46167 & XNUSUG(10),XNUSUG(9)
46168 ELSEIF (INUSUG.EQ.5) THEN
46169 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
46170 & //' M(Ll), M(Lr):'
46171 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
46172 & XNUSUG(15),XNUSUG(14)
46173 ENDIF
46174 GOTO 110
46175 ENDIF
46176 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
46177 IMSS(11)=1
46178 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
46179 & ,' sgn(mu), M_t, C_gv:'
46180 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
46181 XGMIN(7)=XCMGV
46182 XGMIN(8)=1.
46183C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
46184 AMPL=2.4D18
46185 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
46186 IF (IMODEL.EQ.5) THEN
46187 IMODEL=2
46188 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
46189 & ,' masses at M_mes'
46190 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
46191 & ,' shifts at M_mes'
46192 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
46193 & ' Y at M_mes'
46194 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
46195 & ,'SU(2),SU(3)'
46196 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
46197 & ,' n5_2, n5_3'
46198 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
46199 $ XGMIN(13),XGMIN(14)
46200 ENDIF
46201 ELSE
46202 WRITE(MSTU(11),*) 'Invalid model choice.'
46203 GOTO 9999
46204 ENDIF
46205 ENDIF
46206
46207 120 MZERO=M0
46208 MHLF=MHF
46209 AZERO=A0
46210C TANB=REAL(RMSS(5))
46211C SGNMU=REAL(RMSS(4))
46212 MTOP=MT
46213
46214C...Initialize MSSM parameter array
46215 130 DO 140 IPAR=1,72
46216 SUPER(IPAR)=0.0
46217 140 CONTINUE
46218C...Call ISASUGRA
46219 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
46220C...Check whether ISASUSY thought the model was OK.
46221 IF (NOGOOD.NE.0) THEN
46222 IF (NOGOOD.EQ.1) CALL PYERRM(26
46223 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
46224 IF (NOGOOD.EQ.2) CALL PYERRM(26
46225 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
46226 IF (NOGOOD.EQ.3) CALL PYERRM(26
46227 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
46228 IF (NOGOOD.EQ.4) CALL PYERRM(26
46229 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
46230 IF (NOGOOD.EQ.7) CALL PYERRM(26
46231 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
46232 IF (NOGOOD.EQ.8) CALL PYERRM(26
46233 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
46234C...Give warning, but don't stop, if LSP not ~chi_10.
46235 IF (NOGOOD.EQ.5) CALL PYERRM(16
46236 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
46237 ENDIF
46238C...Warn about possible GUT scale tachyons.
46239 IF (ITACHY.NE.0) CALL PYERRM(16,
46240 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
46241C...Finalize spectrum (last iteration)
46242C...(Thanks to A. Raklev for pointing this out.)
46243C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
46244 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
46245 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
46246 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
46247 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
46248 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
46249 $ MTOP,IALLOW,1)
46250
46251C...M1, M2, M3.
46252 RMSS(1)=dble(GSS(7))
46253 RMSS(2)=dble(GSS(8))
46254 RMSS(3)=dble(GSS(9))
46255 RMSOFT(1)=dble(GSS(7))
46256 RMSOFT(2)=dble(GSS(8))
46257 RMSOFT(3)=dble(GSS(9))
46258C...Mu = - Higgsino mass.
46259 RMSS(4)=-SUPER(29)
46260 RMSS(5)=TANB
46261C...Slepton and squark masses. 2 first generations.
46262 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
46263 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
46264 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
46265 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
46266C...Third generation.
46267 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
46268 RMSS(11)=SUPER(11)
46269 RMSS(12)=SUPER(15)
46270 RMSS(13)=SUPER(22)
46271 RMSS(14)=SUPER(23)
46272C...SLHA: store exact soft spectrum in RMSOFT
46273 RMSOFT(31)=SUPER(18)
46274 RMSOFT(32)=SUPER(20)
46275 RMSOFT(33)=SUPER(22)
46276 RMSOFT(34)=SUPER(19)
46277 RMSOFT(35)=SUPER(21)
46278 RMSOFT(36)=SUPER(23)
46279 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
46280 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
46281 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
46282 RMSOFT(44)=SUPER(3)
46283 RMSOFT(45)=SUPER(9)
46284 RMSOFT(46)=SUPER(15)
46285 RMSOFT(47)=SUPER(5)
46286 RMSOFT(48)=SUPER(7)
46287 RMSOFT(49)=SUPER(11)
46288
46289C...~b, ~t, and ~tau trilinear couplings and mixing angles.
46290 RMSS(15)=SUPER(62)
46291 RMSS(16)=SUPER(60)
46292 RMSS(17)=SUPER(64)
46293 RMSS(26)=SUPER(63)
46294 RMSS(27)=SUPER(61)
46295 RMSS(28)=SUPER(65)
46296C...SLHA trilinears
46297 DO 142 K1=1,3
46298 DO 141 K2=1,3
46299 AE(K1,K2)=0D0
46300 AU(K1,K2)=0D0
46301 AD(K1,K2)=0D0
46302 141 CONTINUE
46303 142 CONTINUE
46304 AE(3,3)=SUPER(64)
46305 AU(3,3)=SUPER(60)
46306 AD(3,3)=SUPER(62)
46307C...Higgs mixing angle alpha (Gunion-Haber convention).
46308 RMSS(18)=-SUPER(59)
46309C...A0 mass.
46310 RMSS(19)=SUPER(57)
46311C...GUT scale coupling
46312 RMSS(20)=AGUTSS
46313C...Gravitino mass (for future compatibility)
46314 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
46315
46316C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
46317C...Higgs sector.
46318 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
46319 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
46320 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
46321 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
46322C...Gluino.
46323 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
46324C...Squarks and Sleptons.
46325 DO 150 ILR=1,2
46326 ILRM=ILR-1
46327 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
46328 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
46329 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
46330 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
46331 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
46332 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
46333 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
46334 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
46335 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
46336 150 CONTINUE
46337 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
46338 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
46339 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
46340C...Neutralinos.
46341 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
46342 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
46343 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
46344 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
46345C...Signed masses (extra minus from going to G-H convention).
46346 SMZ(1)=-SUPER(31)
46347 SMZ(2)=-SUPER(32)
46348 SMZ(3)=-SUPER(33)
46349 SMZ(4)=-SUPER(34)
46350C...Charginos
46351 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
46352 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
46353C...Signed masses (extra minus from going to G-H convention).
46354 SMW(1)=-SUPER(51)
46355 SMW(2)=-SUPER(52)
46356
46357C... Neutralino Mixing.
46358 DO 160 IN=1,4
46359 ZMIX(IN,1)= SUPER(38+4*(IN-1))
46360 ZMIX(IN,2)= SUPER(37+4*(IN-1))
46361 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
46362 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
46363 160 CONTINUE
46364C...Chargino Mixing (PYTHIA same angle as HERWIG).
46365 THX=1D0
46366 THY=1D0
46367 IF (SUPER(53).GT.0) THX=-1D0
46368 IF (SUPER(54).GT.0) THY=-1D0
46369 UMIX(1,1) = -SIN(SUPER(53))
46370 UMIX(1,2) = -COS(SUPER(53))
46371 UMIX(2,1) = -THX*COS(SUPER(53))
46372 UMIX(2,2) = THX*SIN(SUPER(53))
46373 VMIX(1,1) = -SIN(SUPER(54))
46374 VMIX(1,2) = -COS(SUPER(54))
46375 VMIX(2,1) = -THY*COS(SUPER(54))
46376 VMIX(2,2) = THY*SIN(SUPER(54))
46377C...Sfermion mixing (PYTHIA same angle as ISAJET)
46378 SFMIX(5,1)=COS(SUPER(63))
46379 SFMIX(5,2)=SIN(SUPER(63))
46380 SFMIX(5,3)=-SIN(SUPER(63))
46381 SFMIX(5,4)=COS(SUPER(63))
46382 SFMIX(6,1)=COS(SUPER(61))
46383 SFMIX(6,2)=SIN(SUPER(61))
46384 SFMIX(6,3)=-SIN(SUPER(61))
46385 SFMIX(6,4)=COS(SUPER(61))
46386 SFMIX(15,1)=COS(SUPER(65))
46387 SFMIX(15,2)=SIN(SUPER(65))
46388 SFMIX(15,3)=-SIN(SUPER(65))
46389 SFMIX(15,4)=COS(SUPER(65))
46390
46391 IF (MSTP(122).NE.0) THEN
46392C...Print a few lines to make the user know what's happening
46393 ISAVER=VISAJE()
46394 WRITE(MSTU(11),5000) DOC, ISAVER
46395 WRITE(MSTU(11),5100)
46396 IF (IMODEL.EQ.1) THEN
46397 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
46398 & MTOP
46399 WRITE(MSTU(11),5300)
46400 ENDIF
46401 WRITE(MSTU(11),5500) 'Pole masses'
46402 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
46403 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
46404 & ,(SUPER(IP),IP=19,25,2)
46405 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
46406 & ,IP=1,2)
46407 WRITE(MSTU(11),5400)
46408 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
46409 WRITE(MSTU(11),5400)
46410 WRITE(MSTU(11),5500) 'EW scale mixing structure'
46411 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46412 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46413 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46414 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46415 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46416 & ),(SFMIX(15,J),J=3,4)
46417 WRITE(MSTU(11),5400)
46418 WRITE(MSTU(11),6450) RMSS(18)
46419 WRITE(MSTU(11),5400)
46420 WRITE(MSTU(11),5500) 'Couplings'
46421 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
46422 WRITE(MSTU(11),5400)
46423 ENDIF
46424
46425C...Call FeynHiggs to improve Higgs sector if requested
46426 IF (IMSS(4).EQ.3) THEN
46427 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
46428 & ' (PYSUGI:) Now calling FeynHiggs.'
46429 CALL PYFEYN(IERR)
46430 IF (IERR.EQ.0) THEN
46431 IMSS(4)=2
46432 IF (MSTP(122).NE.0) THEN
46433 WRITE(MSTU(11),5400)
46434 WRITE(MSTU(11),5500)
46435 & 'Corrected Higgs masses and mixing'
46436 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
46437 & PMAS(37,1)
46438 WRITE(MSTU(11),6450) RMSS(18)
46439 WRITE(MSTU(11),5400)
46440 ENDIF
46441 ENDIF
46442 ENDIF
46443
46444 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
46445
46446C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
46447C...output by ISASUSY.
46448 IMSS(4)=MAX(2,IMSS(4))
46449
46450 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
46451 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
46452 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
46453 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
46454 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46455 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46456 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
46457 & ,'----------------')
46458 5400 FORMAT(1x,'*',1x,A)
46459 5500 FORMAT(1x,'*',1x,A,':')
46460 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46461 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46462 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
46463 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
46464 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
46465 & ,1x))
46466 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
46467 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
46468 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
46469 & .2,1x))
46470 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46471 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46472 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46473 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46474 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
46475 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46476 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
46477 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46478 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46479 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46480 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46481 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46482 & ,1x,F6.3,1x),'|')
46483 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46484 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46485 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46486 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46487 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46488 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46489 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46490 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46491 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46492 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46493 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46494 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46495 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
46496 & ,4x,'Alpha_GUT = ',F8.2)
46497 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
46498 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
46499
46500 9999 RETURN
46501 END
46502
46503C*********************************************************************
46504
46505C...PYFEYN
46506C...Interface to FeynHiggs for MSSM Higgs sector.
46507C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
46508C...P. Skands
46509
46510 SUBROUTINE PYFEYN(IERR)
46511
46512C...Double precision and integer declarations.
46513 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46514 IMPLICIT INTEGER(I-N)
46515 INTEGER PYK,PYCHGE,PYCOMP
46516C...Commonblocks.
46517 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46518 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46519C...SUSY blocks
46520 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46521C...FeynHiggs variables
46522 DOUBLE PRECISION RMHIGG(4)
46523 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
46524 DOUBLE COMPLEX DMU,
46525 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46526 & DM1, DM2, DM3
46527C...SLHA Common Block
46528 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46529 & AU(3,3),AD(3,3),AE(3,3)
46530 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
46531
46532 IERR=0
46533 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
46534 IF (IERR.NE.0) THEN
46535 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
46536 & //'Will not use FeynHiggs for this run.')
46537 RETURN
46538 ENDIF
46539 Q=RMSOFT(0)
46540 DMB=PMAS(5,1)
46541 DMT=PMAS(6,1)
46542 DMZ=PMAS(23,1)
46543 DMW=PMAS(24,1)
46544 DMA=PMAS(36,1)
46545 DM1=RMSOFT(1)
46546 DM2=RMSOFT(2)
46547 DM3=RMSOFT(3)
46548 DTANB=RMSS(5)
46549 DMU=RMSS(4)
46550 DM3SL=RMSOFT(33)
46551 DM3SE=RMSOFT(36)
46552 DM3SQ=RMSOFT(43)
46553 DM3SU=RMSOFT(46)
46554 DM3SD=RMSOFT(49)
46555 DM2SL=RMSOFT(32)
46556 DM2SE=RMSOFT(35)
46557 DM2SQ=RMSOFT(42)
46558 DM2SU=RMSOFT(45)
46559 DM2SD=RMSOFT(48)
46560 DM1SL=RMSOFT(31)
46561 DM1SE=RMSOFT(34)
46562 DM1SQ=RMSOFT(41)
46563 DM1SU=RMSOFT(44)
46564 DM1SD=RMSOFT(47)
46565 AE33=AE(3,3)
46566 AE22=AE(2,2)
46567 AE11=AE(1,1)
46568 AU33=AU(3,3)
46569 AU22=AU(2,2)
46570 AU11=AU(1,1)
46571 AD33=AD(3,3)
46572 AD22=AD(2,2)
46573 AD11=AD(1,1)
46574 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
46575 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
46576 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
46577 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
46578 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46579 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
46580 IF (IERR.NE.0) THEN
46581 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
46582 & //' Will not use FeynHiggs for this run.')
46583 RETURN
46584 ENDIF
46585C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
46586 SAEFF=0D0
46587 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
46588 IF (IERR.NE.0) THEN
46589 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
46590 & 'GSCORR. Will not use FeynHiggs for this run.')
46591 RETURN
46592 ENDIF
46593 ALPHA = ASIN(DBLE(SAEFF))
46594 R=RMSS(18)/ALPHA
46595 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
46596 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46597 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
46598 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
46599 ENDIF
46600 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
46601 & 1.15D0*PMAS(25,1)) THEN
46602 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46603 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
46604 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
46605 ENDIF
46606 RMSS(18)=ALPHA
46607 PMAS(25,1)=RMHIGG(1)
46608 PMAS(35,1)=RMHIGG(2)
46609 PMAS(36,1)=RMHIGG(3)
46610 PMAS(37,1)=RMHIGG(4)
46611
46612 RETURN
46613 END
46614
46615C*********************************************************************
46616
46617C...PYRNMQ
46618C...Determines the running mass of Squarks.
46619
46620 FUNCTION PYRNMQ(ID,DTERM)
46621
46622C...Double precision and integer declarations.
46623 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46624 IMPLICIT INTEGER(I-N)
46625 INTEGER PYK,PYCHGE,PYCOMP
46626C...Commonblock.
46627 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46628 SAVE /PYMSSM/
46629
46630C...Local variables.
46631 DOUBLE PRECISION PI,R
46632 DOUBLE PRECISION TOL
46633 DOUBLE PRECISION CI(3)
46634 EXTERNAL PYALPS
46635 DOUBLE PRECISION PYALPS
46636 DATA TOL/0.001D0/
46637 DATA PI,R/3.141592654D0,.61803399D0/
46638 DATA CI/0.47D0,0.07D0,0.02D0/
46639
46640 C=1D0-R
46641 CA=CI(ID)
46642 AG=(0.71D0)**2/4D0/PI
46643 AG=RMSS(20)
46644 XM0=RMSS(8)
46645 XMG=RMSS(1)
46646 XM02=XM0*XM0
46647 XMG2=XMG*XMG
46648
46649 AS=PYALPS(XM02+6D0*XMG2)
46650 CG=8D0/9D0*((AS/AG)**2-1D0)
46651 BX=XM02+(CA+CG)*XMG2+DTERM
46652 AX=MIN(50D0**2,0.5D0*BX)
46653 CX=MAX(2000D0**2,2D0*BX)
46654
46655 X0=AX
46656 X3=CX
46657 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46658 X1=BX
46659 X2=BX+C*(CX-BX)
46660 ELSE
46661 X2=BX
46662 X1=BX-C*(BX-AX)
46663 ENDIF
46664 AS1=PYALPS(X1)
46665 CG=8D0/9D0*((AS1/AG)**2-1D0)
46666 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46667 AS2=PYALPS(X2)
46668 CG=8D0/9D0*((AS2/AG)**2-1D0)
46669 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46670 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46671 IF(F2.LT.F1) THEN
46672 X0=X1
46673 X1=X2
46674 X2=R*X1+C*X3
46675 F1=F2
46676 AS2=PYALPS(X2)
46677 CG=8D0/9D0*((AS2/AG)**2-1D0)
46678 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46679 ELSE
46680 X3=X2
46681 X2=X1
46682 X1=R*X2+C*X0
46683 F2=F1
46684 AS1=PYALPS(X1)
46685 CG=8D0/9D0*((AS1/AG)**2-1D0)
46686 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46687 ENDIF
46688 GOTO 100
46689 ENDIF
46690 IF(F1.LT.F2) THEN
46691 PYRNMQ=X1
46692 XMIN=X1
46693 ELSE
46694 PYRNMQ=X2
46695 XMIN=X2
46696 ENDIF
46697
46698 RETURN
46699 END
46700
46701C*********************************************************************
46702
46703C...PYTHRG
46704C...Calculates the mass eigenstates of the third generation sfermions.
46705C...Created: 5-31-96
46706
46707 SUBROUTINE PYTHRG
46708
46709C...Double precision and integer declarations.
46710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46711 IMPLICIT INTEGER(I-N)
46712 INTEGER PYK,PYCHGE,PYCOMP
46713C...Parameter statement to help give large particle numbers.
46714 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46715 &KEXCIT=4000000,KDIMEN=5000000)
46716C...Commonblocks.
46717 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46718 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46719 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46720 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46721 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46722 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46723
46724C...Local variables.
46725 DOUBLE PRECISION BETA
46726 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
46727 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
46728 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
46729 DOUBLE PRECISION ATR,AMQR,AMQL
46730 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
46731 INTEGER IF,I,J,II,JJ,IT,L
46732 LOGICAL DTERM
46733 DATA SMALL/1D-3/
46734 DATA ID1/10,10,13/
46735 DATA ID2/5,6,15/
46736 DATA ID3/15,16,17/
46737 DATA ID4/11,12,14/
46738 DATA DTERM/.TRUE./
46739
46740 XMZ2=PMAS(23,1)**2
46741 XMW2=PMAS(24,1)**2
46742 TANB=RMSS(5)
46743 XMU=-RMSS(4)
46744 BETA=ATAN(TANB)
46745 COS2B=COS(2D0*BETA)
46746
46747C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
46748
46749 IOPT=IMSS(5)
46750 IF(IOPT.EQ.1) THEN
46751 CTT=DCOS(RMSS(27))
46752 CTT2=CTT**2
46753 STT=DSIN(RMSS(27))
46754 STT2=STT**2
46755 XM12=RMSS(10)**2
46756 XM22=RMSS(12)**2
46757 XMQL2=CTT2*XM12+STT2*XM22
46758 XMQR2=STT2*XM12+CTT2*XM22
46759 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
46760 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46761 RMSS(16)=ATOP
46762C......SUBTRACT OUT D-TERM AND FERMION MASS
46763 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
46764 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
46765 IF(XMQL2.GE.0D0) THEN
46766 RMSS(10)=SQRT(XMQL2)
46767 ELSE
46768 RMSS(10)=-SQRT(-XMQL2)
46769 ENDIF
46770 IF(XMQR2.GE.0D0) THEN
46771 RMSS(12)=SQRT(XMQR2)
46772 ELSE
46773 RMSS(12)=-SQRT(-XMQR2)
46774 ENDIF
46775
46776C SAME FOR BOTTOM SQUARK
46777 CTT=DCOS(RMSS(26))
46778 CTT2=CTT**2
46779 STT=DSIN(RMSS(26))
46780 STT2=STT**2
46781 XM22=RMSS(11)**2
46782 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
46783 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
46784 IF(ABS(CTT).GE..9999D0) THEN
46785 ABOT=-XMU*TANB
46786 XMQR2=RMSS(11)**2
46787 ELSEIF(ABS(CTT).LE.1D-4) THEN
46788 ABOT=-XMU*TANB
46789 XMQR2=RMSS(11)**2
46790 ELSE
46791 XM12=(XMQL2-STT2*XM22)/CTT2
46792 XMQR2=STT2*XM12+CTT2*XM22
46793 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46794 ENDIF
46795 RMSS(15)=ABOT
46796C......SUBTRACT OUT D-TERM AND FERMION MASS
46797 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
46798 IF(XMQR2.GE.0D0) THEN
46799 RMSS(11)=SQRT(XMQR2)
46800 ELSE
46801 RMSS(11)=-SQRT(-XMQR2)
46802 ENDIF
46803C SAME FOR TAU SLEPTON
46804 CTT=DCOS(RMSS(28))
46805 CTT2=CTT**2
46806 STT=DSIN(RMSS(28))
46807 STT2=STT**2
46808 XM12=RMSS(13)**2
46809 XM22=RMSS(14)**2
46810 XMQL2=CTT2*XM12+STT2*XM22
46811 XMQR2=STT2*XM12+CTT2*XM22
46812 XMFR=PMAS(15,1)
46813 XMF2=XMFR**2
46814 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46815 RMSS(17)=ATAU
46816C......SUBTRACT OUT D-TERM AND FERMION MASS
46817 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
46818 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
46819 IF(XMQL2.GE.0D0) THEN
46820 RMSS(13)=SQRT(XMQL2)
46821 ELSE
46822 RMSS(13)=-SQRT(-XMQL2)
46823 ENDIF
46824 IF(XMQR2.GE.0D0) THEN
46825 RMSS(14)=SQRT(XMQR2)
46826 ELSE
46827 RMSS(14)=-SQRT(-XMQR2)
46828 ENDIF
46829 ENDIF
46830 DO 170 L=1,3
46831 AMQL=RMSS(ID1(L))
46832 IF(AMQL.LT.0D0) THEN
46833 XMQL2=-AMQL**2
46834 ELSE
46835 XMQL2=AMQL**2
46836 ENDIF
46837 ATR=RMSS(ID3(L))
46838 AMQR=RMSS(ID4(L))
46839 IF(AMQR.LT.0D0) THEN
46840 XMQR2=-AMQR**2
46841 ELSE
46842 XMQR2=AMQR**2
46843 ENDIF
46844 IF=ID2(L)
46845 XMF=PYMRUN(IF,PMAS(6,1)**2)
46846 XMF2=XMF**2
46847 AM2(1,1)=XMQL2+XMF2
46848 AM2(2,2)=XMQR2+XMF2
46849 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
46850 IF(DTERM) THEN
46851 IF(L.EQ.1) THEN
46852 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
46853 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
46854 AM2(1,2)=XMF*(ATR+XMU*TANB)
46855 ELSEIF(L.EQ.2) THEN
46856 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
46857 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
46858 AM2(1,2)=XMF*(ATR+XMU/TANB)
46859 ELSEIF(L.EQ.3) THEN
46860 IF(IMSS(8).EQ.1) THEN
46861 AM2(1,1)=RMSS(6)**2
46862 AM2(2,2)=RMSS(7)**2
46863 AM2(1,2)=0D0
46864 RMSS(13)=RMSS(6)
46865 RMSS(14)=RMSS(7)
46866 ELSE
46867 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
46868 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
46869 AM2(1,2)=XMF*(ATR+XMU*TANB)
46870 ENDIF
46871 ENDIF
46872 ENDIF
46873 AM2(2,1)=AM2(1,2)
46874 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
46875 IF(DETM.LT.0D0) THEN
46876 WRITE(MSTU(11),*) ID2(L),DETM,AM2
46877 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
46878 ENDIF
46879 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
46880 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
46881 XMF12=SAME-DIFF
46882 XMF22=SAME+DIFF
46883 IT=0
46884 IF(XMF22-XMF12.GT.0D0) THEN
46885 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
46886 RT(2,2) = RT(1,1)
46887 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
46888 & AM2(1,2)/(XMF22-XMF12))
46889 RT(2,1) = -RT(1,2)
46890 ELSE
46891 RT(1,1) = 1D0
46892 RT(2,2) = RT(1,1)
46893 RT(1,2) = 0D0
46894 RT(2,1) = -RT(1,2)
46895 ENDIF
46896 100 CONTINUE
46897 IT=IT+1
46898
46899 DO 140 I=1,2
46900 DO 130 JJ=1,2
46901 DI(I,JJ)=0D0
46902 DO 120 II=1,2
46903 DO 110 J=1,2
46904 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
46905 110 CONTINUE
46906 120 CONTINUE
46907 130 CONTINUE
46908 140 CONTINUE
46909
46910 IF(DI(1,1).GT.DI(2,2)) THEN
46911 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
46912 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
46913 WRITE(MSTU(11),*) AM2
46914 WRITE(MSTU(11),*) DI
46915 WRITE(MSTU(11),*) RT
46916 DI(1,1)=-RT(2,1)
46917 DI(2,2)=RT(1,2)
46918 DI(1,2)=-RT(2,2)
46919 DI(2,1)=RT(1,1)
46920 DO 160 I=1,2
46921 DO 150 J=1,2
46922 RT(I,J)=DI(I,J)
46923 150 CONTINUE
46924 160 CONTINUE
46925 GOTO 100
46926 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
46927 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46928 & ' OFF DIAGONAL ELEMENTS '
46929 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
46930 WRITE(MSTU(11),*) DI
46931 WRITE(MSTU(11),*) ' ROTATION = ',RT
46932C...STOP
46933 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
46934 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46935 & ' NEGATIVE MASSES '
46936 CALL PYSTOP(111)
46937 ENDIF
46938 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
46939 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
46940 SFMIX(IF,1)=RT(1,1)
46941 SFMIX(IF,2)=RT(1,2)
46942 SFMIX(IF,3)=RT(2,1)
46943 SFMIX(IF,4)=RT(2,2)
46944 170 CONTINUE
46945
46946C.....TAU SNEUTRINO MASS...L=3
46947
46948 XARG=AM2(1,1)+XMW2*COS2B
46949 IF(XARG.LT.0D0) THEN
46950 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
46951 & ' FROM THE SUM RULE. '
46952 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46953 RETURN
46954 ELSE
46955 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
46956 ENDIF
46957
46958 RETURN
46959 END
46960C*********************************************************************
46961
46962C...PYINOM
46963C...Finds the mass eigenstates and mixing matrices for neutralinos
46964C...and charginos.
46965
46966 SUBROUTINE PYINOM
46967
46968C...Double precision and integer declarations.
46969 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46970 IMPLICIT INTEGER(I-N)
46971 INTEGER PYCOMP
46972C...Parameter statement to help give large particle numbers.
46973 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46974 &KEXCIT=4000000,KDIMEN=5000000)
46975C...Commonblocks.
46976 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46977 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46978 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46979 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46980 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46981 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46982
46983C...Local variables.
46984 DOUBLE PRECISION XMW,XMZ,XM(4)
46985 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
46986 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
46987 DOUBLE PRECISION COSW,SINW
46988 DOUBLE PRECISION XMU
46989 DOUBLE PRECISION TANB,COSB,SINB
46990 DOUBLE PRECISION XM1,XM2,XM3,BETA
46991 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
46992 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
46993 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
46994 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
46995 DOUBLE PRECISION PYALPS,PYALEM
46996 DOUBLE PRECISION PYRNM3
46997 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
46998 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
46999 DATA KFNCHI/1000022,1000023,1000025,1000035/
47000
47001 IOPT=IMSS(2)
47002 IF(IMSS(1).EQ.2) THEN
47003 IOPT=1
47004 ENDIF
47005C...M1, M2, AND M3 ARE INDEPENDENT
47006 IF(IOPT.EQ.0) THEN
47007 XM1=RMSS(1)
47008 XM2=RMSS(2)
47009 XM3=RMSS(3)
47010 ELSEIF(IOPT.GE.1) THEN
47011 Q2=PMAS(23,1)**2
47012 AEM=PYALEM(Q2)
47013 A2=AEM/PARU(102)
47014 A1=AEM/(1D0-PARU(102))
47015 XM1=RMSS(1)
47016 XM2=RMSS(2)
47017 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47018 IF(IOPT.EQ.1) THEN
47019 XM2=XM1*A2/A1*3D0/5D0
47020 RMSS(2)=XM2
47021 ELSEIF(IOPT.EQ.3) THEN
47022 XM1=XM2*5D0/3D0*A1/A2
47023 RMSS(1)=XM1
47024 ENDIF
47025 XM3=PYRNM3(XM2/A2)
47026 RMSS(3)=XM3
47027 IF(XM3.LE.0D0) THEN
47028 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47029 CALL PYSTOP(105)
47030 ENDIF
47031 ENDIF
47032
47033C...GLUINO MASS
47034 IF(IMSS(3).EQ.1) THEN
47035 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
47036 ELSE
47037 AQ=0D0
47038 DO 110 I=1,4
47039 DO 100 ILR=1,2
47040 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47041 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
47042 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
47043 100 CONTINUE
47044 110 CONTINUE
47045
47046 DO 130 I=5,6
47047 DO 120 ILR=1,2
47048 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47049 RM2=PMAS(I,1)**2/XM3**2
47050 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
47051 IF(ARG.GE.0D0) THEN
47052 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
47053 AX0=ABS(X0)
47054 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
47055 AX1=ABS(X1)
47056 IF(X0.EQ.1D0) THEN
47057 AT=-1D0
47058 BT=0.25D0
47059 ELSEIF(X0.EQ.0D0) THEN
47060 AT=0D0
47061 BT=-0.25D0
47062 ELSE
47063 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
47064 & 0.5D0*X0**2*LOG(AX0)
47065 BT=(-1D0-2D0*X0)/4D0
47066 ENDIF
47067 IF(X1.EQ.1D0) THEN
47068 AT=-1D0+AT
47069 BT=0.25D0+BT
47070 ELSEIF(X1.EQ.0D0) THEN
47071 AT=0D0+AT
47072 BT=-0.25D0+BT
47073 ELSE
47074 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
47075 & X1**2*LOG(AX1)+AT
47076 BT=(-1D0-2D0*X1)/4D0+BT
47077 ENDIF
47078 AQ=AQ+AT+BT
47079 ELSE
47080 X0=0.5D0*(1D0+RM2-RM1)
47081 Y0=-0.5D0*SQRT(-ARG)
47082 AMGX0=SQRT(X0**2+Y0**2)
47083 AM1X0=SQRT((1D0-X0)**2+Y0**2)
47084 ARGX0=ATAN2(-X0,-Y0)
47085 AR1X0=ATAN2(1D0-X0,Y0)
47086 X1=X0
47087 Y1=-Y0
47088 AMGX1=AMGX0
47089 AM1X1=AM1X0
47090 ARGX1=ATAN2(-X1,-Y1)
47091 AR1X1=ATAN2(1D0-X1,Y1)
47092 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
47093 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
47094 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
47095 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
47096 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
47097 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
47098 AQ=AQ+AT+BT
47099 ENDIF
47100 120 CONTINUE
47101 130 CONTINUE
47102 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
47103 & /(2D0*PARU(2))*(15D0+AQ))
47104 ENDIF
47105
47106C...NEUTRALINO MASSES
47107 DO 150 I=1,4
47108 DO 140 J=1,4
47109 AI(I,J)=0D0
47110 140 CONTINUE
47111 150 CONTINUE
47112 XMZ=PMAS(23,1)/100D0
47113 XMW=PMAS(24,1)/100D0
47114 XMU=RMSS(4)/100D0
47115 SINW=SQRT(PARU(102))
47116 COSW=SQRT(1D0-PARU(102))
47117 TANB=RMSS(5)
47118 BETA=ATAN(TANB)
47119 COSB=COS(BETA)
47120 SINB=TANB*COSB
47121
47122 XM2=XM2/100D0
47123 XM1=XM1/100D0
47124
47125
47126C... Definitions:
47127C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47128C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47129 AR(1,1) = XM1*COS(RMSS(30))
47130 AI(1,1) = XM1*SIN(RMSS(30))
47131 AR(2,2) = XM2*COS(RMSS(31))
47132 AI(2,2) = XM2*SIN(RMSS(31))
47133 AR(3,3) = 0D0
47134 AR(4,4) = 0D0
47135 AR(1,2) = 0D0
47136 AR(2,1) = 0D0
47137 AR(1,3) = -XMZ*SINW*COSB
47138 AR(3,1) = AR(1,3)
47139 AR(1,4) = XMZ*SINW*SINB
47140 AR(4,1) = AR(1,4)
47141 AR(2,3) = XMZ*COSW*COSB
47142 AR(3,2) = AR(2,3)
47143 AR(2,4) = -XMZ*COSW*SINB
47144 AR(4,2) = AR(2,4)
47145 AR(3,4) = -XMU*COS(RMSS(33))
47146 AI(3,4) = -XMU*SIN(RMSS(33))
47147 AR(4,3) = -XMU*COS(RMSS(33))
47148 AI(4,3) = -XMU*SIN(RMSS(33))
47149C CALL PYEIG4(AR,WR,ZR)
47150 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47151 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47152 & 'PROBLEM WITH PYEICG IN PYINOM ')
47153 DO 160 I=1,4
47154 INDEX(I)=I
47155 XM(I)=ABS(WR(I))
47156 160 CONTINUE
47157 DO 180 I=2,4
47158 K=I
47159 DO 170 J=I-1,1,-1
47160 IF(XM(K).LT.XM(J)) THEN
47161 ITMP=INDEX(J)
47162 XTMP=XM(J)
47163 INDEX(J)=INDEX(K)
47164 XM(J)=XM(K)
47165 INDEX(K)=ITMP
47166 XM(K)=XTMP
47167 K=K-1
47168 ELSE
47169 GOTO 180
47170 ENDIF
47171 170 CONTINUE
47172 180 CONTINUE
47173
47174
47175 DO 210 I=1,4
47176 K=INDEX(I)
47177 SMZ(I)=WR(K)*100D0
47178 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
47179 S=0D0
47180 DO 190 J=1,4
47181 S=S+ZR(J,K)**2+ZI(J,K)**2
47182 190 CONTINUE
47183 DO 200 J=1,4
47184 ZMIX(I,J)=ZR(J,K)/SQRT(S)
47185 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
47186 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
47187 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
47188 200 CONTINUE
47189 210 CONTINUE
47190
47191C...CHARGINO MASSES
47192C.....Find eigenvectors of X X^*
47193 DO I=1,4
47194 DO J=1,4
47195 AR(I,J)=0D0
47196 AI(I,J)=0D0
47197 ENDDO
47198 ENDDO
47199 AI(1,1) = 0D0
47200 AI(2,2) = 0D0
47201 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
47202 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
47203 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47204 &XMU*COS(RMSS(33))*SINB)
47205 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
47206 &XMU*SIN(RMSS(33))*SINB)
47207 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47208 &XMU*COS(RMSS(33))*SINB)
47209 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
47210 &XMU*SIN(RMSS(33))*SINB)
47211 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47212 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47213 & 'PROBLEM WITH PYEICG IN PYINOM ')
47214 INDEX(1)=1
47215 INDEX(2)=2
47216 IF(WR(2).LT.WR(1)) THEN
47217 INDEX(1)=2
47218 INDEX(2)=1
47219 ENDIF
47220
47221
47222 DO 240 I=1,2
47223 K=INDEX(I)
47224 SMW(I)=SQRT(WR(K))*100D0
47225 S=0D0
47226 DO 220 J=1,2
47227 S=S+ZR(J,K)**2+ZI(J,K)**2
47228 220 CONTINUE
47229 DO 230 J=1,2
47230 UMIX(I,J)=ZR(J,K)/SQRT(S)
47231 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
47232 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
47233 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
47234 230 CONTINUE
47235 240 CONTINUE
47236C...Force chargino mass > neutralino mass
47237 IFRC=0
47238 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
47239 CALL PYERRM(18,'(PYINOM:) '//
47240 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
47241 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
47242 IFRC=1
47243 ENDIF
47244 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
47245 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
47246
47247C.....Find eigenvectors of X^* X
47248 DO I=1,4
47249 DO J=1,4
47250 AR(I,J)=0D0
47251 AI(I,J)=0D0
47252 ZR(I,J)=0D0
47253 ZI(I,J)=0D0
47254 ENDDO
47255 ENDDO
47256 AI(1,1) = 0D0
47257 AI(2,2) = 0D0
47258 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
47259 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
47260 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47261 &XMU*COS(RMSS(33))*COSB)
47262 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
47263 &XMU*SIN(RMSS(33))*COSB)
47264 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47265 &XMU*COS(RMSS(33))*COSB)
47266 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
47267 &XMU*SIN(RMSS(33))*COSB)
47268 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47269 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47270 & 'PROBLEM WITH PYEICG IN PYINOM ')
47271 INDEX(1)=1
47272 INDEX(2)=2
47273 IF(WR(2).LT.WR(1)) THEN
47274 INDEX(1)=2
47275 INDEX(2)=1
47276 ENDIF
47277
47278 SIMAG=0D0
47279 DO 270 I=1,2
47280 K=INDEX(I)
47281 S=0D0
47282 DO 250 J=1,2
47283 S=S+ZR(J,K)**2+ZI(J,K)**2
47284 SIMAG=SIMAG+ZI(J,K)**2
47285 250 CONTINUE
47286 DO 260 J=1,2
47287 VMIX(I,J)=ZR(J,K)/SQRT(S)
47288 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
47289 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
47290 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
47291 260 CONTINUE
47292 270 CONTINUE
47293
47294C.....Simplify if no phases
47295 IF(SIMAG.LT.1D-6) THEN
47296 AR(1,1) = XM2*COS(RMSS(31))
47297 AR(2,2) = XMU*COS(RMSS(33))
47298 AR(1,2) = SQRT(2D0)*XMW*SINB
47299 AR(2,1) = SQRT(2D0)*XMW*COSB
47300 IKNT=0
47301 300 CONTINUE
47302 DO I=1,2
47303 DO J=1,2
47304 ZR(I,J)=0D0
47305 ENDDO
47306 ENDDO
47307
47308 DO I=1,2
47309 DO J=1,2
47310 DO K=1,2
47311 DO L=1,2
47312 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
47313 ENDDO
47314 ENDDO
47315 ENDDO
47316 ENDDO
47317 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
47318 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
47319 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
47320 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
47321 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47322 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47323 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
47324 IKNT=IKNT+1
47325 GOTO 300
47326 ENDIF
47327C.....Must deal with phases
47328 ELSE
47329 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
47330 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
47331 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
47332 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
47333
47334 IKNT=0
47335 310 CONTINUE
47336 DO I=1,2
47337 DO J=1,2
47338 CAI(I,J)=CMPLX(0D0,0D0)
47339 ENDDO
47340 ENDDO
47341
47342 DO I=1,2
47343 DO J=1,2
47344 DO K=1,2
47345 DO L=1,2
47346 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
47347 & CMPLX(VMIX(J,L),VMIXI(J,L))
47348 ENDDO
47349 ENDDO
47350 ENDDO
47351 ENDDO
47352
47353 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
47354 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
47355 TEMPR=VMIX(1,1)
47356 TEMPI=VMIXI(1,1)
47357 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47358 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47359 TEMPR=VMIX(1,2)
47360 TEMPI=VMIXI(1,2)
47361 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47362 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47363 TEMPR=VMIX(2,1)
47364 TEMPI=VMIXI(2,1)
47365 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47366 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47367 TEMPR=VMIX(2,2)
47368 TEMPI=VMIXI(2,2)
47369 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47370 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47371 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47372 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47373 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
47374 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
47375 IKNT=IKNT+1
47376 GOTO 310
47377 ENDIF
47378 ENDIF
47379 RETURN
47380 END
47381
47382C*********************************************************************
47383
47384C...PYRNM3
47385C...Calculates the running of M3, the SU(3) gluino mass parameter.
47386
47387 FUNCTION PYRNM3(RGUT)
47388
47389C...Double precision and integer declarations.
47390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47391 IMPLICIT INTEGER(I-N)
47392 INTEGER PYK,PYCHGE,PYCOMP
47393
47394C...Local variables.
47395 DOUBLE PRECISION R
47396 DOUBLE PRECISION TOL
47397 EXTERNAL PYALPS
47398 DOUBLE PRECISION PYALPS
47399 DATA TOL/0.001D0/
47400 DATA R/0.61803399D0/
47401
47402 C=1D0-R
47403
47404 BX=RGUT*PYALPS(RGUT**2)
47405 AX=MIN(50D0,BX*0.5D0)
47406 CX=MAX(2000D0,2D0*BX)
47407
47408 X0=AX
47409 X3=CX
47410 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47411 X1=BX
47412 X2=BX+C*(CX-BX)
47413 ELSE
47414 X2=BX
47415 X1=BX-C*(BX-AX)
47416 ENDIF
47417 AS1=PYALPS(X1**2)
47418 F1=ABS(X1-RGUT*AS1)
47419 AS2=PYALPS(X2**2)
47420 F2=ABS(X2-RGUT*AS2)
47421 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47422 IF(F2.LT.F1) THEN
47423 X0=X1
47424 X1=X2
47425 X2=R*X1+C*X3
47426 F1=F2
47427 AS2=PYALPS(X2**2)
47428 F2=ABS(X2-RGUT*AS2)
47429 ELSE
47430 X3=X2
47431 X2=X1
47432 X1=R*X2+C*X0
47433 F2=F1
47434 AS1=PYALPS(X1**2)
47435 F1=ABS(X1-RGUT*AS1)
47436 ENDIF
47437 GOTO 100
47438 ENDIF
47439 IF(F1.LT.F2) THEN
47440 PYRNM3=X1
47441 XMIN=X1
47442 ELSE
47443 PYRNM3=X2
47444 XMIN=X2
47445 ENDIF
47446
47447 RETURN
47448 END
47449
47450C*********************************************************************
47451
47452C...PYEIG4
47453C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
47454C...Specific application: mixing in neutralino sector.
47455
47456 SUBROUTINE PYEIG4(A,W,Z)
47457
47458C...Double precision and integer declarations.
47459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47460 IMPLICIT INTEGER(I-N)
47461 INTEGER PYK,PYCHGE,PYCOMP
47462
47463C...Arrays: in call and local.
47464 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
47465
47466C...Coefficients of fourth-degree equation from matrix.
47467C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
47468 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
47469 B2=0D0
47470 DO 110 I=1,3
47471 DO 100 J=I+1,4
47472 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
47473 100 CONTINUE
47474 110 CONTINUE
47475 B1=0D0
47476 B0=0D0
47477 DO 120 I=1,4
47478 I1=MOD(I,4)+1
47479 I2=MOD(I+1,4)+1
47480 I3=MOD(I+2,4)+1
47481 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
47482 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
47483 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
47484 B0=B0+(-1D0)**(I+1)*A(1,I)*(
47485 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
47486 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
47487 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
47488 120 CONTINUE
47489
47490C...Coefficients of third-degree equation needed for
47491C...separation into two second-degree equations.
47492C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
47493 C2=-B2
47494 C1=B1*B3-4D0*B0
47495 C0=-B1**2-B0*B3**2+4D0*B0*B2
47496 CQ=C1/3D0-C2**2/9D0
47497 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
47498 CQR=CQ**3+CR**2
47499
47500C...Cases with one or three real roots.
47501 IF(CQR.GE.0D0) THEN
47502 S1=(CR+SQRT(CQR))**(1D0/3D0)
47503 S2=(CR-SQRT(CQR))**(1D0/3D0)
47504 U=S1+S2-C2/3D0
47505 ELSE
47506 SABS=SQRT(-CQ)
47507 THE=ACOS(CR/SABS**3)/3D0
47508 SRE=SABS*COS(THE)
47509 U=2D0*SRE-C2/3D0
47510 ENDIF
47511
47512C...Find and solve two second-degree equations.
47513 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
47514 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
47515 Q1=U/2D0+SQRT(U**2/4D0-B0)
47516 Q2=U/2D0-SQRT(U**2/4D0-B0)
47517 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
47518 QSAV=Q1
47519 Q1=Q2
47520 Q2=QSAV
47521 ENDIF
47522 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
47523 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
47524 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
47525 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
47526
47527C...Order eigenvalues in asceding mass.
47528 W(1)=X(1)
47529 DO 150 I1=2,4
47530 DO 130 I2=I1-1,1,-1
47531 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
47532 W(I2+1)=W(I2)
47533 130 CONTINUE
47534 140 W(I2+1)=X(I1)
47535 150 CONTINUE
47536
47537C...Find equation system for eigenvectors.
47538 DO 250 I=1,4
47539 DO 170 J1=1,4
47540 D(J1,J1)=A(J1,J1)-W(I)
47541 DO 160 J2=J1+1,4
47542 D(J1,J2)=A(J1,J2)
47543 D(J2,J1)=A(J2,J1)
47544 160 CONTINUE
47545 170 CONTINUE
47546
47547C...Find largest element in matrix.
47548 DAMAX=0D0
47549 DO 190 J1=1,4
47550 DO 180 J2=1,4
47551 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
47552 JA=J1
47553 JB=J2
47554 DAMAX=ABS(D(J1,J2))
47555 180 CONTINUE
47556 190 CONTINUE
47557
47558C...Subtract others by multiple of row selected above.
47559 DAMAX=0D0
47560 DO 210 J3=JA+1,JA+3
47561 J1=J3-4*((J3-1)/4)
47562 RL=D(J1,JB)/D(JA,JB)
47563 DO 200 J2=1,4
47564 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
47565 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
47566 JC=J1
47567 JD=J2
47568 DAMAX=ABS(D(J1,J2))
47569 200 CONTINUE
47570 210 CONTINUE
47571
47572C...Do one more subtraction of a row.
47573 DAMAX=0D0
47574 DO 230 J3=JC+1,JC+3
47575 J1=J3-4*((J3-1)/4)
47576 IF(J1.EQ.JA) GOTO 230
47577 RL=D(J1,JD)/D(JC,JD)
47578 DO 220 J2=1,4
47579 IF(J2.EQ.JB) GOTO 220
47580 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
47581 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
47582 JE=J1
47583 DAMAX=ABS(D(J1,J2))
47584 220 CONTINUE
47585 230 CONTINUE
47586
47587C...Construct unnormalized eigenvector.
47588 JF1=JD+1-4*(JD/4)
47589 JF2=JD+2-4*((JD+1)/4)
47590 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
47591 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
47592 E(JF1)=-D(JE,JF2)
47593 E(JF2)=D(JE,JF1)
47594 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
47595 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
47596 & D(JA,JB)
47597
47598C...Normalize and fill in final array.
47599 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
47600 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47601 DO 240 J=1,4
47602 Z(I,J)=SGN*E(J)/EA
47603 240 CONTINUE
47604 250 CONTINUE
47605
47606 RETURN
47607 END
47608
47609C*********************************************************************
47610
47611C...PYHGGM
47612C...Determines the Higgs boson mass spectrum using several inputs.
47613
47614 SUBROUTINE PYHGGM(ALPHA)
47615
47616C...Double precision and integer declarations.
47617 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47618 IMPLICIT INTEGER(I-N)
47619 INTEGER PYK,PYCHGE,PYCOMP
47620C...Parameter statement to help give large particle numbers.
47621 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47622 &KEXCIT=4000000,KDIMEN=5000000)
47623C...Commonblocks.
47624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47625 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47626 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47627 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47628 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
47629
47630C...Local variables.
47631 DOUBLE PRECISION AT,AB,XMU,TANB
47632 DOUBLE PRECISION ALPHA
47633 INTEGER IHOPT
47634 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
47635 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
47636 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
47637 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
47638
47639 IHOPT=IMSS(4)
47640 IF(IHOPT.EQ.2) THEN
47641 ALPHA=RMSS(18)
47642 RETURN
47643 ENDIF
47644 AT=RMSS(16)
47645 AB=RMSS(15)
47646 DMGL=RMSS(3)
47647 XMU=RMSS(4)
47648 TANB=RMSS(5)
47649
47650 DMA=RMSS(19)
47651 DTANB=TANB
47652 DMQ=RMSS(10)
47653 DMUR=RMSS(12)
47654 DMDR=RMSS(11)
47655 DMTOP=PMAS(6,1)
47656 DMC=PMAS(PYCOMP(KSUSY1+37),1)
47657 DAU=AT
47658 DAD=AB
47659 DMU=XMU
47660 RMSS(40)=0D0
47661 RMSS(41)=0D0
47662
47663 IF(IHOPT.EQ.0) THEN
47664 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47665 & DMHCH,DSA,DCA,DTANBA)
47666 ELSEIF(IHOPT.EQ.1) THEN
47667 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47668 & DMHCH,DSA,DCA,DTANBA)
47669 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
47670 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
47671 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
47672 RMSS(40)=DDT
47673 RMSS(41)=DDB
47674 DMH=DMHP
47675 DHM=DHMP
47676 DMA=DAMP
47677 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
47678 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
47679 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
47680 & PMAS(PYCOMP(1000006),1),DSTOP2
47681 ENDIF
47682 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
47683 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
47684 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
47685 & PMAS(PYCOMP(2000006),1),DSTOP1
47686 ENDIF
47687 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
47688 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
47689 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
47690 & PMAS(PYCOMP(1000005),1),DSBOT2
47691 ENDIF
47692 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
47693 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
47694 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
47695 & PMAS(PYCOMP(2000005),1),DSBOT1
47696 ENDIF
47697
47698 ELSEIF (IHOPT.EQ.3) THEN
47699c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
47700C...Currently only available for SLHA spectrum read-in.
47701 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
47702 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
47703 & //' spectrum, change IMSS(1) or IMSS(4) option.')
47704 ENDIF
47705 ALPHA=RMSS(18)
47706 RETURN
47707 ENDIF
47708
47709 ALPHA=ACOS(DCA)
47710
47711 PMAS(25,1)=DMH
47712 PMAS(35,1)=DHM
47713 PMAS(36,1)=DMA
47714 PMAS(37,1)=DMHCH
47715
47716 RETURN
47717 END
47718
47719C*********************************************************************
47720
47721C...PYSUBH
47722C...This routine computes the renormalization group improved
47723C...values of Higgs masses and couplings in the MSSM.
47724
47725C...Program based on the work by M. Carena, J.R. Espinosa,
47726c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
47727
47728C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
47729C...All masses in GeV units. MA is the CP-odd Higgs mass,
47730C...MTOP is the physical top mass, MQ and MUR are the soft
47731C...supersymmetry breaking mass parameters of left handed
47732C...and right handed stops respectively, AU and AD are the
47733C...stop and sbottom trilinear soft breaking terms,
47734C...respectively, and MU is the supersymmetric
47735C...Higgs mass parameter. We use the conventions from
47736C...the physics report of Haber and Kane: left right
47737C...stop mixing term proportional to (AU - MU/TANB)
47738C...We use as input TANB defined at the scale MTOP
47739
47740C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
47741C...where MH and HM are the lightest and heaviest CP-even
47742C...Higgs masses, MHCH is the charged Higgs mass and
47743C...ALPHA is the Higgs mixing angle
47744C...TANBA is the angle TANB at the CP-odd Higgs mass scale
47745
47746C...Range of validity:
47747C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
47748C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
47749C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
47750C...are the sbottom mass eigenvalues, respectively. This
47751C...range automatically excludes the existence of tachyons.
47752C...For the charged Higgs mass computation, the method is
47753C...valid if
47754C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
47755C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
47756C...where M_SUSY**2 is the average of the squared stop mass
47757C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
47758C...masses have been assumed to be of order of the stop ones
47759C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
47760
47761 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
47762 &XMHCH,SA,CA,TANBA)
47763
47764C...Double precision and integer declarations.
47765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47766 IMPLICIT INTEGER(I-N)
47767 INTEGER PYK,PYCHGE,PYCOMP
47768C...Parameter statement to help give large particle numbers.
47769 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47770 &KEXCIT=4000000,KDIMEN=5000000)
47771C...Commonblocks.
47772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47774 COMMON/PYHTRI/HHH(7)
47775 SAVE /PYDAT1/,/PYDAT2/
47776
47777C...Local variables.
47778 DOUBLE PRECISION PYALEM,PYALPS
47779 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
47780 DOUBLE PRECISION XMHCH,SA,CA
47781 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
47782 DOUBLE PRECISION Q02
47783 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
47784 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
47785 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
47786 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
47787 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
47788 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
47789 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
47790 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
47791
47792 XMZ = PMAS(23,1)
47793 Q02=XMZ**2
47794 AEM=PYALEM(Q02)
47795 ALP1=AEM/(1D0-PARU(102))
47796 ALP2=AEM/PARU(102)
47797 ALPH3Z=PYALPS(Q02)
47798
47799 ALP1 = 0.0101D0
47800 ALP2 = 0.0337D0
47801 ALPH3Z = 0.12D0
47802
47803 V = 174.1D0
47804 PI = PARU(1)
47805 TANBA = TANB
47806 TANBT = TANB
47807
47808C...MBOTTOM(MTOP) = 3. GEV
47809 XMB = PYMRUN(5,XMTOP**2)
47810 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
47811 &LOG(XMTOP**2/XMZ**2))
47812
47813C...RMTOP= RUNNING TOP QUARK MASS
47814 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
47815 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
47816 T = LOG(XMS**2/XMTOP**2)
47817 SINB = TANB/((1D0 + TANB**2)**0.5D0)
47818 COSB = SINB/TANB
47819C...IF(MA.LE.XMTOP) TANBA = TANBT
47820 IF(XMA.GT.XMTOP)
47821 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
47822 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
47823 &LOG(XMA**2/XMTOP**2))
47824
47825 SINBT = TANBT/SQRT(1D0 + TANBT**2)
47826 COSBT = 1D0/SQRT(1D0 + TANBT**2)
47827C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
47828 G1 = SQRT(ALP1*4D0*PI)
47829 G2 = SQRT(ALP2*4D0*PI)
47830 G3 = SQRT(ALP3*4D0*PI)
47831 HU = RMTOP/V/SINBT
47832 HD = XMB/V/COSBT
47833 HU2=HU*HU
47834 HD2=HD*HD
47835 HU4=HU2*HU2
47836 HD4=HD2*HD2
47837 AU2=AU**2
47838 AD2=AD**2
47839 XMS2=XMS**2
47840 XMS3=XMS**3
47841 XMS4=XMS2*XMS2
47842 XMU2=XMU*XMU
47843 PI2=PI*PI
47844
47845 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
47846 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
47847 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
47848 &+ 3D0*(AU + AD)**2/XMS2)/6D0
47849 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
47850 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
47851 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
47852 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
47853 &- 16D0*G3**2) *T/16D0/PI2)
47854 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
47855 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
47856 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
47857 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
47858 &- 16D0*G3**2) *T/16D0/PI2)
47859 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47860 &(HU2 + HD2)*T/16D0/PI2)
47861 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47862 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47863 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47864 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
47865 &- 16D0*G3**2) *T/16D0/PI2)
47866 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47867 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
47868 &- 16D0*G3**2) *T/16D0/PI2)
47869 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
47870 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47871 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47872 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47873 &XMS4)*
47874 &(1+ (6D0*HU2 -2D0* HD2
47875 &- 16D0*G3**2) *T/16D0/PI2)
47876 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47877 &XMS4)*
47878 &(1+ (6D0*HD2 -2D0* HU2/2D0
47879 &- 16D0*G3**2) *T/16D0/PI2)
47880 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
47881 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
47882 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
47883 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
47884 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
47885 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47886 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
47887 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47888 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
47889 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47890 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
47891 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47892 HHH(1)=XLAM1
47893 HHH(2)=XLAM2
47894 HHH(3)=XLAM3
47895 HHH(4)=XLAM4
47896 HHH(5)=XLAM5
47897 HHH(6)=XLAM6
47898 HHH(7)=XLAM7
47899 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
47900 &2D0* XLAM6*SINBT*COSBT
47901 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
47902 &+ XLAM5*COSBT**2)
47903 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
47904 &XLAM6*COSBT**2
47905 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
47906 &2D0* XLAM6* COSBT*SINBT
47907 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47908 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
47909 &((XLAM1* COSBT**2 +2D0*
47910 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
47911 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
47912 &*SINBT**2
47913 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
47914 &+ XLAM4) + XLAM6*COSBT**2
47915 &+ XLAM7* SINBT**2))
47916
47917 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
47918 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
47919 XHM = SQRT(XHM2)
47920 XMH = SQRT(XMH2)
47921 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
47922 XMHCH = SQRT(XMHCH2)
47923
47924 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47925 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47926 &XLAM6* COSBT*SINBT
47927 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47928 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47929 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
47930 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
47931
47932 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
47933 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
47934 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
47935 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
47936 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47937 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47938 &XLAM6* COSBT*SINBT
47939 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47940 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47941 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
47942
47943 SA = -SINALP
47944 CA = -COSALP
47945
47946 100 CONTINUE
47947
47948 RETURN
47949 END
47950
47951C*********************************************************************
47952
47953C...PYPOLE
47954C...This subroutine computes the CP-even higgs and CP-odd pole
47955c...Higgs masses and mixing angles.
47956
47957C...Program based on the work by M. Carena, M. Quiros
47958C...and C.E.M. Wagner, "Effective potential methods and
47959C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
47960
47961C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
47962C...AT,AB,MU
47963C...where MCHI is the largest chargino mass, MA is the running
47964C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
47965C...expectaion values at the scale MTOP, MQ is the third generation
47966C...left handed squark mass parameter, MUR is the third generation
47967C...right handed stop mass parameter, MDR is the third generation
47968C...right handed sbottom mass parameter, MTOP is the pole top quark
47969C...mass; AT,AB are the soft supersymmetry breaking trilinear
47970C...couplings of the stop and sbottoms, respectively, and MU is the
47971C...supersymmetric mass parameter
47972
47973C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
47974C...Higgses whose pole mass is computed. If IHIGGS=0 only running
47975C...masses are given, what makes the running of the program
47976c...much faster and it is quite generally a good approximation
47977c...(for a theoretical discussion see ref. above). If IHIGGS=1,
47978C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
47979c...and if IHIGGS=3, then h,H,A polarizations are computed
47980
47981C...Output: MH and MHP which are the lightest CP-even Higgs running
47982C...and pole masses, respectively; HM and HMP are the heaviest CP-even
47983C...Higgs running and pole masses, repectively; SA and CA are the
47984C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
47985C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
47986C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
47987C...the value of TANB at the CP-odd Higgs mass scale
47988
47989C...This subroutine makes use of CERN library subroutine
47990C...integration package, which makes the computation of the
47991C...pole Higgs masses somewhat faster. We thank P. Janot for this
47992C...improvement. Those who are not able to call the CERN
47993C...libraries, please use the subroutine SUBHPOLE2.F, which
47994C...although somewhat slower, gives identical results
47995
47996 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
47997 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
47998
47999C...Double precision and integer declarations.
48000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48001 IMPLICIT INTEGER(I-N)
48002
48003C...Parameters.
48004 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48005 SAVE /PYDAT1/
48006 INTEGER PYK,PYCHGE,PYCOMP
48007
48008C...Local variables.
48009 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48010 &SSBOT2(2),B(2,2),COUPB(2,2),
48011 &HCOUPT(2,2),HCOUPB(2,2),
48012 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48013
48014 DELTA(1,1) = 1D0
48015 DELTA(2,2) = 1D0
48016 DELTA(1,2) = 0D0
48017 DELTA(2,1) = 0D0
48018 V = 174.1D0
48019 XMZ=91.18D0
48020 PI=PARU(1)
48021 RXMT=PYMRUN(6,XMT**2)
48022 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48023 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48024
48025 SINB = TANB/(TANB**2+1D0)**0.5D0
48026 COSB = 1D0/(TANB**2+1D0)**0.5D0
48027 COS2B = SINB**2 - COSB**2
48028 SINBPA = SINB*CA + COSB*SA
48029 COSBPA = COSB*CA - SINB*SA
48030 RMBOT = PYMRUN(5,XMT**2)
48031 XMQ2 = XMQ**2
48032 XMUR2 = XMUR**2
48033 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48034 XMDR2 = XMDR**2
48035 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48036 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48037 IF(XMST11.LT.0D0) GOTO 500
48038 IF(XMST22.LT.0D0) GOTO 500
48039 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
48040 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
48041 IF(XMSB11.LT.0D0) GOTO 500
48042 IF(XMSB22.LT.0D0) GOTO 500
48043C WMST11 = RXMT**2 + XMQ2
48044C WMST22 = RXMT**2 + XMUR2
48045 XMST12 = RXMT*(AT - XMU/TANB)
48046 XMSB12 = RMBOT*(AB - XMU*TANB)
48047
48048CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48049C...STOP EIGENVALUES CALCULATION
48050CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48051
48052 STOP12 = 0.5D0*(XMST11+XMST22) +
48053 &0.5D0*((XMST11+XMST22)**2 -
48054 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
48055 STOP22 = 0.5D0*(XMST11+XMST22) -
48056 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
48057 &XMST12**2))**0.5D0
48058
48059 IF(STOP22.LT.0D0) GOTO 500
48060 SSTOP2(1) = STOP12
48061 SSTOP2(2) = STOP22
48062 STOP1 = STOP12**0.5D0
48063 STOP2 = STOP22**0.5D0
48064C STOP1W = STOP1
48065C STOP2W = STOP2
48066
48067 IF(XMST12.EQ.0D0) XST11 = 1D0
48068 IF(XMST12.EQ.0D0) XST12 = 0D0
48069 IF(XMST12.EQ.0D0) XST21 = 0D0
48070 IF(XMST12.EQ.0D0) XST22 = 1D0
48071
48072 IF(XMST12.EQ.0D0) GOTO 110
48073
48074 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48075 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48076 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48077 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48078
48079 110 T(1,1) = XST11
48080 T(2,2) = XST22
48081 T(1,2) = XST12
48082 T(2,1) = XST21
48083
48084 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
48085 &0.5D0*((XMSB11+XMSB22)**2 -
48086 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
48087 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
48088 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
48089 &XMSB12**2))**0.5D0
48090 IF(SBOT22.LT.0D0) GOTO 500
48091 SBOT1 = SBOT12**0.5D0
48092 SBOT2 = SBOT22**0.5D0
48093
48094 SSBOT2(1) = SBOT12
48095 SSBOT2(2) = SBOT22
48096
48097 IF(XMSB12.EQ.0D0) XSB11 = 1D0
48098 IF(XMSB12.EQ.0D0) XSB12 = 0D0
48099 IF(XMSB12.EQ.0D0) XSB21 = 0D0
48100 IF(XMSB12.EQ.0D0) XSB22 = 1D0
48101
48102 IF(XMSB12.EQ.0D0) GOTO 130
48103
48104 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48105 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48106 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48107 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48108
48109 130 B(1,1) = XSB11
48110 B(2,2) = XSB22
48111 B(1,2) = XSB12
48112 B(2,1) = XSB21
48113
48114
48115 SINT = 0.2320D0
48116 SQR = DSQRT(2D0)
48117 VP = 174.1D0*SQR
48118
48119CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48120C...STARTING OF LIGHT HIGGS
48121CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48122
48123 IF(IHIGGS.EQ.0) GOTO 490
48124
48125 DO 150 I = 1,2
48126 DO 140 J = 1,2
48127 COUPT(I,J) =
48128 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
48129 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48130 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
48131 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
48132 & T(1,J)*T(2,I))
48133 140 CONTINUE
48134 150 CONTINUE
48135
48136
48137 DO 170 I = 1,2
48138 DO 160 J = 1,2
48139 COUPB(I,J) =
48140 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
48141 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48142 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
48143 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
48144 & B(1,J)*B(2,I))
48145 160 CONTINUE
48146 170 CONTINUE
48147
48148 PRUN = XMH
48149 EPS = 1D-4*PRUN
48150 ITER = 0
48151 180 ITER = ITER + 1
48152 DO 230 I3 = 1,3
48153
48154 PR(I3)=PRUN+(I3-2)*EPS/2
48155 P2=PR(I3)**2
48156 POLT = 0D0
48157 DO 200 I = 1,2
48158 DO 190 J = 1,2
48159 POLT = POLT + COUPT(I,J)**2*3D0*
48160 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48161 190 CONTINUE
48162 200 CONTINUE
48163
48164 POLB = 0D0
48165 DO 220 I = 1,2
48166 DO 210 J = 1,2
48167 POLB = POLB + COUPB(I,J)**2*3D0*
48168 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48169 210 CONTINUE
48170 220 CONTINUE
48171C RXMT2 = RXMT**2
48172 XMT2=XMT**2
48173
48174 POLTT =
48175 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48176 & CA**2/SINB**2 *
48177 & (-2D0*XMT**2+0.5D0*P2)*
48178 & PYFINT(P2,XMT2,XMT2)
48179
48180 POL = POLT + POLB + POLTT
48181 POLAR(I3) = P2 - XMH**2 - POL
48182 230 CONTINUE
48183 DERIV = (POLAR(3)-POLAR(1))/EPS
48184 DRUN = - POLAR(2)/DERIV
48185 PRUN = PRUN + DRUN
48186 P2 = PRUN**2
48187 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
48188 GOTO 180
48189 240 CONTINUE
48190
48191 XMHP = DSQRT(P2)
48192
48193CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48194C...END OF LIGHT HIGGS
48195CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48196
48197 250 IF(IHIGGS.EQ.1) GOTO 490
48198
48199CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48200C... STARTING OF HEAVY HIGGS
48201CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48202
48203 DO 270 I = 1,2
48204 DO 260 J = 1,2
48205 HCOUPT(I,J) =
48206 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
48207 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48208 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
48209 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
48210 & T(1,J)*T(2,I))
48211 260 CONTINUE
48212 270 CONTINUE
48213
48214 DO 290 I = 1,2
48215 DO 280 J = 1,2
48216 HCOUPB(I,J) =
48217 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
48218 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48219 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
48220 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
48221 & B(1,J)*B(2,I))
48222 HCOUPB(I,J)=0D0
48223 280 CONTINUE
48224 290 CONTINUE
48225
48226 PRUN = HM
48227 EPS = 1D-4*PRUN
48228 ITER = 0
48229 300 ITER = ITER + 1
48230 DO 350 I3 = 1,3
48231 PR(I3)=PRUN+(I3-2)*EPS/2
48232 HP2=PR(I3)**2
48233
48234 HPOLT = 0D0
48235 DO 320 I = 1,2
48236 DO 310 J = 1,2
48237 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
48238 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48239 310 CONTINUE
48240 320 CONTINUE
48241
48242 HPOLB = 0D0
48243 DO 340 I = 1,2
48244 DO 330 J = 1,2
48245 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
48246 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48247 330 CONTINUE
48248 340 CONTINUE
48249
48250C RXMT2 = RXMT**2
48251 XMT2 = XMT**2
48252
48253 HPOLTT =
48254 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48255 & SA**2/SINB**2 *
48256 & (-2D0*XMT**2+0.5D0*HP2)*
48257 & PYFINT(HP2,XMT2,XMT2)
48258
48259 HPOL = HPOLT + HPOLB + HPOLTT
48260 POLAR(I3) =HP2-HM**2-HPOL
48261 350 CONTINUE
48262 DERIV = (POLAR(3)-POLAR(1))/EPS
48263 DRUN = - POLAR(2)/DERIV
48264 PRUN = PRUN + DRUN
48265 HP2 = PRUN**2
48266 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
48267 GOTO 300
48268 360 CONTINUE
48269
48270
48271 370 CONTINUE
48272 HMP = HP2**0.5D0
48273
48274CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48275C... END OF HEAVY HIGGS
48276CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48277
48278 IF(IHIGGS.EQ.2) GOTO 490
48279
48280CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48281C...BEGINNING OF PSEUDOSCALAR HIGGS
48282CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48283
48284 DO 390 I = 1,2
48285 DO 380 J = 1,2
48286 ACOUPT(I,J) =
48287 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
48288 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
48289 380 CONTINUE
48290 390 CONTINUE
48291 DO 410 I = 1,2
48292 DO 400 J = 1,2
48293 ACOUPB(I,J) =
48294 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
48295 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
48296 400 CONTINUE
48297 410 CONTINUE
48298
48299 PRUN = XMA
48300 EPS = 1D-4*PRUN
48301 ITER = 0
48302 420 ITER = ITER + 1
48303 DO 470 I3 = 1,3
48304 PR(I3)=PRUN+(I3-2)*EPS/2
48305 AP2=PR(I3)**2
48306 APOLT = 0D0
48307 DO 440 I = 1,2
48308 DO 430 J = 1,2
48309 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
48310 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48311 430 CONTINUE
48312 440 CONTINUE
48313 APOLB = 0D0
48314 DO 460 I = 1,2
48315 DO 450 J = 1,2
48316 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
48317 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48318 450 CONTINUE
48319 460 CONTINUE
48320C RXMT2 = RXMT**2
48321 XMT2=XMT**2
48322 APOLTT =
48323 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48324 & COSB**2/SINB**2 *
48325 & (-0.5D0*AP2)*
48326 & PYFINT(AP2,XMT2,XMT2)
48327 APOL = APOLT + APOLB + APOLTT
48328 POLAR(I3) = AP2 - XMA**2 -APOL
48329 470 CONTINUE
48330 DERIV = (POLAR(3)-POLAR(1))/EPS
48331 DRUN = - POLAR(2)/DERIV
48332 PRUN = PRUN + DRUN
48333 AP2 = PRUN**2
48334 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
48335 GOTO 420
48336 480 CONTINUE
48337
48338 AMP = DSQRT(AP2)
48339
48340CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48341C...END OF PSEUDOSCALAR HIGGS
48342CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48343
48344 IF(IHIGGS.EQ.3) GOTO 490
48345
48346 490 CONTINUE
48347 RETURN
48348 500 CONTINUE
48349 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
48350 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
48351 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
48352 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
48353 CALL PYSTOP(107)
48354 END
48355
48356C*********************************************************************
48357
48358C...PYRGHM
48359C...Auxiliary to PYPOLE.
48360
48361 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
48362 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
48363 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
48364 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
48365C...Parameters.
48366 INTEGER MSTU,MSTJ
48367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48368 SAVE /PYDAT1/
48369
48370 MZ = 91.18D0
48371 PI = PARU(1)
48372 V = 174.1D0
48373 ALPHA1 = 0.0101D0
48374 ALPHA2 = 0.0337D0
48375 ALPHA3Z = 0.12D0
48376 TANBA = TANB
48377 TANBT = TANB
48378C MBOTTOM(MTOP) = 3. GEV
48379 MB = PYMRUN(5,MTOP**2)
48380 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
48381 *LOG(MTOP**2/MZ**2))
48382C RMTOP= RUNNING TOP QUARK MASS
48383 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48384 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
48385 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
48386 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
48387CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48388C
48389C NEW DEFINITION, TGLU.
48390C
48391CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48392 TGLU = LOG(MGLU**2/MTOP**2)
48393 SINB = TANB/DSQRT(1D0 + TANB**2)
48394 COSB = SINB/TANB
48395 IF(MA.GT.MTOP)
48396 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
48397 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
48398 *LOG(MA**2/MTOP**2))
48399 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
48400 SINB = TANBT/SQRT(1D0 + TANBT**2)
48401 COSB = 1D0/DSQRT(1D0 + TANBT**2)
48402 G1 = SQRT(ALPHA1*4D0*PI)
48403 G2 = SQRT(ALPHA2*4D0*PI)
48404 G3 = SQRT(ALPHA3*4D0*PI)
48405 HU = RMTOP/V/SINB
48406 HD = MB/V/COSB
48407 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
48408 *SBOT1,SBOT2,DELTAMT,DELTAMB)
48409 IF(MQ.GT.MUR) TP = TQ - TU
48410 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
48411 IF(MQ.GT.MUR) TDP = TU
48412 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
48413 IF(MQ.GT.MD) TPD = TQ - TD
48414 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
48415 IF(MQ.GT.MD) TDPD = TD
48416 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
48417
48418 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
48419 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
48420 * HD**2*(G1**2/3D0+G2**2)*TPD
48421
48422 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
48423 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
48424 * HU**2*(-G1**2/3D0+G2**2)*TP
48425
48426CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48427C
48428C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
48429C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
48430C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
48431C TWO STOPS.
48432C
48433C
48434CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48435
48436 DLAMBDAP2 = 0D0
48437 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
48438 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
48439 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
48440 ENDIF
48441
48442 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
48443 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48444 ENDIF
48445
48446 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
48447 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48448 ENDIF
48449
48450 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
48451 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
48452 ENDIF
48453
48454 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
48455 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48456 ENDIF
48457
48458 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
48459 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48460 ENDIF
48461 ENDIF
48462 DLAMBDA3 = 0D0
48463 DLAMBDA4 = 0D0
48464 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
48465 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
48466 *(G2**2-G1**2/3D0)*TPD
48467 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
48468 *1D0/16D0/PI**2*G1**2*HU**2*TP
48469 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
48470 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
48471 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
48472 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
48473 *HD**2*TPD
48474 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
48475 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
48476 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
48477 *+ (3D0*HD**2/2D0 + HU**2/2D0
48478 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
48479 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
48480 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
48481 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
48482 *(TP + TDP)/8D0/PI**2)
48483 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
48484 *+ (3D0*HU**2/2D0 + HD**2/2D0
48485 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
48486 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
48487 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
48488 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48489 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
48490 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
48491 LAMBDA4 = (- G2**2/2D0)*(1D0
48492 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
48493 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
48494
48495 LAMBDA5 = 0D0
48496 LAMBDA6 = 0D0
48497 LAMBDA7 = 0D0
48498
48499 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
48500 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
48501
48502 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
48503 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
48504 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
48505 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
48506
48507 M2(2,1) = M2(1,2)
48508CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48509CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
48510CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48511
48512 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
48513
48514 IF(MCHI.GT.MSSUSY) GOTO 100
48515 IF(MCHI.LT.MTOP) MCHI=MTOP
48516
48517 TCHAR=LOG(MSSUSY**2/MCHI**2)
48518
48519 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
48520 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
48521 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
48522
48523 DELTAM112=2D0*DELTAL12*V**2*COSB**2
48524 DELTAM222=2D0*DELTAL12*V**2*SINB**2
48525 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
48526
48527 M2(1,1)=M2(1,1)+DELTAM112
48528 M2(2,2)=M2(2,2)+DELTAM222
48529 M2(1,2)=M2(1,2)+DELTAM122
48530 M2(2,1)=M2(2,1)+DELTAM122
48531
48532 100 CONTINUE
48533
48534CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48535CCC END OF CHARGINOS/NEUTRALINOS
48536CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48537
48538 DO 120 I = 1,2
48539 DO 110 J = 1,2
48540 M2P(I,J) = M2(I,J) + VH(I,J)
48541 110 CONTINUE
48542 120 CONTINUE
48543 TRM2P = M2P(1,1) + M2P(2,2)
48544 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
48545 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48546 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48547 HMP = DSQRT(HM2P)
48548 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
48549 MCH=DSQRT(MCH2)
48550 IF(MH2P.LT.0.) GOTO 130
48551 MHP = SQRT(MH2P)
48552 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
48553 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
48554 IF(COS2ALPHA.GE.0.) THEN
48555 ALPHA = ASIN(SIN2ALPHA)/2D0
48556 ELSE
48557 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
48558 ENDIF
48559 SA = SIN(ALPHA)
48560 CA = COS(ALPHA)
48561CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48562C
48563C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
48564C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
48565C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
48566C
48567C
48568CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48569 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
48570 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
48571 130 CONTINUE
48572 RETURN
48573 END
48574
48575C*********************************************************************
48576
48577C...PYGFXX
48578C...Auxiliary to PYRGHM.
48579
48580 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
48581 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
48582 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
48583 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
48584C...Commonblocks.
48585 INTEGER MSTU,MSTJ,KCHG
48586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48588 SAVE /PYDAT1/,/PYDAT2/
48589
48590 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
48591
48592 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
48593 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
48594
48595 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
48596 MQ2 = MQ**2
48597 MUR2 = MUR**2
48598 MD2 = MD**2
48599 TANBA = TANB
48600 SINBA = TANBA/DSQRT(TANBA**2+1D0)
48601 COSBA = SINBA/TANBA
48602
48603 SINB = TANB/DSQRT(TANB**2+1D0)
48604 COSB = SINB/TANB
48605
48606 PI = PARU(1)
48607 MZ = PMAS(23,1)
48608 MW = PMAS(24,1)
48609 SW = 1D0-MW**2/MZ**2
48610 V = 174.1D0
48611
48612 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
48613 G2 = DSQRT(0.0336D0*4D0*PI)
48614 G1 = DSQRT(0.0101D0*4D0*PI)
48615
48616 IF(MQ.GT.MUR) MST = MQ
48617 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
48618
48619 MSUSYT = DSQRT(MST**2 + MTOP**2)
48620
48621 IF(MQ.GT.MD) MSB = MQ
48622 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
48623
48624 MB = PYMRUN(5,MSB**2)
48625 MSUSYB = DSQRT(MSB**2 + MB**2)
48626 TT = LOG(MSUSYT**2/MTOP**2)
48627 TB = LOG(MSUSYB**2/MTOP**2)
48628
48629 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48630 HT = RMTOP/(V*SINB)
48631 HTST = RMTOP/V
48632 HB = MB/V/COSB
48633 G32 = ALPHA3*4D0*PI
48634 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
48635 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
48636 AL2 = 3D0/8D0/PI**2*HT**2
48637C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
48638C ALST = 3./8./PI**2*HTST**2
48639 AL1 = 3D0/8D0/PI**2*HB**2
48640
48641 AL(1,1) = AL1
48642 AL(1,2) = (AL2+AL1)/2D0
48643 AL(2,1) = (AL2+AL1)/2D0
48644 AL(2,2) = AL2
48645
48646 IF(MA.GT.MTOP) THEN
48647 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
48648 * LOG(MTOP**2/MA**2))
48649 H1I = VI* COSBA
48650 H2I = VI*SINBA
48651 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
48652 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
48653 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
48654 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
48655 ELSE
48656 VI = V
48657 H1I = VI*COSB
48658 H2I = VI*SINB
48659 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48660 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48661 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48662 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48663 ENDIF
48664
48665 TANBST = H2T/H1T
48666 SINBT = TANBST/DSQRT(1D0+TANBST**2)
48667
48668 TANBSB = H2B/H1B
48669 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
48670 COSBB = SINBB/TANBSB
48671
48672 DELTAMT = 0D0
48673 DELTAMB = 0D0
48674
48675 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48676 MTOP2 = DSQRT(MTOP4)
48677 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48678 * /(1D0+DELTAMB)**4
48679 MBOT2 = DSQRT(MBOT4)
48680
48681 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48682 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48683 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48684 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48685 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48686 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48687 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48688 * MQ2 - MUR2)**2*0.25D0
48689 * + MTOP2*(AT-XMU/TANBST)**2)
48690 IF(STOP22.LT.0.) GOTO 120
48691 SBOT12 = (MQ2 + MD2)*.5D0
48692 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48693 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48694 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48695 SBOT22 = (MQ2 + MD2)*.5D0
48696 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48697 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48698 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48699 IF(SBOT22.LT.0.) SBOT22 = 10000D0
48700
48701 STOP1 = DSQRT(STOP12)
48702 STOP2 = DSQRT(STOP22)
48703 SBOT1 = DSQRT(SBOT12)
48704 SBOT2 = DSQRT(SBOT22)
48705
48706CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48707C
48708C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
48709C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
48710C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
48711C INDUCED CORRECTIONS.
48712C
48713CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48714
48715 X=SBOT1
48716 Y=SBOT2
48717 Z=XMGL
48718 IF(X.EQ.Y) X = X - 0.00001D0
48719 IF(X.EQ.Z) X = X - 0.00002D0
48720 IF(Y.EQ.Z) Y = Y - 0.00003D0
48721
48722 T1=T(X,Y,Z)
48723 X=STOP1
48724 Y=STOP2
48725 Z=XMU
48726 IF(X.EQ.Y) X = X - 0.00001D0
48727 IF(X.EQ.Z) X = X - 0.00002D0
48728 IF(Y.EQ.Z) Y = Y - 0.00003D0
48729 T2=T(X,Y,Z)
48730 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
48731 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
48732 X=STOP1
48733 Y=STOP2
48734 Z=XMGL
48735 IF(X.EQ.Y) X = X - 0.00001D0
48736 IF(X.EQ.Z) X = X - 0.00002D0
48737 IF(Y.EQ.Z) Y = Y - 0.00003D0
48738 T3=T(X,Y,Z)
48739 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
48740
48741CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48742C
48743C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
48744C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
48745C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
48746C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
48747C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
48748C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
48749C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
48750C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
48751C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
48752C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
48753C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
48754C
48755C
48756CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48757
48758 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48759 MTOP2 = DSQRT(MTOP4)
48760 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48761 * /(1D0+DELTAMB)**4
48762 MBOT2 = DSQRT(MBOT4)
48763
48764 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48765 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48766 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48767 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48768 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48769 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48770 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48771 * MQ2 - MUR2)**2*0.25D0
48772 * + MTOP2*(AT-XMU/TANBST)**2)
48773
48774 IF(STOP22.LT.0.) GOTO 120
48775 SBOT12 = (MQ2 + MD2)*.5D0
48776 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48777 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48778 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48779 SBOT22 = (MQ2 + MD2)*.5D0
48780 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48781 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48782 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48783 IF(SBOT22.LT.0.) GOTO 120
48784
48785
48786 STOP1 = DSQRT(STOP12)
48787 STOP2 = DSQRT(STOP22)
48788 SBOT1 = DSQRT(SBOT12)
48789 SBOT2 = DSQRT(SBOT22)
48790
48791CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48792CCC D-TERMS
48793CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48794 STW=SW
48795
48796 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
48797 * LOG(STOP1/STOP2)
48798 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
48799 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
48800
48801 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
48802 * LOG(SBOT1/SBOT2)
48803 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
48804 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
48805
48806 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
48807 * (-.5D0*LOG(STOP12/STOP22)
48808 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
48809 * G(STOP12,STOP22))
48810
48811 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
48812 * (.5D0*LOG(SBOT12/SBOT22)
48813 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
48814 * G(SBOT12,SBOT22))
48815
48816 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
48817 * (MQ2+MBOT2)/(MD2+MBOT2))
48818 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
48819 * LOG(SBOT1**2/SBOT2**2)) +
48820 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
48821 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
48822
48823 VH3T(1,1) =
48824 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
48825 * -STOP2**2))**2*G(STOP12,STOP22)
48826
48827 VH3B(1,1)=VH3B(1,1)+
48828 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
48829
48830 VH3T(1,1) = VH3T(1,1) +
48831 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
48832
48833 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
48834 * (MQ2+MTOP2)/(MUR2+MTOP2))
48835 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
48836 * LOG(STOP1**2/STOP2**2)) +
48837 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
48838 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
48839
48840 VH3B(2,2) =
48841 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
48842 * -SBOT2**2))**2*G(SBOT12,SBOT22)
48843
48844 VH3T(2,2)=VH3T(2,2)+
48845 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
48846 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
48847 VH3T(1,2) = -
48848 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
48849 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
48850 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
48851
48852 VH3B(1,2) =
48853 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
48854 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
48855 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
48856
48857
48858 VH3T(1,2)=VH3T(1,2) +
48859 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
48860
48861 VH3B(1,2)=VH3B(1,2) +
48862 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
48863
48864 VH3T(2,1) = VH3T(1,2)
48865 VH3B(2,1) = VH3B(1,2)
48866
48867C TQ = LOG((MQ2 + MTOP2)/MTOP2)
48868C TU = LOG((MUR2+MTOP2)/MTOP2)
48869C TQD = LOG((MQ2 + MB**2)/MB**2)
48870C TD = LOG((MD2+MB**2)/MB**2)
48871
48872 DO 110 I = 1,2
48873 DO 100 J = 1,2
48874 VH(I,J) =
48875 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
48876 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
48877 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
48878 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
48879 100 CONTINUE
48880 110 CONTINUE
48881
48882 GOTO 150
48883 120 DO 140 I =1,2
48884 DO 130 J = 1,2
48885 VH(I,J) = -1D15
48886 130 CONTINUE
48887 140 CONTINUE
48888
48889
48890 150 RETURN
48891 END
48892
48893
48894
48895
48896
48897C*********************************************************************
48898
48899C...PYFINT
48900C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
48901
48902 FUNCTION PYFINT(A,B,C)
48903
48904C...Double precision and integer declarations.
48905 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48906 IMPLICIT INTEGER(I-N)
48907 INTEGER PYK,PYCHGE,PYCOMP
48908C...Commonblock.
48909 COMMON/PYINTS/XXM(20)
48910 SAVE/PYINTS/
48911
48912C...Local variables.
48913 EXTERNAL PYFISB
48914 DOUBLE PRECISION PYFISB
48915
48916 XXM(1)=A
48917 XXM(2)=B
48918 XXM(3)=C
48919 XLO=0D0
48920 XHI=1D0
48921 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
48922
48923 RETURN
48924 END
48925
48926C*********************************************************************
48927
48928C...PYFISB
48929C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
48930
48931 FUNCTION PYFISB(X)
48932
48933C...Double precision and integer declarations.
48934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48935 IMPLICIT INTEGER(I-N)
48936 INTEGER PYK,PYCHGE,PYCOMP
48937C...Commonblock.
48938 COMMON/PYINTS/XXM(20)
48939 SAVE/PYINTS/
48940
48941 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
48942 &(X*(XXM(2)-XXM(3))+XXM(3)))
48943
48944 RETURN
48945 END
48946
48947C*********************************************************************
48948
48949C...PYSFDC
48950C...Calculates decays of sfermions.
48951
48952 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
48953
48954C...Double precision and integer declarations.
48955 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48956 IMPLICIT INTEGER(I-N)
48957 INTEGER PYK,PYCHGE,PYCOMP
48958C...Parameter statement to help give large particle numbers.
48959 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48960 &KEXCIT=4000000,KDIMEN=5000000)
48961C...Commonblocks.
48962 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48963 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48964 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48965 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48966 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48967 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48968
48969C...Local variables.
48970 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
48971 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
48972 INTEGER KFIN,KCIN
48973 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
48974 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48975 DOUBLE PRECISION PYLAMF,XL
48976 DOUBLE PRECISION TANW,XW,AEM,C1,AS
48977 DOUBLE PRECISION AL,AR,BL,BR
48978 DOUBLE PRECISION CH1,CH2,CH3,CH4
48979 DOUBLE PRECISION XMBOT,XMTOP
48980 DOUBLE PRECISION XLAM(0:400)
48981 INTEGER IDLAM(400,3)
48982 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
48983 DOUBLE PRECISION SR2
48984 DOUBLE PRECISION CBETA,SBETA
48985 DOUBLE PRECISION CW
48986 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
48987 DOUBLE PRECISION COSA,SINA,TANB
48988 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
48989 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
48990 INTEGER IG,KF1,KF2
48991 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
48992 DATA IGG/23,25,35,36/
48993 DATA PI/3.141592654D0/
48994 DATA SR2/1.4142136D0/
48995 DATA KFNCHI/1000022,1000023,1000025,1000035/
48996 DATA KFCCHI/1000024,1000037/
48997
48998C...COUNT THE NUMBER OF DECAY MODES
48999 LKNT=0
49000
49001C...NO NU_R DECAYS
49002 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49003 &KFIN.EQ.KSUSY2+16) RETURN
49004
49005 XMW=PMAS(24,1)
49006 XMW2=XMW**2
49007 XMZ=PMAS(23,1)
49008 XW=PARU(102)
49009 TANW = SQRT(XW/(1D0-XW))
49010 CW=SQRT(1D0-XW)
49011
49012 DO 110 I=1,4
49013 DO 100 J=1,4
49014 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49015 100 CONTINUE
49016 110 CONTINUE
49017 DO 130 I=1,2
49018 DO 120 J=1,2
49019 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49020 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49021 120 CONTINUE
49022 130 CONTINUE
49023
49024C...KCIN
49025 KCIN=PYCOMP(KFIN)
49026C...ILR is 1 for left and 2 for right.
49027 ILR=KFIN/KSUSY1
49028C...IFL is matching non-SUSY flavour.
49029 IFL=MOD(KFIN,KSUSY1)
49030C...IDU is weak isospin, 1 for down and 2 for up.
49031 IDU=2-MOD(IFL,2)
49032
49033 XMI=PMAS(KCIN,1)
49034 XMI2=XMI**2
49035 AEM=PYALEM(XMI2)
49036 AS =PYALPS(XMI2)
49037 C1=AEM/XW
49038 XMI3=XMI**3
49039 EI=KCHG(IFL,1)/3D0
49040
49041 XMBOT=PYMRUN(5,XMI2)
49042 XMTOP=PYMRUN(6,XMI2)
49043
49044 TANB=RMSS(5)
49045 BETA=ATAN(TANB)
49046 ALFA=RMSS(18)
49047 CBETA=COS(BETA)
49048 SBETA=TANB*CBETA
49049 SINA=SIN(ALFA)
49050 COSA=COS(ALFA)
49051 XMU=-RMSS(4)
49052 ATRIT=RMSS(16)
49053 ATRIB=RMSS(15)
49054 ATRIL=RMSS(17)
49055
49056C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49057
49058 IF(IMSS(11).EQ.1) THEN
49059 XMP=RMSS(29)
49060 IDG=39+KSUSY1
49061 XMGR=PMAS(PYCOMP(IDG),1)
49062 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
49063 IF(IFL.EQ.5) THEN
49064 XMF=XMBOT
49065 ELSEIF(IFL.EQ.6) THEN
49066 XMF=XMTOP
49067 ELSE
49068 XMF=PMAS(IFL,1)
49069 ENDIF
49070 IF(XMI.GT.XMGR+XMF) THEN
49071 LKNT=LKNT+1
49072 IDLAM(LKNT,1)=IDG
49073 IDLAM(LKNT,2)=IFL
49074 IDLAM(LKNT,3)=0
49075 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
49076 ENDIF
49077 ENDIF
49078
49079C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49080
49081C...CHARGED DECAYS:
49082 DO 140 IX=1,2
49083C...DI -> U CHI1-,CHI2-
49084 IF(IDU.EQ.1) THEN
49085 XMFP=PMAS(IFL+1,1)
49086 XMF =PMAS(IFL,1)
49087C...UI -> D CHI1+,CHI2+
49088 ELSE
49089 XMFP=PMAS(IFL-1,1)
49090 XMF =PMAS(IFL,1)
49091 ENDIF
49092 XMJ=SMW(IX)
49093 AXMJ=ABS(XMJ)
49094 IF(XMI.GE.AXMJ+XMFP) THEN
49095 XMA2=XMJ**2
49096 XMB2=XMFP**2
49097 IF(IDU.EQ.2) THEN
49098 IF(IFL.EQ.6) THEN
49099 XMFP=XMBOT
49100 XMF =XMTOP
49101 ELSEIF(IFL.LT.6) THEN
49102 XMF=0D0
49103 XMFP=0D0
49104 ENDIF
49105 CBL=VMIXC(IX,1)
49106 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
49107 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
49108 CAR=0D0
49109 ELSE
49110 IF(IFL.EQ.5) THEN
49111 XMF =XMBOT
49112 XMFP=XMTOP
49113 ELSEIF(IFL.LT.5) THEN
49114 XMF=0D0
49115 XMFP=0D0
49116 ENDIF
49117 CBL=UMIXC(IX,1)
49118 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
49119 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
49120 CAR=0D0
49121 ENDIF
49122
49123 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49124 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49125 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49126 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49127 CAL=CALP
49128 CBL=CBLP
49129 CAR=CARP
49130 CBR=CBRP
49131
49132C...F1 -> F` CHI
49133 IF(ILR.EQ.1) THEN
49134 CA=CAL
49135 CB=CBL
49136C...F2 -> F` CHI
49137 ELSE
49138 CA=CAR
49139 CB=CBR
49140 ENDIF
49141 LKNT=LKNT+1
49142 XL=PYLAMF(XMI2,XMA2,XMB2)
49143C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49144 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49145 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
49146 IDLAM(LKNT,3)=0
49147 IF(IDU.EQ.1) THEN
49148 IDLAM(LKNT,1)=-KFCCHI(IX)
49149 IDLAM(LKNT,2)=IFL+1
49150 ELSE
49151 IDLAM(LKNT,1)=KFCCHI(IX)
49152 IDLAM(LKNT,2)=IFL-1
49153 ENDIF
49154 ENDIF
49155 140 CONTINUE
49156
49157C...NEUTRAL DECAYS
49158 DO 150 IX=1,4
49159C...DI -> D CHI10
49160 XMF=PMAS(IFL,1)
49161 XMJ=SMZ(IX)
49162 AXMJ=ABS(XMJ)
49163 IF(XMI.GE.AXMJ+XMF) THEN
49164 XMA2=XMJ**2
49165 XMB2=XMF**2
49166 IF(IDU.EQ.1) THEN
49167 IF(IFL.EQ.5) THEN
49168 XMF=XMBOT
49169 ELSEIF(IFL.LT.5) THEN
49170 XMF=0D0
49171 ENDIF
49172 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
49173 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
49174 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49175 CBR=CAL
49176 ELSE
49177 IF(IFL.EQ.6) THEN
49178 XMF=XMTOP
49179 ELSEIF(IFL.LT.5) THEN
49180 XMF=0D0
49181 ENDIF
49182 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
49183 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
49184 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49185 CBR=CAL
49186 ENDIF
49187
49188 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49189 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49190 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49191 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49192 CAL=CALP
49193 CBL=CBLP
49194 CAR=CARP
49195 CBR=CBRP
49196
49197C...F1 -> F CHI
49198 IF(ILR.EQ.1) THEN
49199 CA=CAL
49200 CB=CBL
49201C...F2 -> F CHI
49202 ELSE
49203 CA=CAR
49204 CB=CBR
49205 ENDIF
49206 LKNT=LKNT+1
49207 XL=PYLAMF(XMI2,XMA2,XMB2)
49208C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49209 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49210 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
49211 IDLAM(LKNT,1)=KFNCHI(IX)
49212 IDLAM(LKNT,2)=IFL
49213 IDLAM(LKNT,3)=0
49214 ENDIF
49215 150 CONTINUE
49216
49217C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
49218C...IG=23,25,35,36
49219 DO 160 II=1,4
49220 IG=IGG(II)
49221 IF(ILR.EQ.1) GOTO 160
49222 XMB=PMAS(IG,1)
49223 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
49224 IF(XMI.LT.XMSF1+XMB) GOTO 160
49225 IF(IG.EQ.23) THEN
49226 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
49227 BR=EI*XW/CW
49228 BLR=0D0
49229 ELSEIF(IG.EQ.25) THEN
49230 IF(IFL.EQ.5) THEN
49231 XMF=XMBOT
49232 ELSEIF(IFL.EQ.6) THEN
49233 XMF=XMTOP
49234 ELSEIF(IFL.LT.5) THEN
49235 XMF=0D0
49236 ELSE
49237 XMF=PMAS(IFL,1)
49238 ENDIF
49239 IF(IDU.EQ.2) THEN
49240 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49241 & XMF**2/XMW*COSA/SBETA
49242 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49243 & XMF**2/XMW*COSA/SBETA
49244 ELSE
49245 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49246 & XMF**2/XMW*(-SINA)/CBETA
49247 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49248 & XMF**2/XMW*(-SINA)/CBETA
49249 ENDIF
49250 IF(IFL.EQ.5) THEN
49251 AT=ATRIB
49252 ELSEIF(IFL.EQ.6) THEN
49253 AT=ATRIT
49254 ELSEIF(IFL.EQ.15) THEN
49255 AT=ATRIL
49256 ELSE
49257 AT=0D0
49258 ENDIF
49259C.........need to complexify
49260 IF(IDU.EQ.2) THEN
49261 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
49262 & AT*COSA)
49263 ELSE
49264 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
49265 & AT*SINA)
49266 ENDIF
49267 BL=GHLL
49268 BR=GHRR
49269 BLR=-GHLR
49270 ELSEIF(IG.EQ.35) THEN
49271 IF(IFL.EQ.5) THEN
49272 XMF=XMBOT
49273 ELSEIF(IFL.EQ.6) THEN
49274 XMF=XMTOP
49275 ELSEIF(IFL.LT.5) THEN
49276 XMF=0D0
49277 ELSE
49278 XMF=PMAS(IFL,1)
49279 ENDIF
49280 IF(IDU.EQ.2) THEN
49281 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49282 & XMF**2/XMW*SINA/SBETA
49283 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49284 & XMF**2/XMW*SINA/SBETA
49285 ELSE
49286 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49287 & XMF**2/XMW*COSA/CBETA
49288 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49289 & XMF**2/XMW*COSA/CBETA
49290 ENDIF
49291 IF(IFL.EQ.5) THEN
49292 AT=ATRIB
49293 ELSEIF(IFL.EQ.6) THEN
49294 AT=ATRIT
49295 ELSEIF(IFL.EQ.15) THEN
49296 AT=ATRIL
49297 ELSE
49298 AT=0D0
49299 ENDIF
49300C.........Need to complexify
49301 IF(IDU.EQ.2) THEN
49302 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
49303 & AT*SINA)
49304 ELSE
49305 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
49306 & AT*COSA)
49307 ENDIF
49308 BL=GHLL
49309 BR=GHRR
49310 BLR=GHLR
49311 ELSEIF(IG.EQ.36) THEN
49312 GHLL=0D0
49313 GHRR=0D0
49314 IF(IFL.EQ.5) THEN
49315 XMF=XMBOT
49316 ELSEIF(IFL.EQ.6) THEN
49317 XMF=XMTOP
49318 ELSEIF(IFL.LT.5) THEN
49319 XMF=0D0
49320 ELSE
49321 XMF=PMAS(IFL,1)
49322 ENDIF
49323 IF(IFL.EQ.5) THEN
49324 AT=ATRIB
49325 ELSEIF(IFL.EQ.6) THEN
49326 AT=ATRIT
49327 ELSEIF(IFL.EQ.15) THEN
49328 AT=ATRIL
49329 ELSE
49330 AT=0D0
49331 ENDIF
49332C.........Need to complexify
49333 IF(IDU.EQ.2) THEN
49334 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
49335 ELSE
49336 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
49337 ENDIF
49338 BL=GHLL
49339 BR=GHRR
49340 BLR=GHLR
49341 ENDIF
49342 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
49343 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
49344 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
49345 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49346 LKNT=LKNT+1
49347 IF(IG.EQ.23) THEN
49348 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49349 ELSE
49350 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
49351 ENDIF
49352 IDLAM(LKNT,3)=0
49353 IDLAM(LKNT,1)=KFIN-KSUSY1
49354 IDLAM(LKNT,2)=IG
49355 160 CONTINUE
49356
49357C...SF -> SF' + W
49358 XMB=PMAS(24,1)
49359 IF(MOD(IFL,2).EQ.0) THEN
49360 KF1=KSUSY1+IFL-1
49361 ELSE
49362 KF1=KSUSY1+IFL+1
49363 ENDIF
49364 KF2=KF1+KSUSY1
49365 XMSF1=PMAS(PYCOMP(KF1),1)
49366 XMSF2=PMAS(PYCOMP(KF2),1)
49367 IF(XMI.GT.XMB+XMSF1) THEN
49368 IF(MOD(IFL,2).EQ.0) THEN
49369 IF(ILR.EQ.1) THEN
49370 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
49371 ELSE
49372 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
49373 ENDIF
49374 ELSE
49375 IF(ILR.EQ.1) THEN
49376 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
49377 ELSE
49378 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
49379 ENDIF
49380 ENDIF
49381 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49382 LKNT=LKNT+1
49383 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49384 IDLAM(LKNT,3)=0
49385 IDLAM(LKNT,1)=KF1
49386 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49387 ENDIF
49388 IF(XMI.GT.XMB+XMSF2) THEN
49389 IF(MOD(IFL,2).EQ.0) THEN
49390 IF(ILR.EQ.1) THEN
49391 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
49392 ELSE
49393 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
49394 ENDIF
49395 ELSE
49396 IF(ILR.EQ.1) THEN
49397 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
49398 ELSE
49399 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
49400 ENDIF
49401 ENDIF
49402 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
49403 LKNT=LKNT+1
49404 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49405 IDLAM(LKNT,3)=0
49406 IDLAM(LKNT,1)=KF2
49407 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49408 ENDIF
49409
49410C...SF -> SF' + HC
49411 XMB=PMAS(37,1)
49412 IF(MOD(IFL,2).EQ.0) THEN
49413 KF1=KSUSY1+IFL-1
49414 ELSE
49415 KF1=KSUSY1+IFL+1
49416 ENDIF
49417 KF2=KF1+KSUSY1
49418 XMSF1=PMAS(PYCOMP(KF1),1)
49419 XMSF2=PMAS(PYCOMP(KF2),1)
49420 IF(XMI.GT.XMB+XMSF1) THEN
49421 XMF=0D0
49422 XMFP=0D0
49423 AT=0D0
49424 AB=0D0
49425 IF(MOD(IFL,2).EQ.0) THEN
49426C...T1-> B1 HC
49427 IF(ILR.EQ.1) THEN
49428 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
49429 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
49430 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
49431 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
49432C...T2-> B1 HC
49433 ELSE
49434 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
49435 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
49436 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
49437 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
49438 ENDIF
49439 IF(IFL.EQ.6) THEN
49440 XMF=XMTOP
49441 XMFP=XMBOT
49442 AT=ATRIT
49443 AB=ATRIB
49444 ENDIF
49445 ELSE
49446C...B1 -> T1 HC
49447 IF(ILR.EQ.1) THEN
49448 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
49449 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
49450 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
49451 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
49452C...B2-> T1 HC
49453 ELSE
49454 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
49455 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
49456 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
49457 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
49458 ENDIF
49459 IF(IFL.EQ.5) THEN
49460 XMF=XMTOP
49461 XMFP=XMBOT
49462 AT=ATRIT
49463 AB=ATRIB
49464 ENDIF
49465 ENDIF
49466 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49467 LKNT=LKNT+1
49468C.......Need to complexify
49469 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49470 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49471 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49472 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49473 IDLAM(LKNT,3)=0
49474 IDLAM(LKNT,1)=KF1
49475 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49476 ENDIF
49477 IF(XMI.GT.XMB+XMSF2) THEN
49478 XMF=0D0
49479 XMFP=0D0
49480 AT=0D0
49481 AB=0D0
49482 IF(MOD(IFL,2).EQ.0) THEN
49483C...T1-> B2 HC
49484 IF(ILR.EQ.1) THEN
49485 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
49486 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
49487 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
49488 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
49489C...T2-> B2 HC
49490 ELSE
49491 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
49492 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
49493 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
49494 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
49495 ENDIF
49496 IF(IFL.EQ.6) THEN
49497 XMF=XMTOP
49498 XMFP=XMBOT
49499 AT=ATRIT
49500 AB=ATRIB
49501 ENDIF
49502 ELSE
49503C...B1 -> T2 HC
49504 IF(ILR.EQ.1) THEN
49505 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
49506 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
49507 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
49508 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
49509C...B2-> T2 HC
49510 ELSE
49511 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
49512 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
49513 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
49514 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
49515 ENDIF
49516 IF(IFL.EQ.5) THEN
49517 XMF=XMTOP
49518 XMFP=XMBOT
49519 AT=ATRIT
49520 AB=ATRIB
49521 ENDIF
49522 ENDIF
49523 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49524 LKNT=LKNT+1
49525C.......Need to complexify
49526 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49527 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49528 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49529 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49530 IDLAM(LKNT,3)=0
49531 IDLAM(LKNT,1)=KF2
49532 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49533 ENDIF
49534
49535C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
49536
49537 IF(IFL.LE.6) THEN
49538 XMFP=0D0
49539 XMF=0D0
49540 IF(IFL.EQ.6) XMF=PMAS(6,1)
49541 IF(IFL.EQ.5) XMF=PMAS(5,1)
49542 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
49543 AXMJ=ABS(XMJ)
49544 IF(XMI.GE.AXMJ+XMF) THEN
49545 AL=-SFMIX(IFL,3)
49546 BL=SFMIX(IFL,1)
49547 AR=-SFMIX(IFL,4)
49548 BR=SFMIX(IFL,2)
49549C...F1 -> F CHI
49550 IF(ILR.EQ.1) THEN
49551 XCA=AL
49552 XCB=BL
49553C...F2 -> F CHI
49554 ELSE
49555 XCA=AR
49556 XCB=BR
49557 ENDIF
49558 LKNT=LKNT+1
49559 XMA2=XMJ**2
49560 XMB2=XMF**2
49561 XL=PYLAMF(XMI2,XMA2,XMB2)
49562 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49563 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
49564 IDLAM(LKNT,1)=KSUSY1+21
49565 IDLAM(LKNT,2)=IFL
49566 IDLAM(LKNT,3)=0
49567 ENDIF
49568 ENDIF
49569
49570C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
49571 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
49572 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
49573C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
49574C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
49575C...M*M = C1**2 * G**2/(16PI**2)
49576C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
49577 LKNT=LKNT+1
49578 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
49579 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
49580 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
49581 IDLAM(LKNT,1)=KSUSY1+22
49582 IDLAM(LKNT,2)=4
49583 IDLAM(LKNT,3)=0
49584 ENDIF
49585
49586C...R-violating sfermion decays (SKANDS).
49587 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
49588
49589 IKNT=LKNT
49590 XLAM(0)=0D0
49591 DO 170 I=1,IKNT
49592 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49593 XLAM(0)=XLAM(0)+XLAM(I)
49594 170 CONTINUE
49595 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
49596
49597 RETURN
49598 END
49599
49600C*********************************************************************
49601
49602C...PYGLUI
49603C...Calculates gluino decay modes.
49604
49605 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
49606
49607C...Double precision and integer declarations.
49608 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49609 IMPLICIT INTEGER(I-N)
49610 INTEGER PYK,PYCHGE,PYCOMP
49611C...Parameter statement to help give large particle numbers.
49612 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49613 &KEXCIT=4000000,KDIMEN=5000000)
49614C...Commonblocks.
49615 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49616 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49617 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49618 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49619 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49620CC &SFMIX(16,4),
49621C COMMON/PYINTS/XXM(20)
49622 COMPLEX*16 CXC
49623 COMMON/PYINTC/XXC(10),CXC(8)
49624 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49625
49626C...Local variables
49627 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49628 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
49629 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49630 DOUBLE PRECISION PYLAMF,XL
49631 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
49632 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
49633 DOUBLE PRECISION XLAM(0:400)
49634 INTEGER IDLAM(400,3)
49635 INTEGER LKNT,IX,ILR,I,IKNT,IFL
49636 DOUBLE PRECISION SR2
49637 DOUBLE PRECISION GAM
49638 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
49639 EXTERNAL PYGAUS,PYXXZ6
49640 DOUBLE PRECISION PYGAUS,PYXXZ6
49641 DOUBLE PRECISION PREC
49642 INTEGER KFNCHI(4),KFCCHI(2)
49643 DATA PI/3.141592654D0/
49644 DATA SR2/1.4142136D0/
49645 DATA PREC/1D-2/
49646 DATA KFNCHI/1000022,1000023,1000025,1000035/
49647 DATA KFCCHI/1000024,1000037/
49648
49649C...COUNT THE NUMBER OF DECAY MODES
49650 LKNT=0
49651 IF(KFIN.NE.KSUSY1+21) RETURN
49652 KCIN=PYCOMP(KFIN)
49653
49654 XW=PARU(102)
49655 TANW = SQRT(XW/(1D0-XW))
49656
49657 XMI=PMAS(KCIN,1)
49658 AXMI=ABS(XMI)
49659 XMI2=XMI**2
49660 AEM=PYALEM(XMI2)
49661 AS =PYALPS(XMI2)
49662 C1=AEM/XW
49663 XMI3=AXMI**3
49664
49665 XMI=SIGN(XMI,RMSS(3))
49666
49667C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
49668
49669 IF(IMSS(11).EQ.1) THEN
49670 XMP=RMSS(29)
49671 IDG=39+KSUSY1
49672 XMGR=PMAS(PYCOMP(IDG),1)
49673 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49674 IF(AXMI.GT.XMGR) THEN
49675 LKNT=LKNT+1
49676 IDLAM(LKNT,1)=IDG
49677 IDLAM(LKNT,2)=21
49678 IDLAM(LKNT,3)=0
49679 XLAM(LKNT)=XFAC
49680 ENDIF
49681 ENDIF
49682
49683C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
49684
49685 DO 110 IFL=1,6
49686 DO 100 ILR=1,2
49687 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
49688 AXMJ=ABS(XMJ)
49689 XMF=PMAS(IFL,1)
49690 IF(AXMI.GE.AXMJ+XMF) THEN
49691C...Minus sign difference from gluino-quark-squark feynman rules
49692 AL=SFMIX(IFL,1)
49693 BL=-SFMIX(IFL,3)
49694 AR=SFMIX(IFL,2)
49695 BR=-SFMIX(IFL,4)
49696C...F1 -> F CHI
49697 IF(ILR.EQ.1) THEN
49698 CA=AL
49699 CB=BL
49700C...F2 -> F CHI
49701 ELSE
49702 CA=AR
49703 CB=BR
49704 ENDIF
49705 LKNT=LKNT+1
49706 XMA2=XMJ**2
49707 XMB2=XMF**2
49708 XL=PYLAMF(XMI2,XMA2,XMB2)
49709 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
49710 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
49711 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
49712 IDLAM(LKNT,2)=-IFL
49713 IDLAM(LKNT,3)=0
49714 LKNT=LKNT+1
49715 XLAM(LKNT)=XLAM(LKNT-1)
49716 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49717 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49718 IDLAM(LKNT,3)=0
49719 ENDIF
49720 100 CONTINUE
49721 110 CONTINUE
49722
49723C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
49724C...GLUINO -> NI Q QBAR
49725 DO 170 IX=1,4
49726 XMJ=SMZ(IX)
49727 AXMJ=ABS(XMJ)
49728 IF(AXMI.GE.AXMJ) THEN
49729 DO 120 I=1,4
49730 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
49731 120 CONTINUE
49732 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
49733 ORPP=DCONJG(OLPP)
49734 XXC(1)=0D0
49735 XXC(2)=XMJ
49736 XXC(3)=0D0
49737 XXC(4)=XMI
49738 IA=1
49739 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49740 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49741 XXC(7)=XXC(5)
49742 XXC(8)=XXC(6)
49743 XXC(9)=1D6
49744 XXC(10)=0D0
49745 EI=KCHG(IA,1)/3D0
49746 T3I=SIGN(1D0,EI+1D-6)/2D0
49747 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49748 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49749 CXC(1)=0D0
49750 CXC(2)=-GLIJ
49751 CXC(3)=0D0
49752 CXC(4)=DCONJG(GLIJ)
49753 CXC(5)=0D0
49754 CXC(6)=GRIJ
49755 CXC(7)=0D0
49756 CXC(8)=-DCONJG(GRIJ)
49757 S12MIN=0D0
49758 S12MAX=(AXMI-AXMJ)**2
49759 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
49760 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49761 LKNT=LKNT+1
49762 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49763 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49764 IDLAM(LKNT,1)=KFNCHI(IX)
49765 IDLAM(LKNT,2)=1
49766 IDLAM(LKNT,3)=-1
49767 ENDIF
49768 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49769 LKNT=LKNT+1
49770 XLAM(LKNT)=XLAM(LKNT-1)
49771 IDLAM(LKNT,1)=KFNCHI(IX)
49772 IDLAM(LKNT,2)=3
49773 IDLAM(LKNT,3)=-3
49774 ENDIF
49775 130 CONTINUE
49776 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49777 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
49778 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
49779 GOTO 140
49780 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
49781 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
49782 ENDIF
49783 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
49784 LKNT=LKNT+1
49785 XLAM(LKNT)=GAM
49786 IDLAM(LKNT,1)=KFNCHI(IX)
49787 IDLAM(LKNT,2)=5
49788 IDLAM(LKNT,3)=-5
49789 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
49790 ENDIF
49791C...U-TYPE QUARKS
49792 140 CONTINUE
49793 IA=2
49794 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49795 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49796C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
49797 XXC(7)=XXC(5)
49798 XXC(8)=XXC(6)
49799 EI=KCHG(IA,1)/3D0
49800 T3I=SIGN(1D0,EI+1D-6)/2D0
49801 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49802 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49803 CXC(2)=-GLIJ
49804 CXC(4)=DCONJG(GLIJ)
49805 CXC(6)=GRIJ
49806 CXC(8)=-DCONJG(GRIJ)
49807 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
49808 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49809 LKNT=LKNT+1
49810 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49811 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49812 IDLAM(LKNT,1)=KFNCHI(IX)
49813 IDLAM(LKNT,2)=2
49814 IDLAM(LKNT,3)=-2
49815 ENDIF
49816 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49817 LKNT=LKNT+1
49818 XLAM(LKNT)=XLAM(LKNT-1)
49819 IDLAM(LKNT,1)=KFNCHI(IX)
49820 IDLAM(LKNT,2)=4
49821 IDLAM(LKNT,3)=-4
49822 ENDIF
49823 150 CONTINUE
49824C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
49825C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
49826 XMF=PMAS(6,1)
49827 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
49828 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
49829 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
49830 GOTO 160
49831 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
49832 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
49833 ENDIF
49834 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
49835 LKNT=LKNT+1
49836 XLAM(LKNT)=GAM
49837 IDLAM(LKNT,1)=KFNCHI(IX)
49838 IDLAM(LKNT,2)=6
49839 IDLAM(LKNT,3)=-6
49840 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
49841 ENDIF
49842 160 CONTINUE
49843 ENDIF
49844 170 CONTINUE
49845
49846C...GLUINO -> CI Q QBAR'
49847 DO 210 IX=1,2
49848 XMJ=SMW(IX)
49849 AXMJ=ABS(XMJ)
49850 IF(AXMI.GE.AXMJ) THEN
49851 DO 180 I=1,2
49852 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
49853 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
49854 180 CONTINUE
49855 S12MIN=0D0
49856 S12MAX=(AXMI-AXMJ)**2
49857 XXC(1)=0D0
49858 XXC(2)=XMJ
49859 XXC(3)=0D0
49860 XXC(4)=XMI
49861 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
49862 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
49863 XXC(9)=1D6
49864 XXC(10)=0D0
49865 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
49866 ORPP=DCONJG(OLPP)
49867 CXC(1)=DCMPLX(0D0,0D0)
49868 CXC(3)=DCMPLX(0D0,0D0)
49869 CXC(5)=DCMPLX(0D0,0D0)
49870 CXC(7)=DCMPLX(0D0,0D0)
49871 CXC(2)=UMIXC(IX,1)*OLPP/SR2
49872 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
49873 CXC(6)=DCMPLX(0D0,0D0)
49874 CXC(8)=DCMPLX(0D0,0D0)
49875 IF(XXC(5).LT.AXMI) THEN
49876 XXC(5)=1D6
49877 ELSEIF(XXC(6).LT.AXMI) THEN
49878 XXC(6)=1D6
49879 ENDIF
49880 XXC(7)=XXC(6)
49881 XXC(8)=XXC(5)
49882 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
49883 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
49884 LKNT=LKNT+1
49885 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
49886 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49887 IDLAM(LKNT,1)=KFCCHI(IX)
49888 IDLAM(LKNT,2)=1
49889 IDLAM(LKNT,3)=-2
49890 LKNT=LKNT+1
49891 XLAM(LKNT)=XLAM(LKNT-1)
49892 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49893 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49894 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49895 ENDIF
49896 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49897 LKNT=LKNT+1
49898 XLAM(LKNT)=XLAM(LKNT-1)
49899 IDLAM(LKNT,1)=KFCCHI(IX)
49900 IDLAM(LKNT,2)=3
49901 IDLAM(LKNT,3)=-4
49902 LKNT=LKNT+1
49903 XLAM(LKNT)=XLAM(LKNT-1)
49904 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49905 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49906 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49907 ENDIF
49908 190 CONTINUE
49909
49910 XMF=PMAS(6,1)
49911 XMFP=PMAS(5,1)
49912 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
49913 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
49914 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
49915 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
49916 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
49917 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
49918 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
49919 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
49920 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
49921 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
49922 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
49923 CALL PYTBBC(IX,100,XMI,GAM)
49924 LKNT=LKNT+1
49925 XLAM(LKNT)=GAM
49926 IDLAM(LKNT,1)=KFCCHI(IX)
49927 IDLAM(LKNT,2)=5
49928 IDLAM(LKNT,3)=-6
49929 LKNT=LKNT+1
49930 XLAM(LKNT)=XLAM(LKNT-1)
49931 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49932 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49933 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49934 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
49935 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
49936 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
49937 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
49938 ENDIF
49939 200 CONTINUE
49940 ENDIF
49941 210 CONTINUE
49942
49943C...R-parity violating (3-body) decays.
49944 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
49945
49946 IKNT=LKNT
49947 XLAM(0)=0D0
49948 DO 220 I=1,IKNT
49949 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49950 XLAM(0)=XLAM(0)+XLAM(I)
49951 220 CONTINUE
49952 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
49953
49954 RETURN
49955 END
49956
49957
49958C*********************************************************************
49959
49960C...PYTBBN
49961C...Calculates the three-body decay of gluinos into
49962C...neutralinos and third generation fermions.
49963
49964 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
49965
49966C...Double precision and integer declarations.
49967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49968 IMPLICIT INTEGER(I-N)
49969 INTEGER PYK,PYCHGE,PYCOMP
49970C...Parameter statement to help give large particle numbers.
49971 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49972 &KEXCIT=4000000,KDIMEN=5000000)
49973C...Commonblocks.
49974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49975 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49976 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49977 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49978 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49979 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49980
49981C...Local variables.
49982 EXTERNAL PYSIMP,PYLAMF
49983 DOUBLE PRECISION PYSIMP,PYLAMF
49984 INTEGER LIN,NN
49985 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
49986 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
49987 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
49988 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
49989 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
49990 DOUBLE PRECISION XLN1,XLN2,B1,B2
49991 DOUBLE PRECISION E,XMGLU,GAM
49992 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
49993 SAVE HRB,HLB,FLB,FRB
49994 DOUBLE PRECISION ALPHAW,ALPHAS
49995 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
49996 SAVE HLT,HRT,FLT,FRT
49997 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
49998 SAVE AMN,AN,ZN
49999 DOUBLE PRECISION AMBOT,SINC,COSC
50000 DOUBLE PRECISION AMTOP,SINA,COSA
50001 DOUBLE PRECISION SINW,COSW,TANW
50002 DOUBLE PRECISION ROT1(4,4)
50003 LOGICAL IFIRST
50004 SAVE IFIRST
50005 DATA IFIRST/.TRUE./
50006
50007 TANB=RMSS(5)
50008 SINB=TANB/SQRT(1D0+TANB**2)
50009 COSB=SINB/TANB
50010 XW=PARU(102)
50011 SINW=SQRT(XW)
50012 COSW=SQRT(1D0-XW)
50013 TANW=SINW/COSW
50014 AMW=PMAS(24,1)
50015 COSC=SFMIX(5,1)
50016 SINC=SFMIX(5,3)
50017 COSA=SFMIX(6,1)
50018 SINA=SFMIX(6,3)
50019 AMBOT=PYMRUN(5,XMGLU**2)
50020 AMTOP=PYMRUN(6,XMGLU**2)
50021 W2=SQRT(2D0)
50022 FAKT1=AMBOT/W2/AMW/COSB
50023 FAKT2=AMTOP/W2/AMW/SINB
50024 IF(IFIRST) THEN
50025 DO 110 II=1,4
50026 AMN(II)=SMZ(II)
50027 DO 100 J=1,4
50028 ROT1(II,J)=0D0
50029 AN(II,J)=0D0
50030 100 CONTINUE
50031 110 CONTINUE
50032 ROT1(1,1)=COSW
50033 ROT1(1,2)=-SINW
50034 ROT1(2,1)=-ROT1(1,2)
50035 ROT1(2,2)=ROT1(1,1)
50036 ROT1(3,3)=COSB
50037 ROT1(3,4)=SINB
50038 ROT1(4,3)=-ROT1(3,4)
50039 ROT1(4,4)=ROT1(3,3)
50040 DO 140 II=1,4
50041 DO 130 J=1,4
50042 DO 120 JJ=1,4
50043 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
50044 120 CONTINUE
50045 130 CONTINUE
50046 140 CONTINUE
50047 DO 150 J=1,4
50048 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
50049 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50050 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
50051 & XW)*AN(J,2)/COSW
50052 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
50053 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
50054 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
50055 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
50056C FLU(J)=ZN(3)
50057C FRU(J)=ZN(2)
50058 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
50059 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50060 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
50061 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
50062 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
50063 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
50064 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
50065C FLD(J)=ZN(3)
50066C FRD(J)=ZN(2)
50067 150 CONTINUE
50068C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50069C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50070C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50071C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50072 IFIRST=.FALSE.
50073 ENDIF
50074
50075 IF(NINT(3D0*E).EQ.2) THEN
50076 HL=HLT(I)
50077 HR=HRT(I)
50078 FL=FLT(I)
50079 FR=FRT(I)
50080 COSD=SFMIX(6,1)
50081 SIND=SFMIX(6,3)
50082 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
50083 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
50084 XM=PMAS(6,1)
50085 ELSE
50086 HL=HLB(I)
50087 HR=HRB(I)
50088 FL=FLB(I)
50089 FR=FRB(I)
50090 COSD=SFMIX(5,1)
50091 SIND=SFMIX(5,3)
50092 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
50093 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
50094 XM=PMAS(5,1)
50095 ENDIF
50096 COSD2=COSD*COSD
50097 SIND2=SIND*SIND
50098 COS2D=COSD2-SIND2
50099 SIN2D=SIND*COSD*2D0
50100 HL2=HL*HL
50101 HR2=HR*HR
50102 FL2=FL*FL
50103 FR2=FR*FR
50104 FF=FL*FR
50105 HH=HL*HR
50106 HFL=HL*FL
50107 HFR=HR*FR
50108 HRFL=HR*FL
50109 HLFR=HL*FR
50110 XM2=XM*XM
50111 XMG=XMGLU
50112 XMG2=XMG*XMG
50113 ALPHAW=PYALEM(XMG2)
50114 ALPHAS=PYALPS(XMG2)
50115 XMR=AMN(I)
50116 XMR2=XMR*XMR
50117 XMQ4=XMG*XM2*XMR
50118 XM24=(XMG2+XM2)*(XM2+XMR2)
50119 SMIN=4D0*XM2
50120 SMAX=(XMG-ABS(XMR))**2
50121 XMQA=XMG2+2D0*XM2+XMR2
50122 DO 170 LIN=1,NN-1
50123 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50124 GRS=SBAR-XMQA
50125 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
50126 W=DSQRT(W)
50127 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
50128 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
50129 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
50130 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
50131 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
50132 & +2D0*(FF*SIND2-HH*COSD2))*W
50133 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
50134 & +4D0*HFL*XM*XMR)*XLN1
50135 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
50136 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
50137 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
50138 & +8D0*HFL*XMQ4*SIN2D)*B1
50139 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
50140 & +4D0*HFR*XMR*XM)*XLN2
50141 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
50142 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
50143 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
50144 & -8D0*HFR*XMQ4*SIN2D)*B2
50145 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
50146 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
50147 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
50148 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
50149 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
50150 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
50151 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
50152 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
50153 G(5)=(2D0*(HH*COSD2-FF*SIND2)
50154 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
50155 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
50156 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
50157 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
50158 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
50159 & +COS2D*XM*(SBAR+XMG2-XMR2))
50160 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
50161 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
50162 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
50163 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
50164 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
50165 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
50166 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
50167 SUMME(LIN)=0D0
50168 DO 160 J=0,6
50169 SUMME(LIN)=SUMME(LIN)+G(J)
50170 160 CONTINUE
50171 170 CONTINUE
50172 SUMME(0)=0D0
50173 SUMME(NN)=0D0
50174 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50175 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50176
50177 RETURN
50178 END
50179
50180C*********************************************************************
50181
50182C...PYTBBC
50183C...Calculates the three-body decay of gluinos into
50184C...charginos and third generation fermions.
50185
50186 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
50187
50188C...Double precision and integer declarations.
50189 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50190 IMPLICIT INTEGER(I-N)
50191 INTEGER PYK,PYCHGE,PYCOMP
50192C...Parameter statement to help give large particle numbers.
50193 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50194 &KEXCIT=4000000,KDIMEN=5000000)
50195C...Commonblocks.
50196 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50197 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50198 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50199 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50200 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50201 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50202
50203C...Local variables.
50204 EXTERNAL PYSIMP,PYLAMF
50205 DOUBLE PRECISION PYSIMP,PYLAMF
50206 INTEGER I,NN,LIN
50207 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
50208 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
50209 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
50210 DOUBLE PRECISION SUMME(0:100),A(4,8)
50211 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
50212 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
50213 DOUBLE PRECISION XMGLU,GAM
50214 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
50215 &DDD(2),EEE(2),FFF(2)
50216 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
50217 DOUBLE PRECISION ALPHAW,ALPHAS
50218 DOUBLE PRECISION AMC(2)
50219 SAVE AMC
50220 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
50221 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
50222 SAVE AMSB,AMST
50223 LOGICAL IFIRST
50224 SAVE IFIRST
50225 DATA IFIRST/.TRUE./
50226
50227 TANB=RMSS(5)
50228 SINB=TANB/SQRT(1D0+TANB**2)
50229 COSB=SINB/TANB
50230 XW=PARU(102)
50231 AMW=PMAS(24,1)
50232 COSC=SFMIX(5,1)
50233 SINC=SFMIX(5,3)
50234 COSA=SFMIX(6,1)
50235 SINA=SFMIX(6,3)
50236 AMBOT=PYMRUN(5,XMGLU**2)
50237 AMTOP=PYMRUN(6,XMGLU**2)
50238 W2=SQRT(2D0)
50239 AMW=PMAS(24,1)
50240 FAKT1=AMBOT/W2/AMW/COSB
50241 FAKT2=AMTOP/W2/AMW/SINB
50242 IF(IFIRST) THEN
50243 AMC(1)=SMW(1)
50244 AMC(2)=SMW(2)
50245 DO 100 JJ=1,2
50246 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
50247 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
50248 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
50249 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
50250 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
50251 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
50252 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
50253 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
50254 100 CONTINUE
50255 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50256 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50257 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50258 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50259 IFIRST=.FALSE.
50260 ENDIF
50261
50262 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
50263 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
50264 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
50265 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
50266
50267 COS2A=COSA**2-SINA**2
50268 SIN2A=SINA*COSA*2D0
50269 COS2C=COSC**2-SINC**2
50270 SIN2C=SINC*COSC*2D0
50271
50272 XMG=XMGLU
50273 XMT=PMAS(6,1)
50274 XMB=PMAS(5,1)
50275 XMR=AMC(I)
50276 XMG2=XMG*XMG
50277 ALPHAW=PYALEM(XMG2)
50278 ALPHAS=PYALPS(XMG2)
50279 XMT2=XMT*XMT
50280 XMB2=XMB*XMB
50281 XMR2=XMR*XMR
50282 XMQ2=XMG2+XMT2+XMB2+XMR2
50283 XMQ4=XMG*XMT*XMB*XMR
50284 XMQ3=XMG2*XMR2+XMT2*XMB2
50285 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
50286 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
50287
50288 XMST(1)=AMST(1)*AMST(1)
50289 XMST(2)=AMST(1)*AMST(1)
50290 XMST(3)=AMST(2)*AMST(2)
50291 XMST(4)=AMST(2)*AMST(2)
50292 XMSB(1)=AMSB(1)*AMSB(1)
50293 XMSB(2)=AMSB(2)*AMSB(2)
50294 XMSB(3)=AMSB(1)*AMSB(1)
50295 XMSB(4)=AMSB(2)*AMSB(2)
50296
50297 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
50298 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
50299 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
50300 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
50301 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
50302 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
50303 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
50304 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
50305
50306 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
50307 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
50308 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
50309 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
50310 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
50311 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
50312 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
50313 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
50314
50315 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
50316 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
50317 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
50318 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
50319 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
50320 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
50321 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
50322 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
50323
50324 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
50325 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
50326 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
50327 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
50328 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
50329 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
50330 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
50331 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
50332
50333 SMAX=(XMG-ABS(XMR))**2
50334 SMIN=(XMB+XMT)**2+0.1D0
50335
50336 DO 120 LIN=0,NN-1
50337 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50338 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
50339 GRS=SBAR-XMQ2
50340 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
50341 W=DSQRT(W)/2D0/SBAR
50342 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
50343 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
50344 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
50345 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
50346 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
50347 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
50348 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
50349 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
50350 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
50351 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
50352 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
50353 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
50354 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
50355 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
50356 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
50357 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
50358 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
50359 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
50360 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
50361 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
50362 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
50363 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
50364 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
50365 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
50366 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
50367 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
50368 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
50369 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
50370 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
50371 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
50372 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
50373 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
50374 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
50375 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
50376 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
50377 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
50378 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
50379 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
50380 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
50381 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
50382 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
50383 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
50384 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
50385 DO 110 J=1,4
50386 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
50387 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
50388 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
50389 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
50390 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
50391 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
50392 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
50393 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
50394 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
50395 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
50396 & -A(J,6)*(XMG2+XMR2-SBAR)
50397 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
50398 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
50399 & /(GRS+XMSB(J)+XMST(J))
50400 110 CONTINUE
50401 120 CONTINUE
50402 SUMME(NN)=0D0
50403 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50404 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50405
50406 RETURN
50407 END
50408
50409C*********************************************************************
50410
50411C...PYNJDC
50412C...Calculates decay widths for the neutralinos (admixtures of
50413C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
50414
50415C...Input: KCIN = KF code for particle
50416C...Output: XLAM = widths
50417C... IDLAM = KF codes for decay particles
50418C... IKNT = number of decay channels defined
50419C...AUTHOR: STEPHEN MRENNA
50420C...Last change:
50421C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
50422C...when CHIGAMMA .NE. 0
50423C...10 FEB 96: Calculate this decay for small tan(beta)
50424
50425 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
50426
50427C...Double precision and integer declarations.
50428 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50429 IMPLICIT INTEGER(I-N)
50430 INTEGER PYK,PYCHGE,PYCOMP
50431C...Parameter statement to help give large particle numbers.
50432 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50433 &KEXCIT=4000000,KDIMEN=5000000)
50434C...Commonblocks.
50435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50437 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50438c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50439c &SFMIX(16,4)
50440 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50441 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50442C COMMON/PYINTS/XXM(20)
50443 COMPLEX*16 CXC
50444 COMMON/PYINTC/XXC(10),CXC(8)
50445 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50446
50447C...Local variables.
50448 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50449 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
50450 INTEGER KFIN
50451 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50452 &XMZ,XMZ2,AXMJ,AXMI
50453 DOUBLE PRECISION S12MIN,S12MAX
50454 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
50455 DOUBLE PRECISION PYLAMF,XL
50456 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
50457 DOUBLE PRECISION PYX2XH,PYX2XG
50458 DOUBLE PRECISION XLAM(0:400)
50459 INTEGER IDLAM(400,3)
50460 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
50461 INTEGER ITH(3),KF1,KF2
50462 INTEGER ITHC
50463 DOUBLE PRECISION DH(3),EH(3)
50464 DOUBLE PRECISION SR2
50465 DOUBLE PRECISION CBETA,SBETA
50466 DOUBLE PRECISION GAMCON,XMT1,XMT2
50467 DOUBLE PRECISION PYALEM,PI,PYALPS
50468 DOUBLE PRECISION RAT1,RAT2
50469 DOUBLE PRECISION T3T,FCOL
50470 DOUBLE PRECISION ALFA,BETA,TANB
50471 DOUBLE PRECISION PYXXGA
50472 EXTERNAL PYGAUS,PYXXZ6
50473 DOUBLE PRECISION PYGAUS,PYXXZ6
50474 DOUBLE PRECISION PREC
50475 INTEGER KFNCHI(4),KFCCHI(2)
50476 DATA ITH/25,35,36/
50477 DATA ITHC/37/
50478 DATA PREC/1D-2/
50479 DATA PI/3.141592654D0/
50480 DATA SR2/1.4142136D0/
50481 DATA KFNCHI/1000022,1000023,1000025,1000035/
50482 DATA KFCCHI/1000024,1000037/
50483
50484C...COUNT THE NUMBER OF DECAY MODES
50485 LKNT=0
50486
50487 XMW=PMAS(24,1)
50488 XMW2=XMW**2
50489 XMZ=PMAS(23,1)
50490 XMZ2=XMZ**2
50491 XW=1D0-XMW2/XMZ2
50492 XW1=1D0-XW
50493 TANW = SQRT(XW/XW1)
50494
50495C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
50496 IX=1
50497 IF(KFIN.EQ.KFNCHI(2)) IX=2
50498 IF(KFIN.EQ.KFNCHI(3)) IX=3
50499 IF(KFIN.EQ.KFNCHI(4)) IX=4
50500
50501 XMI=SMZ(IX)
50502 XMI2=XMI**2
50503 AXMI=ABS(XMI)
50504 AEM=PYALEM(XMI2)
50505 AS =PYALPS(XMI2)
50506 C1=AEM/XW
50507 XMI3=ABS(XMI**3)
50508
50509 TANB=RMSS(5)
50510 BETA=ATAN(TANB)
50511 ALFA=RMSS(18)
50512 CBETA=COS(BETA)
50513 SBETA=TANB*CBETA
50514 CALFA=COS(ALFA)
50515 SALFA=SIN(ALFA)
50516
50517 DO 110 I=1,4
50518 DO 100 J=1,4
50519 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50520 100 CONTINUE
50521 110 CONTINUE
50522 DO 130 I=1,2
50523 DO 120 J=1,2
50524 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50525 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50526 120 CONTINUE
50527 130 CONTINUE
50528
50529C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50530 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
50531
50532C...FORCE CHI0_2 -> CHI0_1 + GAMMA
50533 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
50534 XMJ=SMZ(1)
50535 AXMJ=ABS(XMJ)
50536 LKNT=LKNT+1
50537 GAMCON=AEM**3/8D0/PI/XMW2/XW
50538 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50539 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50540 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50541 IDLAM(LKNT,1)=KSUSY1+22
50542 IDLAM(LKNT,2)=22
50543 IDLAM(LKNT,3)=0
50544 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
50545 GOTO 340
50546 ENDIF
50547
50548C...GRAVITINO DECAY MODES
50549
50550 IF(IMSS(11).EQ.1) THEN
50551 XMP=RMSS(29)
50552 IDG=39+KSUSY1
50553 XMGR=PMAS(PYCOMP(IDG),1)
50554 SINW=SQRT(XW)
50555 COSW=SQRT(1D0-XW)
50556 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50557 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
50558 LKNT=LKNT+1
50559 IDLAM(LKNT,1)=IDG
50560 IDLAM(LKNT,2)=22
50561 IDLAM(LKNT,3)=0
50562 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
50563 ENDIF
50564 IF(AXMI.GT.XMGR+XMZ) THEN
50565 LKNT=LKNT+1
50566 IDLAM(LKNT,1)=IDG
50567 IDLAM(LKNT,2)=23
50568 IDLAM(LKNT,3)=0
50569 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
50570 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
50571 & (1D0-XMZ2/XMI2)**4
50572 ENDIF
50573 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
50574 LKNT=LKNT+1
50575 IDLAM(LKNT,1)=IDG
50576 IDLAM(LKNT,2)=25
50577 IDLAM(LKNT,3)=0
50578 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
50579 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
50580 ENDIF
50581 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
50582 LKNT=LKNT+1
50583 IDLAM(LKNT,1)=IDG
50584 IDLAM(LKNT,2)=35
50585 IDLAM(LKNT,3)=0
50586 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
50587 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
50588 ENDIF
50589 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
50590 LKNT=LKNT+1
50591 IDLAM(LKNT,1)=IDG
50592 IDLAM(LKNT,2)=36
50593 IDLAM(LKNT,3)=0
50594 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
50595 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
50596 ENDIF
50597 IF(IX.EQ.1) GOTO 300
50598 ENDIF
50599
50600 DO 220 IJ=1,IX-1
50601 XMJ=SMZ(IJ)
50602 AXMJ=ABS(XMJ)
50603 XMJ2=XMJ**2
50604
50605C...CHI0_I -> CHI0_J + GAMMA
50606 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
50607 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
50608 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
50609 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
50610 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
50611 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
50612 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
50613 LKNT=LKNT+1
50614 IDLAM(LKNT,1)=KFNCHI(IJ)
50615 IDLAM(LKNT,2)=22
50616 IDLAM(LKNT,3)=0
50617 GAMCON=AEM**3/8D0/PI/XMW2/XW
50618 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50619 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50620 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50621 ENDIF
50622 ENDIF
50623
50624C...CHI0_I -> CHI0_J + Z0
50625 IF(AXMI.GE.AXMJ+XMZ) THEN
50626 LKNT=LKNT+1
50627 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50628 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50629 ORPP=-DCONJG(OLPP)
50630 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50631 GLR=DBLE(OLPP*DCONJG(ORPP))
50632 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50633 IDLAM(LKNT,1)=KFNCHI(IJ)
50634 IDLAM(LKNT,2)=23
50635 IDLAM(LKNT,3)=0
50636 ELSEIF(AXMI.GE.AXMJ) THEN
50637 XXC(1)=0D0
50638 XXC(2)=XMJ
50639 XXC(3)=0D0
50640 XXC(4)=XMI
50641 XXC(9)=XMZ
50642 XXC(10)=PMAS(23,2)
50643 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50644 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50645 ORPP=DCONJG(OLPP)
50646C...CHARGED LEPTONS
50647 FID=11
50648 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50649 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50650 EI=KCHG(FID,1)/3D0
50651 T3I=SIGN(1D0,EI+1D-6)/2D0
50652 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50653 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50654 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50655 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50656 CXC(2)=-GLIJ
50657 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50658 CXC(4)=DCONJG(GLIJ)
50659 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50660 CXC(6)=GRIJ
50661 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50662 CXC(8)=-DCONJG(GRIJ)
50663 S12MIN=0D0
50664 S12MAX=(AXMI-AXMJ)**2
50665 IF( XXC(5).LT.AXMI ) THEN
50666 XXC(5)=1D6
50667 ENDIF
50668 IF(XXC(6).LT.AXMI ) THEN
50669 XXC(6)=1D6
50670 ENDIF
50671 XXC(7)=XXC(5)
50672 XXC(8)=XXC(6)
50673
50674 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50675 LKNT=LKNT+1
50676 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50677 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50678 IDLAM(LKNT,1)=KFNCHI(IJ)
50679 IDLAM(LKNT,2)=FID
50680 IDLAM(LKNT,3)=-FID
50681 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50682 LKNT=LKNT+1
50683 XLAM(LKNT)=XLAM(LKNT-1)
50684 IDLAM(LKNT,1)=KFNCHI(IJ)
50685 IDLAM(LKNT,2)=13
50686 IDLAM(LKNT,3)=-13
50687 ENDIF
50688 ENDIF
50689 140 CONTINUE
50690 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50691 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50692 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50693 ELSE
50694 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50695 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50696 ENDIF
50697 IF( XXC(5).LT.AXMI ) THEN
50698 XXC(5)=1D6
50699 ENDIF
50700 IF(XXC(6).LT.AXMI ) THEN
50701 XXC(6)=1D6
50702 ENDIF
50703 XXC(7)=XXC(5)
50704 XXC(8)=XXC(6)
50705
50706 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50707 LKNT=LKNT+1
50708 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50709 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50710 IDLAM(LKNT,1)=KFNCHI(IJ)
50711 IDLAM(LKNT,2)=15
50712 IDLAM(LKNT,3)=-15
50713 ENDIF
50714
50715C...NEUTRINOS
50716 150 CONTINUE
50717 FID=12
50718 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50719 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50720 EI=KCHG(FID,1)/3D0
50721 T3I=SIGN(1D0,EI+1D-6)/2D0
50722 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50723 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50724 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50725 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50726 CXC(2)=-GLIJ
50727 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50728 CXC(4)=DCONJG(GLIJ)
50729 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50730 CXC(6)=GRIJ
50731 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50732 CXC(8)=-DCONJG(GRIJ)
50733 S12MIN=0D0
50734 S12MAX=(AXMI-AXMJ)**2
50735 IF( XXC(5).LT.AXMI ) THEN
50736 XXC(5)=1D6
50737 ENDIF
50738 IF( XXC(6).LT.AXMI ) THEN
50739 XXC(6)=1D6
50740 ENDIF
50741 XXC(7)=XXC(5)
50742 XXC(8)=XXC(6)
50743
50744 LKNT=LKNT+1
50745 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50746 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50747 IDLAM(LKNT,1)=KFNCHI(IJ)
50748 IDLAM(LKNT,2)=12
50749 IDLAM(LKNT,3)=-12
50750 LKNT=LKNT+1
50751 XLAM(LKNT)=XLAM(LKNT-1)
50752 IDLAM(LKNT,1)=KFNCHI(IJ)
50753 IDLAM(LKNT,2)=14
50754 IDLAM(LKNT,3)=-14
50755 160 CONTINUE
50756
50757 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
50758 & THEN
50759 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50760 IF( XXC(5).LT.AXMI ) THEN
50761 XXC(5)=1D6
50762 ENDIF
50763 XXC(7)=XXC(5)
50764 LKNT=LKNT+1
50765 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50766 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50767 ELSE
50768 LKNT=LKNT+1
50769 XLAM(LKNT)=XLAM(LKNT-1)
50770 ENDIF
50771 IDLAM(LKNT,1)=KFNCHI(IJ)
50772 IDLAM(LKNT,2)=16
50773 IDLAM(LKNT,3)=-16
50774C...D-TYPE QUARKS
50775 170 CONTINUE
50776 FID=1
50777 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50778 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50779 EI=KCHG(FID,1)/3D0
50780 T3I=SIGN(1D0,EI+1D-6)/2D0
50781 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50782 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50783 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50784 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50785 CXC(2)=-GLIJ
50786 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50787 CXC(4)=DCONJG(GLIJ)
50788 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50789 CXC(6)=GRIJ
50790 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50791 CXC(8)=-DCONJG(GRIJ)
50792 S12MIN=0D0
50793 S12MAX=(AXMI-AXMJ)**2
50794 IF( XXC(5).LT.AXMI ) THEN
50795 XXC(5)=1D6
50796 ENDIF
50797 IF( XXC(6).LT.AXMI ) THEN
50798 XXC(6)=1D6
50799 ENDIF
50800 XXC(7)=XXC(5)
50801 XXC(8)=XXC(6)
50802
50803 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50804 LKNT=LKNT+1
50805 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50806 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50807 IDLAM(LKNT,1)=KFNCHI(IJ)
50808 IDLAM(LKNT,2)=1
50809 IDLAM(LKNT,3)=-1
50810 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50811 LKNT=LKNT+1
50812 XLAM(LKNT)=XLAM(LKNT-1)
50813 IDLAM(LKNT,1)=KFNCHI(IJ)
50814 IDLAM(LKNT,2)=3
50815 IDLAM(LKNT,3)=-3
50816 ENDIF
50817 ENDIF
50818 180 CONTINUE
50819 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50820 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50821 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50822 ELSE
50823 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50824 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50825 ENDIF
50826 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50827 IF(XXC(5).LT.AXMI) THEN
50828 XXC(5)=1D6
50829 ELSEIF(XXC(6).LT.AXMI) THEN
50830 XXC(6)=1D6
50831 ENDIF
50832 XXC(7)=XXC(5)
50833 XXC(8)=XXC(6)
50834 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50835 LKNT=LKNT+1
50836 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50837 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50838 IDLAM(LKNT,1)=KFNCHI(IJ)
50839 IDLAM(LKNT,2)=5
50840 IDLAM(LKNT,3)=-5
50841 ENDIF
50842
50843C...U-TYPE QUARKS
50844 190 CONTINUE
50845 FID=2
50846 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50847 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50848 EI=KCHG(FID,1)/3D0
50849 T3I=SIGN(1D0,EI+1D-6)/2D0
50850 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50851 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50852 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50853 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50854 CXC(2)=-GLIJ
50855 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50856 CXC(4)=DCONJG(GLIJ)
50857 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50858 CXC(6)=GRIJ
50859 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50860 CXC(8)=-DCONJG(GRIJ)
50861
50862 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
50863 IF(XXC(5).LT.AXMI) THEN
50864 XXC(5)=1D6
50865 ELSEIF(XXC(6).LT.AXMI) THEN
50866 XXC(6)=1D6
50867 ENDIF
50868 XXC(7)=XXC(5)
50869 XXC(8)=XXC(6)
50870
50871 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50872 LKNT=LKNT+1
50873 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50874 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50875 IDLAM(LKNT,1)=KFNCHI(IJ)
50876 IDLAM(LKNT,2)=2
50877 IDLAM(LKNT,3)=-2
50878 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50879 LKNT=LKNT+1
50880 XLAM(LKNT)=XLAM(LKNT-1)
50881 IDLAM(LKNT,1)=KFNCHI(IJ)
50882 IDLAM(LKNT,2)=4
50883 IDLAM(LKNT,3)=-4
50884 ENDIF
50885 ENDIF
50886 200 CONTINUE
50887 ENDIF
50888
50889C...CHI0_I -> CHI0_J + H0_K
50890 EH(1)=SIN(ALFA)
50891 EH(2)=COS(ALFA)
50892 EH(3)=-SIN(BETA)
50893 DH(1)=COS(ALFA)
50894 DH(2)=-SIN(ALFA)
50895 DH(3)=COS(BETA)
50896 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
50897 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
50898 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
50899 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
50900 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
50901 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
50902 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
50903 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
50904 DO 210 IH=1,3
50905 XMH=PMAS(ITH(IH),1)
50906 XMH2=XMH**2
50907 IF(AXMI.GE.AXMJ+XMH) THEN
50908 LKNT=LKNT+1
50909 XL=PYLAMF(XMI2,XMJ2,XMH2)
50910 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
50911 F12K=F21K
50912C...SIGN OF MASSES I,J
50913 XMK=XMJ
50914 IF(IH.EQ.3) XMK=-XMK
50915 GX2=ABS(F21K)**2+ABS(F12K)**2
50916 GLR=DBLE(F21K*DCONJG(F12K))
50917 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50918 IDLAM(LKNT,1)=KFNCHI(IJ)
50919 IDLAM(LKNT,2)=ITH(IH)
50920 IDLAM(LKNT,3)=0
50921 ENDIF
50922 210 CONTINUE
50923 220 CONTINUE
50924
50925C...CHI0_I -> CHI+_J + W-
50926 DO 260 IJ=1,2
50927 XMJ=SMW(IJ)
50928 AXMJ=ABS(XMJ)
50929 XMJ2=XMJ**2
50930 IF(AXMI.GE.AXMJ+XMW) THEN
50931 LKNT=LKNT+1
50932 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50933 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
50934 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50935 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
50936 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50937 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50938 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50939 IDLAM(LKNT,1)=KFCCHI(IJ)
50940 IDLAM(LKNT,2)=-24
50941 IDLAM(LKNT,3)=0
50942 LKNT=LKNT+1
50943 XLAM(LKNT)=XLAM(LKNT-1)
50944 IDLAM(LKNT,1)=-KFCCHI(IJ)
50945 IDLAM(LKNT,2)=24
50946 IDLAM(LKNT,3)=0
50947 ELSEIF(AXMI.GE.AXMJ) THEN
50948 S12MIN=0D0
50949 S12MAX=(AXMI-AXMJ)**2
50950 RT2I = 1D0/SQRT(2D0)
50951 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50952 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
50953 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50954 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
50955 CXC(5)=DCMPLX(0D0,0D0)
50956 CXC(7)=DCMPLX(0D0,0D0)
50957 IA=11
50958 JA=12
50959 EI=KCHG(IA,1)/3D0
50960 T3I=SIGN(1D0,EI+1D-6)/2D0
50961 EJ=KCHG(JA,1)/3D0
50962 T3J=SIGN(1D0,EJ+1D-6)/2D0
50963 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
50964 & TANW+ZMIXC(IX,2)*T3J)*RT2I
50965 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
50966 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
50967 CXC(6)=DCMPLX(0D0,0D0)
50968 CXC(8)=DCMPLX(0D0,0D0)
50969 XXC(1)=0D0
50970 XXC(2)=XMJ
50971 XXC(3)=0D0
50972 XXC(4)=XMI
50973 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50974 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50975 XXC(9)=PMAS(24,1)
50976 XXC(10)=PMAS(24,2)
50977 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
50978 IF(XXC(5).LT.AXMI) THEN
50979 XXC(5)=1D6
50980 ELSEIF(XXC(6).LT.AXMI) THEN
50981 XXC(6)=1D6
50982 ENDIF
50983 XXC(7)=XXC(6)
50984 XXC(8)=XXC(5)
50985 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50986 LKNT=LKNT+1
50987 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50988 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50989 IDLAM(LKNT,1)=KFCCHI(IJ)
50990 IDLAM(LKNT,2)=11
50991 IDLAM(LKNT,3)=-12
50992 LKNT=LKNT+1
50993 XLAM(LKNT)=XLAM(LKNT-1)
50994 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50995 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50996 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50997 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50998 LKNT=LKNT+1
50999 XLAM(LKNT)=XLAM(LKNT-1)
51000 IDLAM(LKNT,1)=KFCCHI(IJ)
51001 IDLAM(LKNT,2)=13
51002 IDLAM(LKNT,3)=-14
51003 LKNT=LKNT+1
51004 XLAM(LKNT)=XLAM(LKNT-1)
51005 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51006 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51007 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51008 ENDIF
51009 ENDIF
51010 230 CONTINUE
51011 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51012 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51013 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51014 ELSE
51015 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51016 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51017 ENDIF
51018 IF(XXC(5).LT.AXMI) THEN
51019 XXC(5)=1D6
51020 ENDIF
51021 IF(XXC(6).LT.AXMI) THEN
51022 XXC(6)=1D6
51023 ENDIF
51024 XXC(7)=XXC(6)
51025 XXC(8)=XXC(5)
51026 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51027 LKNT=LKNT+1
51028 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51029 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51030 XLAM(LKNT)=XLAM(LKNT-1)
51031 IDLAM(LKNT,1)=KFCCHI(IJ)
51032 IDLAM(LKNT,2)=15
51033 IDLAM(LKNT,3)=-16
51034 LKNT=LKNT+1
51035 XLAM(LKNT)=XLAM(LKNT-1)
51036 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51037 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51038 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51039 ENDIF
51040
51041C...NOW, DO THE QUARKS
51042 240 CONTINUE
51043 IA=1
51044 JA=2
51045 EI=KCHG(IA,1)/3D0
51046 T3I=SIGN(1D0,EI+1D-6)/2D0
51047 EJ=KCHG(JA,1)/3D0
51048 T3J=SIGN(1D0,EJ+1D-6)/2D0
51049 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51050 & TANW+ZMIXC(IX,2)*T3J)
51051 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51052 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
51053 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51054 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
51055 IF(XXC(5).LT.AXMI) THEN
51056 XXC(5)=1D6
51057 ENDIF
51058 IF(XXC(6).LT.AXMI) THEN
51059 XXC(6)=1D6
51060 ENDIF
51061 XXC(7)=XXC(6)
51062 XXC(8)=XXC(5)
51063 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
51064 LKNT=LKNT+1
51065 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51066 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51067 IDLAM(LKNT,1)=KFCCHI(IJ)
51068 IDLAM(LKNT,2)=1
51069 IDLAM(LKNT,3)=-2
51070 LKNT=LKNT+1
51071 XLAM(LKNT)=XLAM(LKNT-1)
51072 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51073 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51074 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51075 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51076 LKNT=LKNT+1
51077 XLAM(LKNT)=XLAM(LKNT-1)
51078 IDLAM(LKNT,1)=KFCCHI(IJ)
51079 IDLAM(LKNT,2)=3
51080 IDLAM(LKNT,3)=-4
51081 LKNT=LKNT+1
51082 XLAM(LKNT)=XLAM(LKNT-1)
51083 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51084 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51085 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51086 ENDIF
51087 ENDIF
51088 250 CONTINUE
51089 ENDIF
51090 260 CONTINUE
51091 270 CONTINUE
51092
51093C...CHI0_I -> CHI+_I + H-
51094 DO 280 IJ=1,2
51095 XMJ=SMW(IJ)
51096 AXMJ=ABS(XMJ)
51097 XMJ2=XMJ**2
51098 XMHP=PMAS(ITHC,1)
51099 IF(AXMI.GE.AXMJ+XMHP) THEN
51100 LKNT=LKNT+1
51101 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
51102 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
51103 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
51104 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
51105 & UMIXC(IJ,2)/SR2)
51106 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51107 GLR=DBLE(OLPP*DCONJG(ORPP))
51108 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51109 IDLAM(LKNT,1)=KFCCHI(IJ)
51110 IDLAM(LKNT,2)=-ITHC
51111 IDLAM(LKNT,3)=0
51112 LKNT=LKNT+1
51113 XLAM(LKNT)=XLAM(LKNT-1)
51114 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51115 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51116 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51117 ELSE
51118
51119 ENDIF
51120 280 CONTINUE
51121
51122C...2-BODY DECAYS TO FERMION SFERMION
51123 DO 290 J=1,16
51124 IF(J.GE.7.AND.J.LE.10) GOTO 290
51125 KF1=KSUSY1+J
51126 KF2=KSUSY2+J
51127 XMSF1=PMAS(PYCOMP(KF1),1)
51128 XMSF2=PMAS(PYCOMP(KF2),1)
51129 XMF=PMAS(J,1)
51130 IF(J.LE.6) THEN
51131 FCOL=3D0
51132 ELSE
51133 FCOL=1D0
51134 ENDIF
51135
51136 EI=KCHG(J,1)/3D0
51137 T3T=SIGN(1D0,EI)
51138 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
51139 IF(MOD(J,2).EQ.0) THEN
51140 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51141 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
51142 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51143 CBR=CAL
51144 ELSE
51145 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51146 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
51147 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51148 CBR=CAL
51149 ENDIF
51150
51151C...D~ D_L
51152 IF(AXMI.GE.XMF+XMSF1) THEN
51153 LKNT=LKNT+1
51154 XMA2=XMSF1**2
51155 XMB2=XMF**2
51156 XL=PYLAMF(XMI2,XMA2,XMB2)
51157 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
51158 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
51159 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51160 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51161 IDLAM(LKNT,1)=KF1
51162 IDLAM(LKNT,2)=-J
51163 IDLAM(LKNT,3)=0
51164 LKNT=LKNT+1
51165 XLAM(LKNT)=XLAM(LKNT-1)
51166 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51167 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51168 IDLAM(LKNT,3)=0
51169 ENDIF
51170
51171C...D~ D_R
51172 IF(AXMI.GE.XMF+XMSF2) THEN
51173 LKNT=LKNT+1
51174 XMA2=XMSF2**2
51175 XMB2=XMF**2
51176 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
51177 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
51178 XL=PYLAMF(XMI2,XMA2,XMB2)
51179 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51180 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51181 IDLAM(LKNT,1)=KF2
51182 IDLAM(LKNT,2)=-J
51183 IDLAM(LKNT,3)=0
51184 LKNT=LKNT+1
51185 XLAM(LKNT)=XLAM(LKNT-1)
51186 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51187 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51188 IDLAM(LKNT,3)=0
51189 ENDIF
51190 290 CONTINUE
51191 300 CONTINUE
51192C...3-BODY DECAY TO Q Q~ GLUINO
51193 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51194 IF(AXMI.GE.XMJ) THEN
51195 RT2I = 1D0/SQRT(2D0)
51196 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
51197 ORPP=DCONJG(OLPP)
51198 AXMJ=ABS(XMJ)
51199 XXC(1)=0D0
51200 XXC(2)=XMJ
51201 XXC(3)=0D0
51202 XXC(4)=XMI
51203 FID=1
51204 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51205 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51206 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
51207 XXC(7)=XXC(5)
51208 XXC(8)=XXC(6)
51209 XXC(9)=1D6
51210 XXC(10)=0D0
51211 EI=KCHG(FID,1)/3D0
51212 T3I=SIGN(1D0,EI+1D-6)/2D0
51213 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51214 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51215 CXC(1)=0D0
51216 CXC(2)=-GLIJ
51217 CXC(3)=0D0
51218 CXC(4)=DCONJG(GLIJ)
51219 CXC(5)=0D0
51220 CXC(6)=GRIJ
51221 CXC(7)=0D0
51222 CXC(8)=-DCONJG(GRIJ)
51223 S12MIN=0D0
51224 S12MAX=(AXMI-AXMJ)**2
51225C...ALL QUARKS BUT T
51226 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51227 LKNT=LKNT+1
51228 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51229 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51230 IDLAM(LKNT,1)=KSUSY1+21
51231 IDLAM(LKNT,2)=1
51232 IDLAM(LKNT,3)=-1
51233 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51234 LKNT=LKNT+1
51235 XLAM(LKNT)=XLAM(LKNT-1)
51236 IDLAM(LKNT,1)=KSUSY1+21
51237 IDLAM(LKNT,2)=3
51238 IDLAM(LKNT,3)=-3
51239 ENDIF
51240 ENDIF
51241 310 CONTINUE
51242 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51243 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51244 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51245 ELSE
51246 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51247 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51248 ENDIF
51249 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
51250 XXC(7)=XXC(5)
51251 XXC(8)=XXC(6)
51252 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51253 LKNT=LKNT+1
51254 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51255 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51256 IDLAM(LKNT,1)=KSUSY1+21
51257 IDLAM(LKNT,2)=5
51258 IDLAM(LKNT,3)=-5
51259 ENDIF
51260C...U-TYPE QUARKS
51261 320 CONTINUE
51262 FID=2
51263 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51264 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51265 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
51266 XXC(7)=XXC(5)
51267 XXC(8)=XXC(6)
51268 EI=KCHG(FID,1)/3D0
51269 T3I=SIGN(1D0,EI+1D-6)/2D0
51270 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51271 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51272 CXC(2)=-GLIJ
51273 CXC(4)=DCONJG(GLIJ)
51274 CXC(6)=GRIJ
51275 CXC(8)=-DCONJG(GRIJ)
51276 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51277 LKNT=LKNT+1
51278 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51279 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51280 IDLAM(LKNT,1)=KSUSY1+21
51281 IDLAM(LKNT,2)=2
51282 IDLAM(LKNT,3)=-2
51283 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51284 LKNT=LKNT+1
51285 XLAM(LKNT)=XLAM(LKNT-1)
51286 IDLAM(LKNT,1)=KSUSY1+21
51287 IDLAM(LKNT,2)=4
51288 IDLAM(LKNT,3)=-4
51289 ENDIF
51290 ENDIF
51291 330 CONTINUE
51292 ENDIF
51293
51294C...R-violating decay modes (SKANDS).
51295 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
51296
51297 340 IKNT=LKNT
51298 XLAM(0)=0D0
51299 DO 350 I=1,IKNT
51300 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51301 XLAM(0)=XLAM(0)+XLAM(I)
51302 350 CONTINUE
51303 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51304
51305 RETURN
51306 END
51307
51308C*********************************************************************
51309
51310C...PYCJDC
51311C...Calculate decay widths for the charginos (admixtures of
51312C...charged Wino and charged Higgsino.
51313
51314C...Input: KCIN = KF code for particle
51315C...Output: XLAM = widths
51316C... IDLAM = KF codes for decay particles
51317C... IKNT = number of decay channels defined
51318C...AUTHOR: STEPHEN MRENNA
51319C...Last change:
51320C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
51321C...when CHIENU .NE. 0
51322
51323 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
51324
51325C...Double precision and integer declarations.
51326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51327 IMPLICIT INTEGER(I-N)
51328 INTEGER PYK,PYCHGE,PYCOMP
51329C...Parameter statement to help give large particle numbers.
51330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51331 &KEXCIT=4000000,KDIMEN=5000000)
51332C...Commonblocks.
51333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51335 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51336 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51337 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51338CC &SFMIX(16,4),
51339C COMMON/PYINTS/XXM(20)
51340 COMPLEX*16 CXC
51341 COMMON/PYINTC/XXC(10),CXC(8)
51342 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51343
51344C...Local variables
51345 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51346 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
51347 INTEGER KFIN,KCIN
51348 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51349 &XMZ,XMZ2,AXMJ,AXMI
51350 DOUBLE PRECISION S12MIN,S12MAX
51351 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
51352 DOUBLE PRECISION PYLAMF,XL
51353 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
51354 DOUBLE PRECISION PYX2XH,PYX2XG
51355 DOUBLE PRECISION XLAM(0:400)
51356 INTEGER IDLAM(400,3)
51357 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
51358 INTEGER ITH(3)
51359 INTEGER ITHC
51360 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
51361 DOUBLE PRECISION SR2
51362 DOUBLE PRECISION CBETA,SBETA,TANB
51363
51364 DOUBLE PRECISION PYALEM,PI,PYALPS
51365 DOUBLE PRECISION FCOL
51366 INTEGER KF1,KF2,ISF
51367 INTEGER KFNCHI(4),KFCCHI(2)
51368
51369 DOUBLE PRECISION TEMP
51370 EXTERNAL PYGAUS,PYXXZ6
51371 DOUBLE PRECISION PYGAUS,PYXXZ6
51372 DOUBLE PRECISION PREC
51373 DATA ITH/25,35,36/
51374 DATA ITHC/37/
51375 DATA ETAH/1D0,1D0,-1D0/
51376 DATA SR2/1.4142136D0/
51377 DATA PI/3.141592654D0/
51378 DATA PREC/1D-2/
51379 DATA KFNCHI/1000022,1000023,1000025,1000035/
51380 DATA KFCCHI/1000024,1000037/
51381
51382C...COUNT THE NUMBER OF DECAY MODES
51383 LKNT=0
51384 XMW=PMAS(24,1)
51385 XMW2=XMW**2
51386 XMZ=PMAS(23,1)
51387 XMZ2=XMZ**2
51388 XW=1D0-XMW2/XMZ2
51389 XW1=1D0-XW
51390 TANW = SQRT(XW/XW1)
51391
51392C...1 OR 2 DEPENDING ON CHARGINO TYPE
51393 IX=1
51394 IF(KFIN.EQ.KFCCHI(2)) IX=2
51395 KCIN=PYCOMP(KFIN)
51396
51397 XMI=SMW(IX)
51398 XMI2=XMI**2
51399 AXMI=ABS(XMI)
51400 AEM=PYALEM(XMI2)
51401 AS =PYALPS(XMI2)
51402 C1=AEM/XW
51403 XMI3=ABS(XMI**3)
51404 TANB=RMSS(5)
51405 BETA=ATAN(TANB)
51406 CBETA=COS(BETA)
51407 SBETA=TANB*CBETA
51408 ALFA=RMSS(18)
51409
51410 DO 110 I=1,2
51411 DO 100 J=1,2
51412 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51413 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51414 100 CONTINUE
51415 110 CONTINUE
51416
51417C...GRAVITINO DECAY MODES
51418
51419 IF(IMSS(11).EQ.1) THEN
51420 XMP=RMSS(29)
51421 IDG=39+KSUSY1
51422 XMGR=PMAS(PYCOMP(IDG),1)
51423C SINW=SQRT(XW)
51424C COSW=SQRT(1D0-XW)
51425 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51426 IF(AXMI.GT.XMGR+XMW) THEN
51427 LKNT=LKNT+1
51428 IDLAM(LKNT,1)=IDG
51429 IDLAM(LKNT,2)=24
51430 IDLAM(LKNT,3)=0
51431 XLAM(LKNT)=XFAC*(
51432 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
51433 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
51434 & (1D0-XMW2/XMI2)**4
51435 ENDIF
51436 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
51437 LKNT=LKNT+1
51438 IDLAM(LKNT,1)=IDG
51439 IDLAM(LKNT,2)=37
51440 IDLAM(LKNT,3)=0
51441 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
51442 & (ABS(UMIXC(IX,2))*SBETA)**2))
51443 & *(1D0-PMAS(37,1)**2/XMI2)**4
51444 ENDIF
51445 ENDIF
51446
51447C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51448 IF(IX.EQ.1) GOTO 170
51449 XMJ=SMW(1)
51450 AXMJ=ABS(XMJ)
51451 XMJ2=XMJ**2
51452
51453C...CHI_2+ -> CHI_1+ + Z0
51454 IF(AXMI.GE.AXMJ+XMZ) THEN
51455 LKNT=LKNT+1
51456 IJ=1
51457 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51458 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51459 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51460 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51461 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51462 GLR=DBLE(OLPP*DCONJG(ORPP))
51463 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51464 IDLAM(LKNT,1)=KFCCHI(1)
51465 IDLAM(LKNT,2)=23
51466 IDLAM(LKNT,3)=0
51467
51468C...CHARGED LEPTONS
51469 ELSEIF(AXMI.GE.AXMJ) THEN
51470 S12MIN=0D0
51471 S12MAX=(AXMI-AXMJ)**2
51472 IA=11
51473 JA=12
51474 EI=KCHG(IABS(IA),1)/3D0
51475 T3I=SIGN(1D0,EI+1D-6)/2D0
51476 XXC(1)=0D0
51477 XXC(2)=XMJ
51478 XXC(3)=0D0
51479 XXC(4)=XMI
51480 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51481 XXC(6)=1D6
51482 XXC(9)=PMAS(23,1)
51483 XXC(10)=PMAS(23,2)
51484 IJ=1
51485 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51486 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51487 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51488 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51489 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51490 CXC(2)=DCMPLX(0D0,0D0)
51491 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51492 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51493 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51494 CXC(6)=DCMPLX(0D0,0D0)
51495 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51496 CXC(8)=DCMPLX(0D0,0D0)
51497 IF( XXC(5).LT.AXMI ) THEN
51498 XXC(5)=1D6
51499 ENDIF
51500 XXC(7)=XXC(5)
51501 XXC(8)=XXC(6)
51502 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51503 LKNT=LKNT+1
51504 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51505 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51506 IDLAM(LKNT,1)=KFCCHI(1)
51507 IDLAM(LKNT,2)=11
51508 IDLAM(LKNT,3)=-11
51509 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51510 LKNT=LKNT+1
51511 XLAM(LKNT)=XLAM(LKNT-1)
51512 IDLAM(LKNT,1)=KFCCHI(1)
51513 IDLAM(LKNT,2)=13
51514 IDLAM(LKNT,3)=-13
51515 ENDIF
51516 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51517 LKNT=LKNT+1
51518 XLAM(LKNT)=XLAM(LKNT-1)
51519 IDLAM(LKNT,1)=KFCCHI(1)
51520 IDLAM(LKNT,2)=15
51521 IDLAM(LKNT,3)=-15
51522 ENDIF
51523 ENDIF
51524
51525C...NEUTRINOS
51526 120 CONTINUE
51527 IA=12
51528 JA=11
51529 EI=KCHG(IABS(IA),1)/3D0
51530 T3I=SIGN(1D0,EI+1D-6)/2D0
51531 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51532 XXC(6)=1D6
51533 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51534 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51535 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51536 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51537 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51538 IF( XXC(5).LT.AXMI ) THEN
51539 XXC(5)=1D6
51540 ENDIF
51541 XXC(7)=XXC(5)
51542 XXC(8)=XXC(6)
51543 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
51544 LKNT=LKNT+1
51545 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51546 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51547 IDLAM(LKNT,1)=KFCCHI(1)
51548 IDLAM(LKNT,2)=12
51549 IDLAM(LKNT,3)=-12
51550 LKNT=LKNT+1
51551 XLAM(LKNT)=XLAM(LKNT-1)
51552 IDLAM(LKNT,1)=KFCCHI(1)
51553 IDLAM(LKNT,2)=14
51554 IDLAM(LKNT,3)=-14
51555 ENDIF
51556 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
51557 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51558 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51559 ELSE
51560 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51561 ENDIF
51562 IF( XXC(5).LT.AXMI ) THEN
51563 XXC(5)=1D6
51564 ENDIF
51565 XXC(7)=XXC(5)
51566 LKNT=LKNT+1
51567 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51568 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51569 IDLAM(LKNT,1)=KFCCHI(1)
51570 IDLAM(LKNT,2)=16
51571 IDLAM(LKNT,3)=-16
51572 ENDIF
51573
51574C...D-TYPE QUARKS
51575 130 CONTINUE
51576 IA=1
51577 JA=2
51578 EI=KCHG(IABS(IA),1)/3D0
51579 T3I=SIGN(1D0,EI+1D-6)/2D0
51580 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51581 XXC(6)=1D6
51582 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51583 CXC(2)=DCMPLX(0D0,0D0)
51584 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51585 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51586 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51587 CXC(6)=DCMPLX(0D0,0D0)
51588 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51589 CXC(8)=DCMPLX(0D0,0D0)
51590 IF( XXC(5).LT.AXMI ) THEN
51591 XXC(5)=1D6
51592 ENDIF
51593 XXC(7)=XXC(5)
51594 XXC(8)=XXC(6)
51595 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51596 LKNT=LKNT+1
51597 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51598 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51599 IDLAM(LKNT,1)=KFCCHI(1)
51600 IDLAM(LKNT,2)=1
51601 IDLAM(LKNT,3)=-1
51602 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51603 LKNT=LKNT+1
51604 XLAM(LKNT)=XLAM(LKNT-1)
51605 IDLAM(LKNT,1)=KFCCHI(1)
51606 IDLAM(LKNT,2)=3
51607 IDLAM(LKNT,3)=-3
51608 ENDIF
51609 ENDIF
51610 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51611 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51612 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51613 ELSE
51614 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51615 ENDIF
51616 IF( XXC(5).LT.AXMI ) THEN
51617 XXC(5)=1D6
51618 ENDIF
51619 XXC(7)=XXC(5)
51620 LKNT=LKNT+1
51621 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51622 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51623 IDLAM(LKNT,1)=KFCCHI(1)
51624 IDLAM(LKNT,2)=5
51625 IDLAM(LKNT,3)=-5
51626 ENDIF
51627
51628C...U-TYPE QUARKS
51629 140 CONTINUE
51630 IA=2
51631 JA=1
51632 EI=KCHG(IABS(IA),1)/3D0
51633 T3I=SIGN(1D0,EI+1D-6)/2D0
51634 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51635 XXC(6)=1D6
51636 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51637 CXC(2)=DCMPLX(0D0,0D0)
51638 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51639 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51640 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51641 CXC(6)=DCMPLX(0D0,0D0)
51642 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51643 CXC(8)=DCMPLX(0D0,0D0)
51644 IF( XXC(5).LT.AXMI ) THEN
51645 XXC(5)=1D6
51646 ENDIF
51647 XXC(7)=XXC(5)
51648 XXC(8)=XXC(6)
51649 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51650 LKNT=LKNT+1
51651 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51652 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51653 IDLAM(LKNT,1)=KFCCHI(1)
51654 IDLAM(LKNT,2)=2
51655 IDLAM(LKNT,3)=-2
51656 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51657 LKNT=LKNT+1
51658 XLAM(LKNT)=XLAM(LKNT-1)
51659 IDLAM(LKNT,1)=KFCCHI(1)
51660 IDLAM(LKNT,2)=4
51661 IDLAM(LKNT,3)=-4
51662 ENDIF
51663 ENDIF
51664 150 CONTINUE
51665 ENDIF
51666
51667C...CHI_2+ -> CHI_1+ + H0_K
51668 EH(2)=COS(ALFA)
51669 EH(1)=SIN(ALFA)
51670 EH(3)=-SBETA
51671 DH(2)=-SIN(ALFA)
51672 DH(1)=COS(ALFA)
51673 DH(3)=COS(BETA)
51674 DO 160 IH=1,3
51675 XMH=PMAS(ITH(IH),1)
51676 XMH2=XMH**2
51677C...NO 3-BODY OPTION
51678 IF(AXMI.GE.AXMJ+XMH) THEN
51679 LKNT=LKNT+1
51680 XL=PYLAMF(XMI2,XMJ2,XMH2)
51681 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
51682 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
51683 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
51684 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
51685 XMK=XMJ*ETAH(IH)
51686 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51687 GLR=DBLE(OLPP*DCONJG(ORPP))
51688 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51689 IDLAM(LKNT,1)=KFCCHI(1)
51690 IDLAM(LKNT,2)=ITH(IH)
51691 IDLAM(LKNT,3)=0
51692 ENDIF
51693 160 CONTINUE
51694
51695C...CHI1 JUMPS TO HERE
51696 170 CONTINUE
51697
51698C...CHI+_I -> CHI0_J + W+
51699 DO 220 IJ=1,4
51700 XMJ=SMZ(IJ)
51701 AXMJ=ABS(XMJ)
51702 XMJ2=XMJ**2
51703 IF(AXMI.GE.AXMJ+XMW) THEN
51704 LKNT=LKNT+1
51705 DO 180 I=1,4
51706 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51707 180 CONTINUE
51708 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51709 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
51710 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51711 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
51712 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51713 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51714 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51715 IDLAM(LKNT,1)=KFNCHI(IJ)
51716 IDLAM(LKNT,2)=24
51717 IDLAM(LKNT,3)=0
51718C...LEPTONS
51719 ELSEIF(AXMI.GE.AXMJ) THEN
51720 S12MIN=0D0
51721 S12MAX=(AXMI-AXMJ)**2
51722 DO 190 I=1,4
51723 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51724 190 CONTINUE
51725 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51726 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
51727 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51728 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
51729 CXC(5)=DCMPLX(0D0,0D0)
51730 CXC(7)=DCMPLX(0D0,0D0)
51731 IA=11
51732 JA=12
51733 EI=KCHG(IA,1)/3D0
51734 T3I=SIGN(1D0,EI+1D-6)/2D0
51735 EJ=KCHG(JA,1)/3D0
51736 T3J=SIGN(1D0,EJ+1D-6)/2D0
51737 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51738 & TANW+ZMIXC(IJ,2)*T3J)/SR2
51739 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51740 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
51741 CXC(6)=DCMPLX(0D0,0D0)
51742 CXC(8)=DCMPLX(0D0,0D0)
51743 XXC(1)=0D0
51744 XXC(2)=XMJ
51745 XXC(3)=0D0
51746 XXC(4)=XMI
51747 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51748 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51749 XXC(9)=PMAS(24,1)
51750 XXC(10)=PMAS(24,2)
51751CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51752 IF(XXC(5).LT.AXMI) THEN
51753 XXC(5)=1D6
51754 ELSEIF(XXC(6).LT.AXMI) THEN
51755 XXC(6)=1D6
51756 ENDIF
51757 XXC(7)=XXC(6)
51758 XXC(8)=XXC(5)
51759C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
51760C...--> 1/(16PI)/M**3*(AEM/XW)**2
51761 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51762 LKNT=LKNT+1
51763 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51764 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51765 IDLAM(LKNT,1)=KFNCHI(IJ)
51766 IDLAM(LKNT,2)=-11
51767 IDLAM(LKNT,3)=12
51768C...ONLY DECAY CHI+1 -> E+ NU_E
51769 IF( IMSS(12).NE. 0 ) GOTO 260
51770 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51771 LKNT=LKNT+1
51772 XLAM(LKNT)=XLAM(LKNT-1)
51773 IDLAM(LKNT,1)=KFNCHI(IJ)
51774 IDLAM(LKNT,2)=-13
51775 IDLAM(LKNT,3)=14
51776 ENDIF
51777 ENDIF
51778 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51779 LKNT=LKNT+1
51780 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51781 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51782 ELSE
51783 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51784 ENDIF
51785 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51786 IF(XXC(5).LT.AXMI) THEN
51787 XXC(5)=1D6
51788 ELSEIF(XXC(6).LT.AXMI) THEN
51789 XXC(6)=1D6
51790 ENDIF
51791 XXC(7)=XXC(6)
51792 XXC(8)=XXC(5)
51793 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51794 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51795 IDLAM(LKNT,1)=KFNCHI(IJ)
51796 IDLAM(LKNT,2)=-15
51797 IDLAM(LKNT,3)=16
51798 ENDIF
51799
51800C...NOW, DO THE QUARKS
51801 200 CONTINUE
51802 IA=1
51803 JA=2
51804 EI=KCHG(IA,1)/3D0
51805 T3I=SIGN(1D0,EI+1D-6)/2D0
51806 EJ=KCHG(JA,1)/3D0
51807 T3J=SIGN(1D0,EJ+1D-6)/2D0
51808 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51809 & TANW+ZMIXC(IJ,2)*T3J)
51810 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51811 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
51812 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51813 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51814 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
51815 IF(XXC(5).LT.AXMI) THEN
51816 XXC(5)=1D6
51817 ENDIF
51818 IF(XXC(6).LT.AXMI) THEN
51819 XXC(6)=1D6
51820 ENDIF
51821 XXC(7)=XXC(6)
51822 XXC(8)=XXC(5)
51823 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51824 LKNT=LKNT+1
51825 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51826 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51827 IDLAM(LKNT,1)=KFNCHI(IJ)
51828 IDLAM(LKNT,2)=-1
51829 IDLAM(LKNT,3)=2
51830 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51831 LKNT=LKNT+1
51832 XLAM(LKNT)=XLAM(LKNT-1)
51833 IDLAM(LKNT,1)=KFNCHI(IJ)
51834 IDLAM(LKNT,2)=-3
51835 IDLAM(LKNT,3)=4
51836 ENDIF
51837 ENDIF
51838 210 CONTINUE
51839 ENDIF
51840 220 CONTINUE
51841
51842C...CHI+_I -> CHI0_J + H+
51843 DO 230 IJ=1,4
51844 XMJ=SMZ(IJ)
51845 AXMJ=ABS(XMJ)
51846 XMJ2=XMJ**2
51847 XMHP=PMAS(ITHC,1)
51848 IF(AXMI.GE.AXMJ+XMHP) THEN
51849 LKNT=LKNT+1
51850 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
51851 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
51852 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
51853 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
51854 & UMIXC(IX,2)/SR2)
51855 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51856 GLR=DBLE(OLPP*DCONJG(ORPP))
51857 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51858 IDLAM(LKNT,1)=KFNCHI(IJ)
51859 IDLAM(LKNT,2)=ITHC
51860 IDLAM(LKNT,3)=0
51861 ELSE
51862
51863 ENDIF
51864 230 CONTINUE
51865
51866C...2-BODY DECAYS TO FERMION SFERMION
51867 DO 240 J=1,16
51868 IF(J.GE.7.AND.J.LE.10) GOTO 240
51869 IF(MOD(J,2).EQ.0) THEN
51870 KF1=KSUSY1+J-1
51871 ELSE
51872 KF1=KSUSY1+J+1
51873 ENDIF
51874 KF2=KF1+KSUSY1
51875 XMSF1=PMAS(PYCOMP(KF1),1)
51876 XMSF2=PMAS(PYCOMP(KF2),1)
51877 XMF=PMAS(J,1)
51878 IF(J.LE.6) THEN
51879 FCOL=3D0
51880 ELSE
51881 FCOL=1D0
51882 ENDIF
51883
51884C...U~ D_L
51885 IF(MOD(J,2).EQ.0) THEN
51886 XMFP=PMAS(J-1,1)
51887 CAL=UMIXC(IX,1)
51888 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
51889 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
51890 CBR=0D0
51891 ISF=J-1
51892 ELSE
51893 XMFP=PMAS(J+1,1)
51894 CAL=VMIXC(IX,1)
51895 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
51896 CBR=0D0
51897 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
51898 ISF=J+1
51899 ENDIF
51900
51901C...~U_L D
51902 IF(AXMI.GE.XMF+XMSF1) THEN
51903 LKNT=LKNT+1
51904 XMA2=XMSF1**2
51905 XMB2=XMF**2
51906 XL=PYLAMF(XMI2,XMA2,XMB2)
51907 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
51908 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
51909 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51910 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51911 IDLAM(LKNT,3)=0
51912 IF(MOD(J,2).EQ.0) THEN
51913 IDLAM(LKNT,1)=-KF1
51914 IDLAM(LKNT,2)=J
51915 ELSE
51916 IDLAM(LKNT,1)=KF1
51917 IDLAM(LKNT,2)=-J
51918 ENDIF
51919 ENDIF
51920
51921C...U~ D_R
51922 IF(AXMI.GE.XMF+XMSF2) THEN
51923 LKNT=LKNT+1
51924 XMA2=XMSF2**2
51925 XMB2=XMF**2
51926 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
51927 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
51928 XL=PYLAMF(XMI2,XMA2,XMB2)
51929 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51930 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51931 IDLAM(LKNT,3)=0
51932 IF(MOD(J,2).EQ.0) THEN
51933 IDLAM(LKNT,1)=-KF2
51934 IDLAM(LKNT,2)=J
51935 ELSE
51936 IDLAM(LKNT,1)=KF2
51937 IDLAM(LKNT,2)=-J
51938 ENDIF
51939 ENDIF
51940 240 CONTINUE
51941
51942C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
51943C...A 2-BODY -- 2-BODY CHAIN
51944 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51945 IF(AXMI.GE.XMJ) THEN
51946 AXMJ=ABS(XMJ)
51947 S12MIN=0D0
51948 S12MAX=(AXMI-AXMJ)**2
51949 XXC(1)=0D0
51950 XXC(2)=XMJ
51951 XXC(3)=0D0
51952 XXC(4)=XMI
51953 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51954 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51955 XXC(9)=1D6
51956 XXC(10)=0D0
51957 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51958 ORPP=DCONJG(OLPP)
51959 CXC(1)=DCMPLX(0D0,0D0)
51960 CXC(3)=DCMPLX(0D0,0D0)
51961 CXC(5)=DCMPLX(0D0,0D0)
51962 CXC(7)=DCMPLX(0D0,0D0)
51963 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51964 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51965 CXC(6)=DCMPLX(0D0,0D0)
51966 CXC(8)=DCMPLX(0D0,0D0)
51967 IF(XXC(5).LT.AXMI) THEN
51968 XXC(5)=1D6
51969 ELSEIF(XXC(6).LT.AXMI) THEN
51970 XXC(6)=1D6
51971 ENDIF
51972 XXC(7)=XXC(6)
51973 XXC(8)=XXC(5)
51974 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
51975 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51976 LKNT=LKNT+1
51977 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51978 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51979 IDLAM(LKNT,1)=KSUSY1+21
51980 IDLAM(LKNT,2)=-1
51981 IDLAM(LKNT,3)=2
51982 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51983 LKNT=LKNT+1
51984 XLAM(LKNT)=XLAM(LKNT-1)
51985 IDLAM(LKNT,1)=KSUSY1+21
51986 IDLAM(LKNT,2)=-3
51987 IDLAM(LKNT,3)=4
51988 ENDIF
51989 ENDIF
51990 250 CONTINUE
51991 ENDIF
51992
51993C...R-violating decay modes (SKANDS).
51994 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
51995
51996 260 IKNT=LKNT
51997 XLAM(0)=0D0
51998 DO 270 I=1,IKNT
51999 XLAM(0)=XLAM(0)+XLAM(I)
52000 IF(XLAM(I).LT.0D0) THEN
52001 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52002 & (IDLAM(I,J),J=1,3)
52003 XLAM(I)=0D0
52004 ENDIF
52005 270 CONTINUE
52006 IF(XLAM(0).EQ.0D0) THEN
52007 XLAM(0)=1D-6
52008 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52009 WRITE(MSTU(11),*) LKNT
52010 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52011 ENDIF
52012
52013 RETURN
52014 END
52015
52016C*********************************************************************
52017
52018C...PYXXZ6
52019C...Used in the calculation of inoi -> inoj + f + ~f.
52020
52021 FUNCTION PYXXZ6(X)
52022
52023C...Double precision and integer declarations.
52024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52025 IMPLICIT INTEGER(I-N)
52026 INTEGER PYK,PYCHGE,PYCOMP
52027C...Parameter statement to help give large particle numbers.
52028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52029 &KEXCIT=4000000,KDIMEN=5000000)
52030C...Commonblocks.
52031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52032C COMMON/PYINTS/XXM(20)
52033 COMPLEX*16 CXC
52034 COMMON/PYINTC/XXC(10),CXC(8)
52035 SAVE /PYDAT1/,/PYINTC/
52036
52037C...Local variables.
52038 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52039 DOUBLE PRECISION PYXXZ6,X
52040 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52041 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52042 DOUBLE PRECISION SIJ
52043 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52044 DOUBLE PRECISION OL2
52045 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52046 INTEGER I
52047
52048C...Statement functions.
52049C...Integral from x to y of (t-a)(b-t) dt.
52050 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
52051C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52052 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
52053 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
52054C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52055 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
52056 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
52057C...Integral from x to y of (t-a)/(b-t) dt.
52058 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
52059C...Integral from x to y of 1/(t-a) dt.
52060 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
52061
52062 XM12=XXC(1)**2
52063 XM22=XXC(2)**2
52064 XM32=XXC(3)**2
52065 S=XXC(4)**2
52066 S13=X
52067
52068 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
52069 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
52070 &( (X-XM22-S)**2 -4D0*XM22*S ) )
52071
52072 S23MIN=(S23AVE-S23DEL)
52073 S23MAX=(S23AVE+S23DEL)
52074
52075 XMSD1=XXC(5)**2
52076 XMSD2=XXC(7)**2
52077 XMSU1=XXC(6)**2
52078 XMSU2=XXC(8)**2
52079
52080 XMV=XXC(9)
52081 XMG=XXC(10)
52082 QLLS=CXC(1)
52083 QLLU=CXC(2)
52084 QLRS=CXC(3)
52085 QLRT=CXC(4)
52086 QRLS=CXC(5)
52087 QRLT=CXC(6)
52088 QRRS=CXC(7)
52089 QRRU=CXC(8)
52090 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
52091 SIJ=2D0*XXC(2)*XXC(4)*S13
52092 IF(XMV.LE.1000D0) THEN
52093 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
52094 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
52095 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
52096 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
52097 IF(XXC(5).LE.10000D0) THEN
52098 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
52099 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
52100 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
52101 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
52102 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
52103 & *(S13-XMV**2)/WPROP2
52104 ELSE
52105 WFL1=0D0
52106 ENDIF
52107
52108 IF(XXC(6).LE.10000D0) THEN
52109 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
52110 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
52111 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
52112 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
52113 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
52114 & *(S13-XMV**2)/WPROP2
52115 ELSE
52116 WFL2=0D0
52117 ENDIF
52118 ELSE
52119 WW=0D0
52120 WFL1=0D0
52121 WFL2=0D0
52122 ENDIF
52123 IF(XXC(5).LE.10000D0) THEN
52124 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
52125 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
52126 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
52127 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
52128 ELSE
52129 WF1=0D0
52130 ENDIF
52131 IF(XXC(6).LE.10000D0) THEN
52132 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
52133 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
52134 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
52135 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
52136 ELSE
52137 WF2=0D0
52138 ENDIF
52139
52140 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
52141
52142 IF(PYXXZ6.LT.0D0) THEN
52143 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
52144 WRITE(MSTU(11),*) (XXC(I),I=1,5)
52145 WRITE(MSTU(11),*) (XXC(I),I=6,10)
52146 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
52147 WRITE(MSTU(11),*) S23MIN,S23MAX
52148 PYXXZ6=0D0
52149 ENDIF
52150
52151 RETURN
52152 END
52153
52154
52155C*********************************************************************
52156
52157C...PYXXGA
52158C...Calculates chi0_i -> chi0_j + gamma.
52159
52160 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
52161
52162C...Double precision and integer declarations.
52163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52164 IMPLICIT INTEGER(I-N)
52165 INTEGER PYK,PYCHGE,PYCOMP
52166
52167C...Local variables.
52168 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
52169 DOUBLE PRECISION F1,F2
52170
52171 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
52172 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
52173 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
52174 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
52175
52176 RETURN
52177 END
52178
52179C*********************************************************************
52180
52181C...PYX2XG
52182C...Calculates the decay rate for ino -> ino + gauge boson.
52183
52184 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
52185
52186C...Double precision and integer declarations.
52187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52188 IMPLICIT INTEGER(I-N)
52189 INTEGER PYK,PYCHGE,PYCOMP
52190
52191C...Local variables.
52192 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
52193 DOUBLE PRECISION XL,PYLAMF,C1
52194 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52195
52196 XMI2=XM1**2
52197 XMI3=ABS(XM1**3)
52198 XMJ2=XM2**2
52199 XMV2=XM3**2
52200 XL=PYLAMF(XMI2,XMJ2,XMV2)
52201 PYX2XG=C1/8D0/XMI3*SQRT(XL)
52202 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
52203 &12D0*GLR*XM1*XM2*XMV2)
52204
52205 RETURN
52206 END
52207
52208C*********************************************************************
52209
52210C...PYX2XH
52211C...Calculates the decay rate for ino -> ino + H.
52212
52213 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
52214
52215C...Double precision and integer declarations.
52216 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52217 IMPLICIT INTEGER(I-N)
52218 INTEGER PYK,PYCHGE,PYCOMP
52219
52220C...Local variables.
52221 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
52222 DOUBLE PRECISION XL,PYLAMF,C1
52223 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52224
52225 XMI2=XM1**2
52226 XMI3=ABS(XM1**3)
52227 XMJ2=XM2**2
52228 XMV2=XM3**2
52229 XL=PYLAMF(XMI2,XMJ2,XMV2)
52230 PYX2XH=C1/8D0/XMI3*SQRT(XL)
52231 &*(GX2*(XMI2+XMJ2-XMV2)+
52232 &4D0*GLR*XM1*XM2)
52233
52234 RETURN
52235 END
52236
52237C*********************************************************************
52238
52239C...PYHEXT
52240C...Calculates the non-standard decay modes of the Higgs boson.
52241C...
52242C...Author: Stephen Mrenna
52243C...Last Update: April 2001
52244C......Allow complex values for Z,U, and V
52245
52246 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
52247
52248C...Double precision and integer declarations.
52249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52250 IMPLICIT INTEGER(I-N)
52251 INTEGER PYK,PYCHGE,PYCOMP
52252C...Parameter statement to help give large particle numbers.
52253 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52254 &KEXCIT=4000000,KDIMEN=5000000)
52255C...Commonblocks.
52256 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52257 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52258 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52259 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52260 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52261 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52262 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
52263
52264C...Local variables.
52265 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52266 COMPLEX*16 QIJ,RIJ,F21K,F12K
52267 INTEGER KFIN
52268 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
52269 DOUBLE PRECISION XMI2,XMI3,XMJ2
52270 DOUBLE PRECISION PYLAMF,XL,CF,EI
52271 INTEGER IDU,IFL
52272 DOUBLE PRECISION TANW,XW,AEM,C1,AS
52273 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
52274 DOUBLE PRECISION XLAM(0:400)
52275 INTEGER IDLAM(400,3)
52276 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
52277 INTEGER ITH(4)
52278 INTEGER KFNCHI(4),KFCCHI(2)
52279 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
52280 DOUBLE PRECISION SR2
52281 DOUBLE PRECISION BETA,ALFA
52282 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
52283 DOUBLE PRECISION PYALEM
52284 DOUBLE PRECISION AL,AR,ALR
52285 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
52286 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
52287 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
52288 DATA ITH/25,35,36,37/
52289 DATA ETAH/1D0,1D0,-1D0/
52290 DATA SR2/1.4142136D0/
52291 DATA KFNCHI/1000022,1000023,1000025,1000035/
52292 DATA KFCCHI/1000024,1000037/
52293
52294C...COUNT THE NUMBER OF DECAY MODES
52295 LKNT=IKNT
52296
52297 XMW=PMAS(24,1)
52298 XMW2=XMW**2
52299 XMZ=PMAS(23,1)
52300 XW=PARU(102)
52301 TANW = SQRT(XW/(1D0-XW))
52302 CW=SQRT(1D0-XW)
52303
52304C...1 - 4 DEPENDING ON Higgs species.
52305 IH=1
52306 IF(KFIN.EQ.ITH(2)) IH=2
52307 IF(KFIN.EQ.ITH(3)) IH=3
52308 IF(KFIN.EQ.ITH(4)) IH=4
52309
52310 XMI=PMAS(KFIN,1)
52311 XMI2=XMI**2
52312 AXMI=ABS(XMI)
52313 AEM=PYALEM(XMI2)
52314 C1=AEM/XW
52315 XMI3=ABS(XMI**3)
52316
52317 TANB=RMSS(5)
52318 BETA=ATAN(TANB)
52319 CBETA=COS(BETA)
52320 SBETA=TANB*CBETA
52321 ALFA=RMSS(18)
52322 COSA=COS(ALFA)
52323 SINA=SIN(ALFA)
52324 ATRIT=RMSS(16)
52325 ATRIB=RMSS(15)
52326 ATRIL=RMSS(17)
52327 XMUZ=-RMSS(4)
52328
52329 DO 110 I=1,4
52330 DO 100 J=1,4
52331 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52332 100 CONTINUE
52333 110 CONTINUE
52334 DO 130 I=1,2
52335 DO 120 J=1,2
52336 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52337 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52338 120 CONTINUE
52339 130 CONTINUE
52340
52341
52342 IF(IH.EQ.4) GOTO 220
52343
52344C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52345C...H0_K -> CHI0_I + CHI0_J
52346 EH(2)=SINA
52347 EH(1)=COSA
52348 EH(3)=CBETA
52349 DH(2)=COSA
52350 DH(1)=-SINA
52351 DH(3)=SBETA
52352 DO 150 IJ=1,4
52353 XMJ=SMZ(IJ)
52354 AXMJ=ABS(XMJ)
52355 DO 140 IK=1,IJ
52356 XMK=SMZ(IK)
52357 AXMK=ABS(XMK)
52358 IF(AXMI.GE.AXMJ+AXMK) THEN
52359 LKNT=LKNT+1
52360 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
52361 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
52362 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
52363 & ZMIXC(IJ,3)*ZMIXC(IK,1))
52364 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
52365 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
52366 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
52367 & ZMIXC(IJ,4)*ZMIXC(IK,1))
52368 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
52369 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
52370C...SIGN OF MASSES I,J
52371 XML=XMK*ETAH(IH)
52372 GX2=ABS(F12K)**2+ABS(F21K)**2
52373 GLR=DBLE(F12K*DCONJG(F21K))
52374 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52375 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
52376 IDLAM(LKNT,1)=KFNCHI(IJ)
52377 IDLAM(LKNT,2)=KFNCHI(IK)
52378 IDLAM(LKNT,3)=0
52379 ENDIF
52380 140 CONTINUE
52381 150 CONTINUE
52382
52383C...H0_K -> CHI+_I CHI-_J
52384 DO 170 IJ=1,2
52385 XMJ=SMW(IJ)
52386 AXMJ=ABS(XMJ)
52387 DO 160 IK=1,2
52388 XMK=SMW(IK)
52389 AXMK=ABS(XMK)
52390 IF(AXMI.GE.AXMJ+AXMK) THEN
52391 LKNT=LKNT+1
52392 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
52393 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
52394 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
52395 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
52396 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52397 GLR=DBLE(OLPP*DCONJG(ORPP))
52398 XML=XMK*ETAH(IH)
52399 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52400 IDLAM(LKNT,1)=KFCCHI(IJ)
52401 IDLAM(LKNT,2)=-KFCCHI(IK)
52402 IDLAM(LKNT,3)=0
52403 ENDIF
52404 160 CONTINUE
52405 170 CONTINUE
52406
52407C...HIGGS TO SFERMION SFERMION
52408 DO 200 IFL=1,16
52409 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
52410 IJ=KSUSY1+IFL
52411 XMJL=PMAS(PYCOMP(IJ),1)
52412 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
52413 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
52414 XMJ=XMJL
52415 XMJ2=XMJ**2
52416 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52417 XMF=PMAS(IFL,1)
52418 EI=KCHG(IFL,1)/3D0
52419 IDU=2-MOD(IFL,2)
52420
52421 IF(IH.EQ.1) THEN
52422 IF(IDU.EQ.1) THEN
52423 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
52424 & XMF**2/XMW*SINA/CBETA
52425 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
52426 & XMF**2/XMW*SINA/CBETA
52427 IF(IFL.EQ.5) THEN
52428 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52429 & ATRIB*SINA)
52430 ELSEIF(IFL.EQ.15) THEN
52431 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52432 & ATRIL*SINA)
52433 ELSE
52434 GHLR=0D0
52435 ENDIF
52436 ELSE
52437 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
52438 & XMF**2/XMW*COSA/SBETA
52439 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
52440 & XMF**2/XMW*COSA/SBETA
52441 IF(IFL.EQ.6) THEN
52442 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
52443 & ATRIT*COSA)
52444 ELSE
52445 GHLR=0D0
52446 ENDIF
52447 ENDIF
52448
52449 ELSEIF(IH.EQ.2) THEN
52450 IF(IDU.EQ.1) THEN
52451 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
52452 & XMF**2/XMW*COSA/CBETA
52453 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52454 & XMF**2/XMW*COSA/CBETA
52455 IF(IFL.EQ.5) THEN
52456 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52457 & ATRIB*COSA)
52458 ELSEIF(IFL.EQ.15) THEN
52459 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52460 & ATRIL*COSA)
52461 ELSE
52462 GHLR=0D0
52463 ENDIF
52464 ELSE
52465 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
52466 & XMF**2/XMW*SINA/SBETA
52467 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52468 & XMF**2/XMW*SINA/SBETA
52469 IF(IFL.EQ.6) THEN
52470 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
52471 & ATRIT*SINA)
52472 ELSE
52473 GHLR=0D0
52474 ENDIF
52475 ENDIF
52476
52477 ELSEIF(IH.EQ.3) THEN
52478 GHLL=0D0
52479 GHRR=0D0
52480 GHLR=0D0
52481 IF(IDU.EQ.1) THEN
52482 IF(IFL.EQ.5) THEN
52483 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
52484 ELSEIF(IFL.EQ.15) THEN
52485 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
52486 ENDIF
52487 ELSE
52488 IF(IFL.EQ.6) THEN
52489 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
52490 ENDIF
52491 ENDIF
52492 ENDIF
52493 IF(IH.EQ.3) GOTO 180
52494
52495 AL=SFMIX(IFL,1)**2
52496 AR=SFMIX(IFL,2)**2
52497 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
52498 IF(IFL.LE.6) THEN
52499 CF=3D0
52500 ELSE
52501 CF=1D0
52502 ENDIF
52503
52504 IF(AXMI.GE.2D0*XMJ) THEN
52505 LKNT=LKNT+1
52506 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52507 & (GHLL*AL+GHRR*AR
52508 & +2D0*GHLR*ALR)**2
52509 IDLAM(LKNT,1)=IJ
52510 IDLAM(LKNT,2)=-IJ
52511 IDLAM(LKNT,3)=0
52512 ENDIF
52513
52514 IF(AXMI.GE.2D0*XMJR) THEN
52515 LKNT=LKNT+1
52516 AL=SFMIX(IFL,3)**2
52517 AR=SFMIX(IFL,4)**2
52518 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
52519 XMJ=XMJR
52520 XMJ2=XMJ**2
52521 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52522 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52523 & (GHLL*AL+GHRR*AR
52524 & +2D0*GHLR*ALR)**2
52525 IDLAM(LKNT,1)=IJ+KSUSY1
52526 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52527 IDLAM(LKNT,3)=0
52528 ENDIF
52529 180 CONTINUE
52530
52531 IF(AXMI.GE.XMJL+XMJR) THEN
52532 LKNT=LKNT+1
52533 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
52534 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
52535 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
52536 XMJ=XMJR
52537 XMJ2=XMJ**2
52538 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
52539 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52540 & (GHLL*AL+GHRR*AR)**2
52541 IDLAM(LKNT,1)=IJ
52542 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52543 IDLAM(LKNT,3)=0
52544 LKNT=LKNT+1
52545 IDLAM(LKNT,1)=-IJ
52546 IDLAM(LKNT,2)=IJ+KSUSY1
52547 IDLAM(LKNT,3)=0
52548 XLAM(LKNT)=XLAM(LKNT-1)
52549 ENDIF
52550 ENDIF
52551 190 CONTINUE
52552 200 CONTINUE
52553 210 CONTINUE
52554
52555 GOTO 270
52556 220 CONTINUE
52557
52558C...H+ -> CHI+_I + CHI0_J
52559 DO 240 IJ=1,4
52560 XMJ=SMZ(IJ)
52561 AXMJ=ABS(XMJ)
52562 XMJ2=XMJ**2
52563 DO 230 IK=1,2
52564 XMK=SMW(IK)
52565 AXMK=ABS(XMK)
52566 IF(AXMI.GE.AXMJ+AXMK) THEN
52567 LKNT=LKNT+1
52568 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
52569 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
52570 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
52571 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
52572 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52573 GLR=DBLE(OLPP*DCONJG(ORPP))
52574 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
52575 IDLAM(LKNT,1)=KFNCHI(IJ)
52576 IDLAM(LKNT,2)=KFCCHI(IK)
52577 IDLAM(LKNT,3)=0
52578 ENDIF
52579 230 CONTINUE
52580 240 CONTINUE
52581
52582 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
52583 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
52584 AL=0D0
52585 AR=0D0
52586 CF=3D0
52587
52588C...H+ -> T_1 B_1~
52589 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52590 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52591 IF(XMI.GE.XM1+XM2) THEN
52592 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52593 LKNT=LKNT+1
52594 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52595 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
52596 IDLAM(LKNT,1)=KSUSY1+6
52597 IDLAM(LKNT,2)=-(KSUSY1+5)
52598 IDLAM(LKNT,3)=0
52599 ENDIF
52600
52601C...H+ -> T_2 B_1~
52602 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52603 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52604 IF(XMI.GE.XM1+XM2) THEN
52605 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52606 LKNT=LKNT+1
52607 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52608 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
52609 IDLAM(LKNT,1)=KSUSY2+6
52610 IDLAM(LKNT,2)=-(KSUSY1+5)
52611 IDLAM(LKNT,3)=0
52612 ENDIF
52613
52614C...H+ -> T_1 B_2~
52615 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52616 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52617 IF(XMI.GE.XM1+XM2) THEN
52618 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52619 LKNT=LKNT+1
52620 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52621 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
52622 IDLAM(LKNT,1)=KSUSY1+6
52623 IDLAM(LKNT,2)=-(KSUSY2+5)
52624 IDLAM(LKNT,3)=0
52625 ENDIF
52626
52627C...H+ -> T_2 B_2~
52628 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52629 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52630 IF(XMI.GE.XM1+XM2) THEN
52631 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52632 LKNT=LKNT+1
52633 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52634 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
52635 IDLAM(LKNT,1)=KSUSY2+6
52636 IDLAM(LKNT,2)=-(KSUSY2+5)
52637 IDLAM(LKNT,3)=0
52638 ENDIF
52639
52640C...H+ -> UL DL~
52641 GL=-XMW/SR2*SIN(2D0*BETA)
52642 DO 250 IJ=1,3,2
52643 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52644 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52645 IF(XMI.GE.XM1+XM2) THEN
52646 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52647 LKNT=LKNT+1
52648 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52649 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52650 IDLAM(LKNT,2)=KSUSY1+IJ+1
52651 IDLAM(LKNT,3)=0
52652 ENDIF
52653 250 CONTINUE
52654
52655C...H+ -> EL~ NUL
52656 CF=1D0
52657 DO 260 IJ=11,13,2
52658 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52659 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52660 IF(XMI.GE.XM1+XM2) THEN
52661 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52662 LKNT=LKNT+1
52663 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52664 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52665 IDLAM(LKNT,2)=KSUSY1+IJ+1
52666 IDLAM(LKNT,3)=0
52667 ENDIF
52668 260 CONTINUE
52669
52670C...H+ -> TAU1 NUTAUL
52671 XM1=PMAS(PYCOMP(KSUSY1+15),1)
52672 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52673 IF(XMI.GE.XM1+XM2) THEN
52674 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52675 LKNT=LKNT+1
52676 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
52677 IDLAM(LKNT,1)=-(KSUSY1+15)
52678 IDLAM(LKNT,2)= KSUSY1+16
52679 IDLAM(LKNT,3)=0
52680 ENDIF
52681
52682C...H+ -> TAU2 NUTAUL
52683 XM1=PMAS(PYCOMP(KSUSY2+15),1)
52684 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52685 IF(XMI.GE.XM1+XM2) THEN
52686 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52687 LKNT=LKNT+1
52688 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
52689 IDLAM(LKNT,1)=-(KSUSY2+15)
52690 IDLAM(LKNT,2)= KSUSY1+16
52691 IDLAM(LKNT,3)=0
52692 ENDIF
52693
52694 270 CONTINUE
52695 IKNT=LKNT
52696 XLAM(0)=0D0
52697 DO 280 I=1,IKNT
52698 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
52699 XLAM(0)=XLAM(0)+XLAM(I)
52700 280 CONTINUE
52701 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52702
52703 RETURN
52704 END
52705
52706C*********************************************************************
52707
52708C...PYH2XX
52709C...Calculates the decay rate for a Higgs to an ino pair.
52710
52711 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
52712
52713C...Double precision and integer declarations.
52714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52715 IMPLICIT INTEGER(I-N)
52716 INTEGER PYK,PYCHGE,PYCOMP
52717C...Commonblocks.
52718 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52719 SAVE /PYDAT1/
52720
52721C...Local variables.
52722 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
52723 DOUBLE PRECISION XL,PYLAMF,C1
52724 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
52725
52726 XMI2=XM1**2
52727 XMI3=ABS(XM1**3)
52728 XMJ2=XM2**2
52729 XMK2=XM3**2
52730 XL=PYLAMF(XMI2,XMJ2,XMK2)
52731 PYH2XX=C1/4D0/XMI3*SQRT(XL)
52732 &*(GX2*(XMI2-XMJ2-XMK2)-
52733 &4D0*GLR*XM3*XM2)
52734 IF(PYH2XX.LT.0D0) PYH2XX=0D0
52735
52736 RETURN
52737 END
52738
52739C*********************************************************************
52740
52741C...PYGAUS
52742C...Integration by adaptive Gaussian quadrature.
52743C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52744
52745 FUNCTION PYGAUS(F, A, B, EPS)
52746
52747C...Double precision and integer declarations.
52748 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52749 IMPLICIT INTEGER(I-N)
52750 INTEGER PYK,PYCHGE,PYCOMP
52751
52752C...Local declarations.
52753 EXTERNAL F
52754 DOUBLE PRECISION F,W(12), X(12)
52755 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52756 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52757 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52758 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52759 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52760 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52761 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52762 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52763 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52764 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52765 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52766 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52767
52768C...The Gaussian quadrature algorithm.
52769 H = 0D0
52770 IF(B .EQ. A) GOTO 140
52771 CONST = 5D-3 / ABS(B-A)
52772 BB = A
52773 100 CONTINUE
52774 AA = BB
52775 BB = B
52776 110 CONTINUE
52777 C1 = 0.5D0*(BB+AA)
52778 C2 = 0.5D0*(BB-AA)
52779 S8 = 0D0
52780 DO 120 I = 1, 4
52781 U = C2*X(I)
52782 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52783 120 CONTINUE
52784 S16 = 0D0
52785 DO 130 I = 5, 12
52786 U = C2*X(I)
52787 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52788 130 CONTINUE
52789 S16 = C2*S16
52790 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52791 H = H + S16
52792 IF(BB .NE. B) GOTO 100
52793 ELSE
52794 BB = C1
52795 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52796 H = 0D0
52797 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
52798 GOTO 140
52799 ENDIF
52800 140 CONTINUE
52801 PYGAUS = H
52802
52803 RETURN
52804 END
52805
52806C*********************************************************************
52807
52808C...PYGAU2
52809C...Integration by adaptive Gaussian quadrature.
52810C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52811C...Carbon copy of PYGAUS, but avoids having to use it recursively.
52812
52813 FUNCTION PYGAU2(F, A, B, EPS)
52814
52815C...Double precision and integer declarations.
52816 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52817 IMPLICIT INTEGER(I-N)
52818 INTEGER PYK,PYCHGE,PYCOMP
52819
52820C...Local declarations.
52821 EXTERNAL F
52822 DOUBLE PRECISION F,W(12), X(12)
52823 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52824 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52825 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52826 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52827 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52828 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52829 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52830 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52831 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52832 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52833 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52834 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52835
52836C...The Gaussian quadrature algorithm.
52837 H = 0D0
52838 IF(B .EQ. A) GOTO 140
52839 CONST = 5D-3 / ABS(B-A)
52840 BB = A
52841 100 CONTINUE
52842 AA = BB
52843 BB = B
52844 110 CONTINUE
52845 C1 = 0.5D0*(BB+AA)
52846 C2 = 0.5D0*(BB-AA)
52847 S8 = 0D0
52848 DO 120 I = 1, 4
52849 U = C2*X(I)
52850 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52851 120 CONTINUE
52852 S16 = 0D0
52853 DO 130 I = 5, 12
52854 U = C2*X(I)
52855 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52856 130 CONTINUE
52857 S16 = C2*S16
52858 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52859 H = H + S16
52860 IF(BB .NE. B) GOTO 100
52861 ELSE
52862 BB = C1
52863 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52864 H = 0D0
52865 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
52866 GOTO 140
52867 ENDIF
52868 140 CONTINUE
52869 PYGAU2 = H
52870
52871 RETURN
52872 END
52873
52874C*********************************************************************
52875
52876C...PYSIMP
52877C...Simpson formula for an integral.
52878
52879 FUNCTION PYSIMP(Y,X0,X1,N)
52880
52881C...Double precision and integer declarations.
52882 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52883 IMPLICIT INTEGER(I-N)
52884 INTEGER PYK,PYCHGE,PYCOMP
52885
52886C...Local variables.
52887 DOUBLE PRECISION Y,X0,X1,H,S
52888 DIMENSION Y(0:N)
52889
52890 S=0D0
52891 H=(X1-X0)/N
52892 DO 100 I=0,N-2,2
52893 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
52894 100 CONTINUE
52895 PYSIMP=S*H/3D0
52896
52897 RETURN
52898 END
52899
52900C*********************************************************************
52901
52902C...PYLAMF
52903C...The standard lambda function.
52904
52905 FUNCTION PYLAMF(X,Y,Z)
52906
52907C...Double precision and integer declarations.
52908 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52909 IMPLICIT INTEGER(I-N)
52910 INTEGER PYK,PYCHGE,PYCOMP
52911
52912C...Local variables.
52913 DOUBLE PRECISION PYLAMF,X,Y,Z
52914
52915 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
52916 IF(PYLAMF.LT.0D0) PYLAMF=0D0
52917
52918 RETURN
52919 END
52920
52921C*********************************************************************
52922
52923C...PYTBDY
52924C...Generates 3-body decays of gauginos.
52925
52926 SUBROUTINE PYTBDY(IDIN)
52927
52928C...Double precision and integer declarations.
52929 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52930 IMPLICIT INTEGER(I-N)
52931 INTEGER PYK,PYCHGE,PYCOMP
52932C...Parameter statement to help give large particle numbers.
52933 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52934 &KEXCIT=4000000,KDIMEN=5000000)
52935C...Commonblocks.
52936 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52939C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52940C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52941 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52942 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52943C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
52944 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
52945
52946C...Local variables.
52947 DOUBLE PRECISION XM(5)
52948 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
52949 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
52950 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
52951 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
52952 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
52953 DOUBLE PRECISION CPHI1,SPHI1
52954 DOUBLE PRECISION S23DEL,EPS
52955 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
52956 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
52957 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
52958 INTEGER INOID(4)
52959 DATA INOID/22,23,25,35/
52960 DATA EPS/1D-6/
52961
52962 ID=IDIN
52963 ISKIP=1
52964 XM(1)=P(N+1,5)
52965 XM(2)=P(N+2,5)
52966 XM(3)=P(N+3,5)
52967 XM(5)=P(ID,5)
52968
52969C...GENERATE S12
52970 S12MIN=(XM(1)+XM(2))**2
52971 S12MAX=(XM(5)-XM(3))**2
52972 YJACO1=S12MAX-S12MIN
52973
52974C...Initialize some parameters
52975 XW=PARU(102)
52976 XW1=1D0-XW
52977 TANW=SQRT(XW/XW1)
52978 IZID1=0
52979 IWID1=0
52980 IZID2=0
52981 IWID2=0
52982
52983 IA=K(N+2,2)
52984 JA=K(N+3,2)
52985
52986C...Mrenna: check that we are indeed decaying a SUSY particle
52987 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
52988
52989 ELSE
52990 DO 100 I1=1,4
52991 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
52992 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
52993 100 CONTINUE
52994 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
52995 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
52996 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
52997 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
52998 ZM12=XM(5)**2
52999 ZM22=XM(1)**2
53000 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53001 T3I=SIGN(1D0,EI+1D-6)/2D0
53002 ENDIF
53003
53004 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53005 ISKIP=0
53006 ELSEIF(IZID1*IZID2.NE.0) THEN
53007 SQMZ=PMAS(23,1)**2
53008 GMMZ=PMAS(23,1)*PMAS(23,2)
53009 DO 110 I=1,4
53010 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53011 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53012 110 CONTINUE
53013 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53014 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53015 ORPP=DCONJG(OLPP)
53016 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53017 XLR2=XLL2
53018 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53019 XRL2=XRR2
53020 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53021 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53022 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53023 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53024 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53025 QLLU=-GLIJ
53026 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53027 QLRT=DCONJG(GLIJ)
53028 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53029 QRLT=GRIJ
53030 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53031 QRRU=-DCONJG(GRIJ)
53032 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53033 IF(IZID1.NE.0) THEN
53034 XM1M2=SMZ(IZID1)*SMW(IWID2)
53035 IZID1=IWID2
53036 IZID2=IZID1
53037 ELSE
53038 XM1M2=SMZ(IZID2)*SMW(IWID1)
53039 IZID1=IWID1
53040 ENDIF
53041 RT2I = 1D0/SQRT(2D0)
53042 SQMZ=PMAS(24,1)**2
53043 GMMZ=PMAS(24,1)*PMAS(24,2)
53044 DO 120 I=1,2
53045 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53046 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53047 120 CONTINUE
53048 DO 130 I=1,4
53049 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53050 130 CONTINUE
53051 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
53052 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
53053 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
53054 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
53055 EJ=KCHG(IABS(JA),1)/3D0
53056 T3J=SIGN(1D0,EJ+1D-6)/2D0
53057 QRLS=DCMPLX(0D0,0D0)
53058 QRLT=QRLS
53059 QRRS=QRLS
53060 QRRU=QRLS
53061 XRR2=1D6**2
53062 XRL2=XRR2
53063 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
53064 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53065 IF(MOD(IA,2).EQ.0) THEN
53066 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
53067 & TANW+ZMIXC(IZID2,2)*T3I)
53068 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53069 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
53070 ELSE
53071 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
53072 & TANW+ZMIXC(IZID2,2)*T3J)
53073 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53074 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
53075 ENDIF
53076 ELSEIF(IWID1*IWID2.NE.0) THEN
53077 IZID1=IWID1
53078 IZID2=IWID2
53079 XM1M2=SMW(IWID1)*SMW(IWID2)
53080 SQMZ=PMAS(23,1)**2
53081 GMMZ=PMAS(23,1)*PMAS(23,2)
53082 DO 140 I=1,2
53083 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53084 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53085 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
53086 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
53087 140 CONTINUE
53088 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
53089 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
53090 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
53091 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
53092 QRLS=-DCMPLX(EI/XW1)*ORPP
53093 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53094 QRRS=-DCMPLX(EI/XW1)*OLPP
53095 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53096 IF(MOD(IA,2).EQ.0) THEN
53097 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
53098 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
53099 ELSE
53100 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
53101 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
53102 ENDIF
53103 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
53104 &THEN
53105 ISKIP=0
53106 ELSE
53107 ISKIP=0
53108 ENDIF
53109
53110 IF(ISKIP.NE.0) THEN
53111 WTMAX=0D0
53112 DO 160 KT=1,100
53113 S12=S12MIN+YJACO1*(KT-1)/99
53114 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53115 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53116 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53117 & -(2D0*XM(1)*XM(2))**2
53118 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53119 & -(2D0*XM(3)*XM(5))**2
53120 S23DF1=S23DF1*EPS
53121 S23DF2=S23DF2*EPS
53122 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53123 S23DEL=S23DEL/EPS
53124 S23MIN=S23AVE-S23DEL
53125 S23MAX=S23AVE+S23DEL
53126 YJACO2=S23MAX-S23MIN
53127 TH=S12
53128 DO 150 KS=1,100
53129 S23=S23MIN+YJACO2*(KS-1)/99
53130 SH=S23
53131 UH=ZM12+ZM22-SH-TH
53132 WU2 = (UH-ZM12)*(UH-ZM22)
53133 WT2 = (TH-ZM12)*(TH-ZM22)
53134 WS2 = XM1M2*SH
53135 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53136 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53137 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53138 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53139 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53140 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53141 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53142 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
53143 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53144 IF(WT0.GT.WTMAX) WTMAX=WT0
53145 150 CONTINUE
53146 160 CONTINUE
53147
53148 WTMAX=WTMAX*1.05D0
53149 ENDIF
53150
53151C...FIND S12*
53152 AX=S12MIN
53153 CX=S12MAX
53154 BX=S12MIN+0.5D0*YJACO1
53155 X0=AX
53156 X3=CX
53157 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
53158 X1=BX
53159 X2=BX+C*(CX-BX)
53160 ELSE
53161 X2=BX
53162 X1=BX-C*(BX-AX)
53163 ENDIF
53164
53165C...SOLVE FOR F1 AND F2
53166 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53167 &-(2D0*XM(1)*XM(2))**2
53168 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53169 &-(2D0*XM(3)*XM(5))**2
53170 S23DF1=S23DF1*EPS
53171 S23DF2=S23DF2*EPS
53172 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53173 F1=-2D0*S23DEL/EPS
53174 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53175 &-(2D0*XM(1)*XM(2))**2
53176 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53177 &-(2D0*XM(3)*XM(5))**2
53178 S23DF1=S23DF1*EPS
53179 S23DF2=S23DF2*EPS
53180 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53181 F2=-2D0*S23DEL/EPS
53182
53183 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
53184C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
53185 IF(F2.LE.F1)THEN
53186 X0=X1
53187 X1=X2
53188 X2=R*X1+C*X3
53189 F1=F2
53190 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53191 & -(2D0*XM(1)*XM(2))**2
53192 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53193 & -(2D0*XM(3)*XM(5))**2
53194 S23DF1=S23DF1*EPS
53195 S23DF2=S23DF2*EPS
53196 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53197 F2=-2D0*S23DEL/EPS
53198 ELSE
53199 X3=X2
53200 X2=X1
53201 X1=R*X2+C*X0
53202 F2=F1
53203 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53204 & -(2D0*XM(1)*XM(2))**2
53205 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53206 & -(2D0*XM(3)*XM(5))**2
53207 S23DF1=S23DF1*EPS
53208 S23DF2=S23DF2*EPS
53209 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53210 F1=-2D0*S23DEL/EPS
53211 ENDIF
53212 GOTO 170
53213 ENDIF
53214C...WE WANT THE MAXIMUM, NOT THE MINIMUM
53215 IF(F1.LT.F2)THEN
53216 GOLDEN=-F1
53217 XMIN=X1
53218 ELSE
53219 GOLDEN=-F2
53220 XMIN=X2
53221 ENDIF
53222
53223 IKNT=0
53224 180 S12=S12MIN+PYR(0)*YJACO1
53225 IKNT=IKNT+1
53226C...GENERATE S23
53227 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53228 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53229 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53230 &-(2D0*XM(1)*XM(2))**2
53231 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53232 &-(2D0*XM(3)*XM(5))**2
53233 S23DF1=S23DF1*EPS
53234 S23DF2=S23DF2*EPS
53235 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53236 S23DEL=S23DEL/EPS
53237 S23MIN=S23AVE-S23DEL
53238 S23MAX=S23AVE+S23DEL
53239 YJACO2=S23MAX-S23MIN
53240 S23=S23MIN+PYR(0)*YJACO2
53241
53242C...CHECK THE SAMPLING
53243 IF(IKNT.GT.100) THEN
53244 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
53245 GOTO 190
53246 ENDIF
53247 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
53248
53249 IF(ISKIP.EQ.0) GOTO 190
53250
53251 SH=S23
53252 TH=S12
53253 UH=ZM12+ZM22-SH-TH
53254
53255 WU2 = (UH-ZM12)*(UH-ZM22)
53256 WT2 = (TH-ZM12)*(TH-ZM22)
53257 WS2 = XM1M2*SH
53258 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53259 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53260
53261 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53262 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53263 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53264 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53265c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
53266c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
53267c &/DCMPLX(TH-XML2)
53268c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
53269c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
53270c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
53271 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53272 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
53273 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53274
53275 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
53276 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
53277
53278 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
53279 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
53280 D2=XM(5)-D1-D3
53281 P1=SQRT(D1*D1-XM(1)**2)
53282 P2=SQRT(D2*D2-XM(2)**2)
53283 P3=SQRT(D3*D3-XM(3)**2)
53284 CTHE1=2D0*PYR(0)-1D0
53285 ANG1=2D0*PYR(0)*PARU(1)
53286 CPHI1=COS(ANG1)
53287 SPHI1=SIN(ANG1)
53288 ARG=1D0-CTHE1**2
53289 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53290 STHE1=SQRT(ARG)
53291 P(N+1,1)=P1*STHE1*CPHI1
53292 P(N+1,2)=P1*STHE1*SPHI1
53293 P(N+1,3)=P1*CTHE1
53294 P(N+1,4)=D1
53295
53296C...GET CPHI3
53297 ANG3=2D0*PYR(0)*PARU(1)
53298 CPHI3=COS(ANG3)
53299 SPHI3=SIN(ANG3)
53300 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
53301 ARG=1D0-CTHE3**2
53302 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53303 STHE3=SQRT(ARG)
53304 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
53305 &+P3*STHE3*SPHI3*SPHI1
53306 &+P3*CTHE3*STHE1*CPHI1
53307 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
53308 &-P3*STHE3*SPHI3*CPHI1
53309 &+P3*CTHE3*STHE1*SPHI1
53310 P(N+3,3)=P3*STHE3*CPHI3*STHE1
53311 &+P3*CTHE3*CTHE1
53312 P(N+3,4)=D3
53313
53314 DO 200 I=1,3
53315 P(N+2,I)=-P(N+1,I)-P(N+3,I)
53316 200 CONTINUE
53317 P(N+2,4)=D2
53318
53319 RETURN
53320 END
53321
53322
53323C*********************************************************************
53324
53325C...PYTECM
53326C...Finds the s-hat dependent eigenvalues of the inverse propagator
53327C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
53328C...phase space generation. Extended to include techni-a meson, and
53329C...to return the width.
53330
53331 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
53332
53333C...Double precision and integer declarations.
53334 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53335 IMPLICIT INTEGER(I-N)
53336 INTEGER PYK,PYCHGE,PYCOMP
53337C...Parameter statement to help give large particle numbers.
53338 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53339 &KEXCIT=4000000,KDIMEN=5000000)
53340C...Commonblocks.
53341 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53342 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53343 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53344 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53345 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
53346
53347C...Local variables.
53348 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
53349 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
53350 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
53351 INTEGER i,j,ierr
53352
53353 SH=SMIN
53354 SHR=SQRT(SH)
53355 AEM=PYALEM(SH)
53356
53357 SINW=MIN(SQRT(PARU(102)),1D0)
53358 COSW=SQRT(1D0-SINW**2)
53359 TANW=SINW/COSW
53360 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
53361 QUPD=2D0*RTCM(2)-1D0
53362
53363 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
53364 FAR=SQRT(AEM/ALPRHT)
53365 FAO=FAR*QUPD
53366 FZR=FAR*CT2W
53367 FZO=-FAO*TANW
53368 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
53369 FWR=FAR/(2D0*SINW)
53370 FWX=-FWR/RTCM(47)
53371
53372 DO 110 I=1,5
53373 DO 100 J=1,5
53374 AT(I,J)=0D0
53375 100 CONTINUE
53376 110 CONTINUE
53377
53378C...NC
53379 IF(IOPT.EQ.1) THEN
53380 AR(1,1) = SH
53381 AR(2,2) = SH-PMAS(23,1)**2
53382 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
53383 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
53384 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
53385 AR(1,2) = 0D0
53386 AR(2,1) = 0D0
53387 AR(1,3) = SH*FAR
53388 AR(3,1) = AR(1,3)
53389 AR(1,4) = SH*FAO
53390 AR(4,1) = AR(1,4)
53391 AR(2,3) = SH*FZR
53392 AR(3,2) = AR(2,3)
53393 AR(2,4) = SH*FZO
53394 AR(4,2) = AR(2,4)
53395 AR(3,4) = 0D0
53396 AR(4,3) = 0D0
53397 AR(2,5) = SH*FZX
53398 AR(5,2) = AR(2,5)
53399 AR(1,5) = 0D0
53400 AR(5,1) = AR(1,5)
53401 AR(3,5) = 0D0
53402 AR(5,3) = AR(3,5)
53403 AR(4,5) = 0D0
53404 AR(5,4) = AR(4,5)
53405 CALL PYWIDT(23,SH,WDTP,WDTE)
53406 AT(2,2) = WDTP(0)*SHR
53407 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
53408 AT(3,3) = WDTP(0)*SHR
53409 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
53410 AT(4,4) = WDTP(0)*SHR
53411 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
53412 AT(5,5) = WDTP(0)*SHR
53413 IDIM=5
53414C...CC
53415 ELSE
53416 AR(1,1) = SH-PMAS(24,1)**2
53417 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
53418 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
53419 AR(1,2) = SH*FWR
53420 AR(2,1) = AR(1,2)
53421 AR(1,3) = SH*FWX
53422 AR(3,1) = AR(1,3)
53423 AR(2,3) = 0D0
53424 AR(3,2) = 0D0
53425 CALL PYWIDT(24,SH,WDTP,WDTE)
53426 AT(1,1) = WDTP(0)*SHR
53427 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
53428 AT(2,2) = WDTP(0)*SHR
53429 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
53430 AT(3,3) = WDTP(0)*SHR
53431 IDIM=3
53432 ENDIF
53433 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
53434
53435 IMIN=1
53436 SXMN=1D20
53437 DO 120 I=1,IDIM
53438 WX(I)=SQRT(ABS(SH-WR(I)))
53439 WR(I)=ABS(WR(I))
53440 IF(WR(I).LT.SXMN) THEN
53441 SXMN=WR(I)
53442 IMIN=I
53443 ENDIF
53444 120 CONTINUE
53445 SMOU=WX(IMIN)**2
53446 WIDO=WI(IMIN)/SHR
53447
53448 RETURN
53449 END
53450
53451C*********************************************************************
53452
53453C...PYEIGC
53454C...Finds eigenvalues of a general complex matrix
53455C
53456C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
53457C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
53458C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
53459C OF A COMPLEX GENERAL MATRIX.
53460C
53461C ON INPUT
53462C
53463C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
53464C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53465C DIMENSION STATEMENT.
53466C
53467C N IS THE ORDER OF THE MATRIX A=(AR,AI).
53468C
53469C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53470C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
53471C
53472C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
53473C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
53474C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
53475C
53476C ON OUTPUT
53477C
53478C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53479C RESPECTIVELY, OF THE EIGENVALUES.
53480C
53481C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53482C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
53483C
53484C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
53485C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
53486C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
53487C
53488C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
53489C
53490C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53491C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53492C
53493C THIS VERSION DATED AUGUST 1983.
53494C
53495
53496 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
53497
53498 INTEGER N,NM,IS1,IS2,IERR,MATZ
53499 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53500 X FV1(5),FV2(5),FV3(5)
53501 IF (N .LE. NM) GOTO 100
53502 IERR = 10 * N
53503 GOTO 120
53504C
53505 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
53506 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
53507 IF (MATZ .NE. 0) GOTO 110
53508C .......... FIND EIGENVALUES ONLY ..........
53509 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
53510 GOTO 120
53511C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
53512 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
53513 IF (IERR .NE. 0) GOTO 120
53514 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
53515 120 RETURN
53516 END
53517
53518C*********************************************************************
53519
53520C...PYCMQR
53521C...Auxiliary to PYEICG.
53522C
53523C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53524C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
53525C AND WILKINSON.
53526C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
53527C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53528C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53529C
53530C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
53531C UPPER HESSENBERG MATRIX BY THE QR METHOD.
53532C
53533C ON INPUT
53534C
53535C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53536C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53537C DIMENSION STATEMENT.
53538C
53539C N IS THE ORDER OF THE MATRIX.
53540C
53541C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53542C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53543C SET LOW=1, IGH=N.
53544C
53545C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53546C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53547C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
53548C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
53549C THE REDUCTION BY CORTH, IF PERFORMED.
53550C
53551C ON OUTPUT
53552C
53553C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
53554C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
53555C CALLING COMQR IF SUBSEQUENT CALCULATION OF
53556C EIGENVECTORS IS TO BE PERFORMED.
53557C
53558C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53559C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53560C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53561C FOR INDICES IERR+1,...,N.
53562C
53563C IERR IS SET TO
53564C ZERO FOR NORMAL RETURN,
53565C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53566C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53567C
53568C CALLS PYCDIV FOR COMPLEX DIVISION.
53569C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53570C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53571C
53572C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53573C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53574C
53575C THIS VERSION DATED AUGUST 1983.
53576C
53577
53578 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
53579
53580 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
53581 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
53582 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53583 X PYTHAG
53584
53585 IERR = 0
53586 IF (LOW .EQ. IGH) GOTO 130
53587C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53588 L = LOW + 1
53589C
53590 DO 120 I = L, IGH
53591 LL = MIN0(I+1,IGH)
53592 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
53593 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53594 YR = HR(I,I-1) / NORM
53595 YI = HI(I,I-1) / NORM
53596 HR(I,I-1) = NORM
53597 HI(I,I-1) = 0.0D0
53598C
53599 DO 100 J = I, IGH
53600 SI = YR * HI(I,J) - YI * HR(I,J)
53601 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53602 HI(I,J) = SI
53603 100 CONTINUE
53604C
53605 DO 110 J = LOW, LL
53606 SI = YR * HI(J,I) + YI * HR(J,I)
53607 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53608 HI(J,I) = SI
53609 110 CONTINUE
53610C
53611 120 CONTINUE
53612C .......... STORE ROOTS ISOLATED BY CBAL ..........
53613 130 DO 140 I = 1, N
53614 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53615 WR(I) = HR(I,I)
53616 WI(I) = HI(I,I)
53617 140 CONTINUE
53618C
53619 EN = IGH
53620 TR = 0.0D0
53621 TI = 0.0D0
53622 ITN = 30*N
53623C .......... SEARCH FOR NEXT EIGENVALUE ..........
53624 150 IF (EN .LT. LOW) GOTO 320
53625 ITS = 0
53626 ENM1 = EN - 1
53627C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53628C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
53629 160 DO 170 LL = LOW, EN
53630 L = EN + LOW - LL
53631 IF (L .EQ. LOW) GOTO 180
53632 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53633 X + DABS(HR(L,L)) + DABS(HI(L,L))
53634 TST2 = TST1 + DABS(HR(L,L-1))
53635 IF (TST2 .EQ. TST1) GOTO 180
53636 170 CONTINUE
53637C .......... FORM SHIFT ..........
53638 180 IF (L .EQ. EN) GOTO 300
53639 IF (ITN .EQ. 0) GOTO 310
53640 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
53641 SR = HR(EN,EN)
53642 SI = HI(EN,EN)
53643 XR = HR(ENM1,EN) * HR(EN,ENM1)
53644 XI = HI(ENM1,EN) * HR(EN,ENM1)
53645 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
53646 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53647 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53648 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53649 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
53650 ZZR = -ZZR
53651 ZZI = -ZZI
53652 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53653 SR = SR - XR
53654 SI = SI - XI
53655 GOTO 210
53656C .......... FORM EXCEPTIONAL SHIFT ..........
53657 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53658 SI = 0.0D0
53659C
53660 210 DO 220 I = LOW, EN
53661 HR(I,I) = HR(I,I) - SR
53662 HI(I,I) = HI(I,I) - SI
53663 220 CONTINUE
53664C
53665 TR = TR + SR
53666 TI = TI + SI
53667 ITS = ITS + 1
53668 ITN = ITN - 1
53669C .......... REDUCE TO TRIANGLE (ROWS) ..........
53670 LP1 = L + 1
53671C
53672 DO 240 I = LP1, EN
53673 SR = HR(I,I-1)
53674 HR(I,I-1) = 0.0D0
53675 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53676 XR = HR(I-1,I-1) / NORM
53677 WR(I-1) = XR
53678 XI = HI(I-1,I-1) / NORM
53679 WI(I-1) = XI
53680 HR(I-1,I-1) = NORM
53681 HI(I-1,I-1) = 0.0D0
53682 HI(I,I-1) = SR / NORM
53683C
53684 DO 230 J = I, EN
53685 YR = HR(I-1,J)
53686 YI = HI(I-1,J)
53687 ZZR = HR(I,J)
53688 ZZI = HI(I,J)
53689 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53690 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53691 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53692 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53693 230 CONTINUE
53694C
53695 240 CONTINUE
53696C
53697 SI = HI(EN,EN)
53698 IF (SI .EQ. 0.0D0) GOTO 250
53699 NORM = PYTHAG(HR(EN,EN),SI)
53700 SR = HR(EN,EN) / NORM
53701 SI = SI / NORM
53702 HR(EN,EN) = NORM
53703 HI(EN,EN) = 0.0D0
53704C .......... INVERSE OPERATION (COLUMNS) ..........
53705 250 DO 280 J = LP1, EN
53706 XR = WR(J-1)
53707 XI = WI(J-1)
53708C
53709 DO 270 I = L, J
53710 YR = HR(I,J-1)
53711 YI = 0.0D0
53712 ZZR = HR(I,J)
53713 ZZI = HI(I,J)
53714 IF (I .EQ. J) GOTO 260
53715 YI = HI(I,J-1)
53716 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
53717 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
53718 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
53719 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
53720 270 CONTINUE
53721C
53722 280 CONTINUE
53723C
53724 IF (SI .EQ. 0.0D0) GOTO 160
53725C
53726 DO 290 I = L, EN
53727 YR = HR(I,EN)
53728 YI = HI(I,EN)
53729 HR(I,EN) = SR * YR - SI * YI
53730 HI(I,EN) = SR * YI + SI * YR
53731 290 CONTINUE
53732C
53733 GOTO 160
53734C .......... A ROOT FOUND ..........
53735 300 WR(EN) = HR(EN,EN) + TR
53736 WI(EN) = HI(EN,EN) + TI
53737 EN = ENM1
53738 GOTO 150
53739C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
53740C CONVERGED AFTER 30*N ITERATIONS ..........
53741 310 IERR = EN
53742 320 RETURN
53743 END
53744
53745C*********************************************************************
53746
53747C...PYCMQ2
53748C...Auxiliary to PYEICG.
53749C
53750C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53751C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
53752C AND WILKINSON.
53753C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
53754C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53755C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53756C
53757C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
53758C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
53759C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
53760C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
53761C THIS GENERAL MATRIX TO HESSENBERG FORM.
53762C
53763C ON INPUT
53764C
53765C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53766C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53767C DIMENSION STATEMENT.
53768C
53769C N IS THE ORDER OF THE MATRIX.
53770C
53771C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53772C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53773C SET LOW=1, IGH=N.
53774C
53775C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
53776C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
53777C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
53778C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
53779C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
53780C
53781C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53782C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53783C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
53784C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
53785C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
53786C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
53787C ARBITRARY.
53788C
53789C ON OUTPUT
53790C
53791C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
53792C HAVE BEEN DESTROYED.
53793C
53794C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53795C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53796C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53797C FOR INDICES IERR+1,...,N.
53798C
53799C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53800C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
53801C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
53802C THE EIGENVECTORS HAS BEEN FOUND.
53803C
53804C IERR IS SET TO
53805C ZERO FOR NORMAL RETURN,
53806C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53807C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53808C
53809C CALLS PYCDIV FOR COMPLEX DIVISION.
53810C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53811C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53812C
53813C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53814C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53815C
53816C THIS VERSION DATED OCTOBER 1989.
53817C
53818C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
53819C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
53820C
53821
53822 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
53823
53824 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
53825 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
53826 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53827 X ORTR(5),ORTI(5)
53828 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53829 X PYTHAG
53830
53831 IERR = 0
53832C .......... INITIALIZE EIGENVECTOR MATRIX ..........
53833 DO 110 J = 1, N
53834C
53835 DO 100 I = 1, N
53836 ZR(I,J) = 0.0D0
53837 ZI(I,J) = 0.0D0
53838 100 CONTINUE
53839 ZR(J,J) = 1.0D0
53840 110 CONTINUE
53841C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
53842C FROM THE INFORMATION LEFT BY CORTH ..........
53843 IEND = IGH - LOW - 1
53844 IF (IEND.LT.0) GOTO 220
53845 IF (IEND.EQ.0) GOTO 170
53846C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
53847 DO 160 II = 1, IEND
53848 I = IGH - II
53849 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
53850 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
53851C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
53852 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
53853 IP1 = I + 1
53854C
53855 DO 120 K = IP1, IGH
53856 ORTR(K) = HR(K,I-1)
53857 ORTI(K) = HI(K,I-1)
53858 120 CONTINUE
53859C
53860 DO 150 J = I, IGH
53861 SR = 0.0D0
53862 SI = 0.0D0
53863C
53864 DO 130 K = I, IGH
53865 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
53866 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
53867 130 CONTINUE
53868C
53869 SR = SR / NORM
53870 SI = SI / NORM
53871C
53872 DO 140 K = I, IGH
53873 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
53874 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
53875 140 CONTINUE
53876C
53877 150 CONTINUE
53878C
53879 160 CONTINUE
53880C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53881 170 L = LOW + 1
53882C
53883 DO 210 I = L, IGH
53884 LL = MIN0(I+1,IGH)
53885 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
53886 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53887 YR = HR(I,I-1) / NORM
53888 YI = HI(I,I-1) / NORM
53889 HR(I,I-1) = NORM
53890 HI(I,I-1) = 0.0D0
53891C
53892 DO 180 J = I, N
53893 SI = YR * HI(I,J) - YI * HR(I,J)
53894 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53895 HI(I,J) = SI
53896 180 CONTINUE
53897C
53898 DO 190 J = 1, LL
53899 SI = YR * HI(J,I) + YI * HR(J,I)
53900 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53901 HI(J,I) = SI
53902 190 CONTINUE
53903C
53904 DO 200 J = LOW, IGH
53905 SI = YR * ZI(J,I) + YI * ZR(J,I)
53906 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
53907 ZI(J,I) = SI
53908 200 CONTINUE
53909C
53910 210 CONTINUE
53911C .......... STORE ROOTS ISOLATED BY CBAL ..........
53912 220 DO 230 I = 1, N
53913 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
53914 WR(I) = HR(I,I)
53915 WI(I) = HI(I,I)
53916 230 CONTINUE
53917C
53918 EN = IGH
53919 TR = 0.0D0
53920 TI = 0.0D0
53921 ITN = 30*N
53922C .......... SEARCH FOR NEXT EIGENVALUE ..........
53923 240 IF (EN .LT. LOW) GOTO 430
53924 ITS = 0
53925 ENM1 = EN - 1
53926C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53927C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
53928 250 DO 260 LL = LOW, EN
53929 L = EN + LOW - LL
53930 IF (L .EQ. LOW) GOTO 270
53931 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53932 X + DABS(HR(L,L)) + DABS(HI(L,L))
53933 TST2 = TST1 + DABS(HR(L,L-1))
53934 IF (TST2 .EQ. TST1) GOTO 270
53935 260 CONTINUE
53936C .......... FORM SHIFT ..........
53937 270 IF (L .EQ. EN) GOTO 420
53938 IF (ITN .EQ. 0) GOTO 550
53939 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
53940 SR = HR(EN,EN)
53941 SI = HI(EN,EN)
53942 XR = HR(ENM1,EN) * HR(EN,ENM1)
53943 XI = HI(ENM1,EN) * HR(EN,ENM1)
53944 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
53945 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53946 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53947 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53948 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
53949 ZZR = -ZZR
53950 ZZI = -ZZI
53951 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53952 SR = SR - XR
53953 SI = SI - XI
53954 GOTO 300
53955C .......... FORM EXCEPTIONAL SHIFT ..........
53956 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53957 SI = 0.0D0
53958C
53959 300 DO 310 I = LOW, EN
53960 HR(I,I) = HR(I,I) - SR
53961 HI(I,I) = HI(I,I) - SI
53962 310 CONTINUE
53963C
53964 TR = TR + SR
53965 TI = TI + SI
53966 ITS = ITS + 1
53967 ITN = ITN - 1
53968C .......... REDUCE TO TRIANGLE (ROWS) ..........
53969 LP1 = L + 1
53970C
53971 DO 330 I = LP1, EN
53972 SR = HR(I,I-1)
53973 HR(I,I-1) = 0.0D0
53974 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53975 XR = HR(I-1,I-1) / NORM
53976 WR(I-1) = XR
53977 XI = HI(I-1,I-1) / NORM
53978 WI(I-1) = XI
53979 HR(I-1,I-1) = NORM
53980 HI(I-1,I-1) = 0.0D0
53981 HI(I,I-1) = SR / NORM
53982C
53983 DO 320 J = I, N
53984 YR = HR(I-1,J)
53985 YI = HI(I-1,J)
53986 ZZR = HR(I,J)
53987 ZZI = HI(I,J)
53988 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53989 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53990 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53991 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53992 320 CONTINUE
53993C
53994 330 CONTINUE
53995C
53996 SI = HI(EN,EN)
53997 IF (SI .EQ. 0.0D0) GOTO 350
53998 NORM = PYTHAG(HR(EN,EN),SI)
53999 SR = HR(EN,EN) / NORM
54000 SI = SI / NORM
54001 HR(EN,EN) = NORM
54002 HI(EN,EN) = 0.0D0
54003 IF (EN .EQ. N) GOTO 350
54004 IP1 = EN + 1
54005C
54006 DO 340 J = IP1, N
54007 YR = HR(EN,J)
54008 YI = HI(EN,J)
54009 HR(EN,J) = SR * YR + SI * YI
54010 HI(EN,J) = SR * YI - SI * YR
54011 340 CONTINUE
54012C .......... INVERSE OPERATION (COLUMNS) ..........
54013 350 DO 390 J = LP1, EN
54014 XR = WR(J-1)
54015 XI = WI(J-1)
54016C
54017 DO 370 I = 1, J
54018 YR = HR(I,J-1)
54019 YI = 0.0D0
54020 ZZR = HR(I,J)
54021 ZZI = HI(I,J)
54022 IF (I .EQ. J) GOTO 360
54023 YI = HI(I,J-1)
54024 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54025 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54026 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54027 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54028 370 CONTINUE
54029C
54030 DO 380 I = LOW, IGH
54031 YR = ZR(I,J-1)
54032 YI = ZI(I,J-1)
54033 ZZR = ZR(I,J)
54034 ZZI = ZI(I,J)
54035 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54036 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54037 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54038 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54039 380 CONTINUE
54040C
54041 390 CONTINUE
54042C
54043 IF (SI .EQ. 0.0D0) GOTO 250
54044C
54045 DO 400 I = 1, EN
54046 YR = HR(I,EN)
54047 YI = HI(I,EN)
54048 HR(I,EN) = SR * YR - SI * YI
54049 HI(I,EN) = SR * YI + SI * YR
54050 400 CONTINUE
54051C
54052 DO 410 I = LOW, IGH
54053 YR = ZR(I,EN)
54054 YI = ZI(I,EN)
54055 ZR(I,EN) = SR * YR - SI * YI
54056 ZI(I,EN) = SR * YI + SI * YR
54057 410 CONTINUE
54058C
54059 GOTO 250
54060C .......... A ROOT FOUND ..........
54061 420 HR(EN,EN) = HR(EN,EN) + TR
54062 WR(EN) = HR(EN,EN)
54063 HI(EN,EN) = HI(EN,EN) + TI
54064 WI(EN) = HI(EN,EN)
54065 EN = ENM1
54066 GOTO 240
54067C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
54068C VECTORS OF UPPER TRIANGULAR FORM ..........
54069 430 NORM = 0.0D0
54070C
54071 DO 440 I = 1, N
54072C
54073 DO 440 J = I, N
54074 TR = DABS(HR(I,J)) + DABS(HI(I,J))
54075 IF (TR .GT. NORM) NORM = TR
54076 440 CONTINUE
54077C
54078 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
54079C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
54080 DO 500 NN = 2, N
54081 EN = N + 2 - NN
54082 XR = WR(EN)
54083 XI = WI(EN)
54084 HR(EN,EN) = 1.0D0
54085 HI(EN,EN) = 0.0D0
54086 ENM1 = EN - 1
54087C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
54088 DO 490 II = 1, ENM1
54089 I = EN - II
54090 ZZR = 0.0D0
54091 ZZI = 0.0D0
54092 IP1 = I + 1
54093C
54094 DO 450 J = IP1, EN
54095 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
54096 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
54097 450 CONTINUE
54098C
54099 YR = XR - WR(I)
54100 YI = XI - WI(I)
54101 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
54102 TST1 = NORM
54103 YR = TST1
54104 460 YR = 0.01D0 * YR
54105 TST2 = NORM + YR
54106 IF (TST2 .GT. TST1) GOTO 460
54107 470 CONTINUE
54108 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
54109C .......... OVERFLOW CONTROL ..........
54110 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
54111 IF (TR .EQ. 0.0D0) GOTO 490
54112 TST1 = TR
54113 TST2 = TST1 + 1.0D0/TST1
54114 IF (TST2 .GT. TST1) GOTO 490
54115 DO 480 J = I, EN
54116 HR(J,EN) = HR(J,EN)/TR
54117 HI(J,EN) = HI(J,EN)/TR
54118 480 CONTINUE
54119C
54120 490 CONTINUE
54121C
54122 500 CONTINUE
54123C .......... END BACKSUBSTITUTION ..........
54124C .......... VECTORS OF ISOLATED ROOTS ..........
54125 DO 520 I = 1, N
54126 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
54127C
54128 DO 510 J = I, N
54129 ZR(I,J) = HR(I,J)
54130 ZI(I,J) = HI(I,J)
54131 510 CONTINUE
54132C
54133 520 CONTINUE
54134C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
54135C VECTORS OF ORIGINAL FULL MATRIX.
54136C FOR J=N STEP -1 UNTIL LOW DO -- ..........
54137 DO 540 JJ = LOW, N
54138 J = N + LOW - JJ
54139 M = MIN0(J,IGH)
54140C
54141 DO 540 I = LOW, IGH
54142 ZZR = 0.0D0
54143 ZZI = 0.0D0
54144C
54145 DO 530 K = LOW, M
54146 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
54147 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
54148 530 CONTINUE
54149C
54150 ZR(I,J) = ZZR
54151 ZI(I,J) = ZZI
54152 540 CONTINUE
54153C
54154 GOTO 560
54155C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
54156C CONVERGED AFTER 30*N ITERATIONS ..........
54157 550 IERR = EN
54158 560 RETURN
54159 END
54160
54161C*********************************************************************
54162
54163C...PYCDIV
54164C...Auxiliary to PYCMQR
54165C
54166C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
54167C
54168
54169 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
54170
54171 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
54172 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
54173
54174 S = DABS(BR) + DABS(BI)
54175 ARS = AR/S
54176 AIS = AI/S
54177 BRS = BR/S
54178 BIS = BI/S
54179 S = BRS**2 + BIS**2
54180 CR = (ARS*BRS + AIS*BIS)/S
54181 CI = (AIS*BRS - ARS*BIS)/S
54182 RETURN
54183 END
54184
54185C*********************************************************************
54186
54187C...PYCSRT
54188C...Auxiliary to PYCMQR
54189C
54190C (YR,YI) = COMPLEX DSQRT(XR,XI)
54191C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
54192C
54193
54194 SUBROUTINE PYCSRT(XR,XI,YR,YI)
54195
54196 DOUBLE PRECISION XR,XI,YR,YI
54197 DOUBLE PRECISION S,TR,TI,PYTHAG
54198
54199 TR = XR
54200 TI = XI
54201 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
54202 IF (TR .GE. 0.0D0) YR = S
54203 IF (TI .LT. 0.0D0) S = -S
54204 IF (TR .LE. 0.0D0) YI = S
54205 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
54206 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
54207 RETURN
54208 END
54209
54210 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
54211 DOUBLE PRECISION A,B
54212C
54213C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
54214C
54215 DOUBLE PRECISION P,R,S,T,U
54216 P = DMAX1(DABS(A),DABS(B))
54217 IF (P .EQ. 0.0D0) GOTO 110
54218 R = (DMIN1(DABS(A),DABS(B))/P)**2
54219 100 CONTINUE
54220 T = 4.0D0 + R
54221 IF (T .EQ. 4.0D0) GOTO 110
54222 S = R/T
54223 U = 1.0D0 + 2.0D0*S
54224 P = U*P
54225 R = (S/U)**2 * R
54226 GOTO 100
54227 110 PYTHAG = P
54228 RETURN
54229 END
54230
54231C*********************************************************************
54232
54233C...PYCBAL
54234C...Auxiliary to PYEICG
54235C
54236C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54237C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
54238C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54239C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54240C
54241C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
54242C EIGENVALUES WHENEVER POSSIBLE.
54243C
54244C ON INPUT
54245C
54246C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54247C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54248C DIMENSION STATEMENT.
54249C
54250C N IS THE ORDER OF THE MATRIX.
54251C
54252C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54253C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
54254C
54255C ON OUTPUT
54256C
54257C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54258C RESPECTIVELY, OF THE BALANCED MATRIX.
54259C
54260C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
54261C ARE EQUAL TO ZERO IF
54262C (1) I IS GREATER THAN J AND
54263C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
54264C
54265C SCALE CONTAINS INFORMATION DETERMINING THE
54266C PERMUTATIONS AND SCALING FACTORS USED.
54267C
54268C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
54269C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
54270C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
54271C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
54272C SCALE(J) = P(J), FOR J = 1,...,LOW-1
54273C = D(J,J) J = LOW,...,IGH
54274C = P(J) J = IGH+1,...,N.
54275C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
54276C THEN 1 TO LOW-1.
54277C
54278C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
54279C
54280C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
54281C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
54282C K,L HAVE BEEN REVERSED.)
54283C
54284C ARITHMETIC IS REAL THROUGHOUT.
54285C
54286C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54287C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54288C
54289C THIS VERSION DATED AUGUST 1983.
54290C
54291
54292 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
54293
54294 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
54295 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
54296 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
54297 LOGICAL NOCONV
54298
54299 RADIX = 16.0D0
54300C
54301 B2 = RADIX * RADIX
54302 K = 1
54303 L = N
54304 GOTO 150
54305C .......... IN-LINE PROCEDURE FOR ROW AND
54306C COLUMN EXCHANGE ..........
54307 100 SCALE(M) = J
54308 IF (J .EQ. M) GOTO 130
54309C
54310 DO 110 I = 1, L
54311 F = AR(I,J)
54312 AR(I,J) = AR(I,M)
54313 AR(I,M) = F
54314 F = AI(I,J)
54315 AI(I,J) = AI(I,M)
54316 AI(I,M) = F
54317 110 CONTINUE
54318C
54319 DO 120 I = K, N
54320 F = AR(J,I)
54321 AR(J,I) = AR(M,I)
54322 AR(M,I) = F
54323 F = AI(J,I)
54324 AI(J,I) = AI(M,I)
54325 AI(M,I) = F
54326 120 CONTINUE
54327C
54328 130 IF(IEXC.EQ.1) GOTO 140
54329 IF(IEXC.EQ.2) GOTO 180
54330C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
54331C AND PUSH THEM DOWN ..........
54332 140 IF (L .EQ. 1) GOTO 320
54333 L = L - 1
54334C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
54335 150 DO 170 JJ = 1, L
54336 J = L + 1 - JJ
54337C
54338 DO 160 I = 1, L
54339 IF (I .EQ. J) GOTO 160
54340 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
54341 160 CONTINUE
54342C
54343 M = L
54344 IEXC = 1
54345 GOTO 100
54346 170 CONTINUE
54347C
54348 GOTO 190
54349C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
54350C AND PUSH THEM LEFT ..........
54351 180 K = K + 1
54352C
54353 190 DO 210 J = K, L
54354C
54355 DO 200 I = K, L
54356 IF (I .EQ. J) GOTO 200
54357 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
54358 200 CONTINUE
54359C
54360 M = K
54361 IEXC = 2
54362 GOTO 100
54363 210 CONTINUE
54364C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
54365 DO 220 I = K, L
54366 220 SCALE(I) = 1.0D0
54367C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
54368 230 NOCONV = .FALSE.
54369C
54370 DO 310 I = K, L
54371 C = 0.0D0
54372 R = 0.0D0
54373C
54374 DO 240 J = K, L
54375 IF (J .EQ. I) GOTO 240
54376 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
54377 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
54378 240 CONTINUE
54379C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
54380 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
54381 G = R / RADIX
54382 F = 1.0D0
54383 S = C + R
54384 250 IF (C .GE. G) GOTO 260
54385 F = F * RADIX
54386 C = C * B2
54387 GOTO 250
54388 260 G = R * RADIX
54389 270 IF (C .LT. G) GOTO 280
54390 F = F / RADIX
54391 C = C / B2
54392 GOTO 270
54393C .......... NOW BALANCE ..........
54394 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
54395 G = 1.0D0 / F
54396 SCALE(I) = SCALE(I) * F
54397 NOCONV = .TRUE.
54398C
54399 DO 290 J = K, N
54400 AR(I,J) = AR(I,J) * G
54401 AI(I,J) = AI(I,J) * G
54402 290 CONTINUE
54403C
54404 DO 300 J = 1, L
54405 AR(J,I) = AR(J,I) * F
54406 AI(J,I) = AI(J,I) * F
54407 300 CONTINUE
54408C
54409 310 CONTINUE
54410C
54411 IF (NOCONV) GOTO 230
54412C
54413 320 LOW = K
54414 IGH = L
54415 RETURN
54416 END
54417
54418C*********************************************************************
54419
54420C...PYCBA2
54421C...Auxiliary to PYEICG.
54422C
54423C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54424C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
54425C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54426C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54427C
54428C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
54429C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
54430C BALANCED MATRIX DETERMINED BY CBAL.
54431C
54432C ON INPUT
54433C
54434C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54435C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54436C DIMENSION STATEMENT.
54437C
54438C N IS THE ORDER OF THE MATRIX.
54439C
54440C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
54441C
54442C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
54443C AND SCALING FACTORS USED BY CBAL.
54444C
54445C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
54446C
54447C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54448C RESPECTIVELY, OF THE EIGENVECTORS TO BE
54449C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
54450C
54451C ON OUTPUT
54452C
54453C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54454C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
54455C IN THEIR FIRST M COLUMNS.
54456C
54457C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54458C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54459C
54460C THIS VERSION DATED AUGUST 1983.
54461C
54462
54463 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
54464
54465 INTEGER I,J,K,M,N,II,NM,IGH,LOW
54466 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
54467 DOUBLE PRECISION S
54468
54469 IF (M .EQ. 0) GOTO 150
54470 IF (IGH .EQ. LOW) GOTO 120
54471C
54472 DO 110 I = LOW, IGH
54473 S = SCALE(I)
54474C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
54475C IF THE FOREGOING STATEMENT IS REPLACED BY
54476C S=1.0D0/SCALE(I). ..........
54477 DO 100 J = 1, M
54478 ZR(I,J) = ZR(I,J) * S
54479 ZI(I,J) = ZI(I,J) * S
54480 100 CONTINUE
54481C
54482 110 CONTINUE
54483C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
54484C IGH+1 STEP 1 UNTIL N DO -- ..........
54485 120 DO 140 II = 1, N
54486 I = II
54487 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
54488 IF (I .LT. LOW) I = LOW - II
54489 K = SCALE(I)
54490 IF (K .EQ. I) GOTO 140
54491C
54492 DO 130 J = 1, M
54493 S = ZR(I,J)
54494 ZR(I,J) = ZR(K,J)
54495 ZR(K,J) = S
54496 S = ZI(I,J)
54497 ZI(I,J) = ZI(K,J)
54498 ZI(K,J) = S
54499 130 CONTINUE
54500C
54501 140 CONTINUE
54502C
54503 150 RETURN
54504 END
54505
54506C*********************************************************************
54507
54508C...PYCRTH
54509C...Auxiliary to PYEICG.
54510C
54511C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
54512C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
54513C BY MARTIN AND WILKINSON.
54514C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
54515C
54516C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
54517C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
54518C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
54519C UNITARY SIMILARITY TRANSFORMATIONS.
54520C
54521C ON INPUT
54522C
54523C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54524C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54525C DIMENSION STATEMENT.
54526C
54527C N IS THE ORDER OF THE MATRIX.
54528C
54529C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
54530C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
54531C SET LOW=1, IGH=N.
54532C
54533C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54534C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
54535C
54536C ON OUTPUT
54537C
54538C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54539C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
54540C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
54541C IS STORED IN THE REMAINING TRIANGLES UNDER THE
54542C HESSENBERG MATRIX.
54543C
54544C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
54545C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
54546C
54547C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
54548C
54549C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54550C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54551C
54552C THIS VERSION DATED AUGUST 1983.
54553C
54554
54555 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
54556
54557 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
54558 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
54559 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
54560
54561 LA = IGH - 1
54562 KP1 = LOW + 1
54563 IF (LA .LT. KP1) GOTO 210
54564C
54565 DO 200 M = KP1, LA
54566 H = 0.0D0
54567 ORTR(M) = 0.0D0
54568 ORTI(M) = 0.0D0
54569 SCALE = 0.0D0
54570C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
54571 DO 100 I = M, IGH
54572 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
54573C
54574 IF (SCALE .EQ. 0.0D0) GOTO 200
54575 MP = M + IGH
54576C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54577 DO 110 II = M, IGH
54578 I = MP - II
54579 ORTR(I) = AR(I,M-1) / SCALE
54580 ORTI(I) = AI(I,M-1) / SCALE
54581 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
54582 110 CONTINUE
54583C
54584 G = DSQRT(H)
54585 F = PYTHAG(ORTR(M),ORTI(M))
54586 IF (F .EQ. 0.0D0) GOTO 120
54587 H = H + F * G
54588 G = G / F
54589 ORTR(M) = (1.0D0 + G) * ORTR(M)
54590 ORTI(M) = (1.0D0 + G) * ORTI(M)
54591 GOTO 130
54592C
54593 120 ORTR(M) = G
54594 AR(M,M-1) = SCALE
54595C .......... FORM (I-(U*UT)/H) * A ..........
54596 130 DO 160 J = M, N
54597 FR = 0.0D0
54598 FI = 0.0D0
54599C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54600 DO 140 II = M, IGH
54601 I = MP - II
54602 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
54603 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
54604 140 CONTINUE
54605C
54606 FR = FR / H
54607 FI = FI / H
54608C
54609 DO 150 I = M, IGH
54610 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
54611 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
54612 150 CONTINUE
54613C
54614 160 CONTINUE
54615C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
54616 DO 190 I = 1, IGH
54617 FR = 0.0D0
54618 FI = 0.0D0
54619C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
54620 DO 170 JJ = M, IGH
54621 J = MP - JJ
54622 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
54623 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
54624 170 CONTINUE
54625C
54626 FR = FR / H
54627 FI = FI / H
54628C
54629 DO 180 J = M, IGH
54630 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
54631 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
54632 180 CONTINUE
54633C
54634 190 CONTINUE
54635C
54636 ORTR(M) = SCALE * ORTR(M)
54637 ORTI(M) = SCALE * ORTI(M)
54638 AR(M,M-1) = -G * AR(M,M-1)
54639 AI(M,M-1) = -G * AI(M,M-1)
54640 200 CONTINUE
54641C
54642 210 RETURN
54643 END
54644
54645C*********************************************************************
54646
54647C...PYLDCM
54648C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54649C...processes.
54650
54651 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
54652 IMPLICIT NONE
54653 INTEGER N,NP,INDX(N)
54654 REAL*8 D,TINY
54655 COMPLEX*16 A(NP,NP)
54656 PARAMETER (TINY=1.0D-20)
54657 INTEGER I,IMAX,J,K
54658 REAL*8 AAMAX,VV(6),DUM
54659 COMPLEX*16 SUM,DUMC
54660
54661 D=1D0
54662 DO 110 I=1,N
54663 AAMAX=0D0
54664 DO 100 J=1,N
54665 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
54666 100 CONTINUE
54667 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
54668 VV(I)=1D0/AAMAX
54669 110 CONTINUE
54670 DO 180 J=1,N
54671 DO 130 I=1,J-1
54672 SUM=A(I,J)
54673 DO 120 K=1,I-1
54674 SUM=SUM-A(I,K)*A(K,J)
54675 120 CONTINUE
54676 A(I,J)=SUM
54677 130 CONTINUE
54678 AAMAX=0D0
54679 DO 150 I=J,N
54680 SUM=A(I,J)
54681 DO 140 K=1,J-1
54682 SUM=SUM-A(I,K)*A(K,J)
54683 140 CONTINUE
54684 A(I,J)=SUM
54685 DUM=VV(I)*ABS(SUM)
54686 IF (DUM.GE.AAMAX) THEN
54687 IMAX=I
54688 AAMAX=DUM
54689 ENDIF
54690 150 CONTINUE
54691 IF (J.NE.IMAX)THEN
54692 DO 160 K=1,N
54693 DUMC=A(IMAX,K)
54694 A(IMAX,K)=A(J,K)
54695 A(J,K)=DUMC
54696 160 CONTINUE
54697 D=-D
54698 VV(IMAX)=VV(J)
54699 ENDIF
54700 INDX(J)=IMAX
54701 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
54702 IF(J.NE.N)THEN
54703 DO 170 I=J+1,N
54704 A(I,J)=A(I,J)/A(J,J)
54705 170 CONTINUE
54706 ENDIF
54707 180 CONTINUE
54708
54709 RETURN
54710 END
54711
54712C*********************************************************************
54713
54714C...PYBKSB
54715C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54716C...processes.
54717
54718 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
54719 IMPLICIT NONE
54720 INTEGER N,NP,INDX(N)
54721 COMPLEX*16 A(NP,NP),B(N)
54722 INTEGER I,II,J,LL
54723 COMPLEX*16 SUM
54724
54725 II=0
54726 DO 110 I=1,N
54727 LL=INDX(I)
54728 SUM=B(LL)
54729 B(LL)=B(I)
54730 IF (II.NE.0)THEN
54731 DO 100 J=II,I-1
54732 SUM=SUM-A(I,J)*B(J)
54733 100 CONTINUE
54734 ELSE IF (ABS(SUM).NE.0D0) THEN
54735 II=I
54736 ENDIF
54737 B(I)=SUM
54738 110 CONTINUE
54739 DO 130 I=N,1,-1
54740 SUM=B(I)
54741 DO 120 J=I+1,N
54742 SUM=SUM-A(I,J)*B(J)
54743 120 CONTINUE
54744 B(I)=SUM/A(I,I)
54745 130 CONTINUE
54746 RETURN
54747 END
54748
54749C***********************************************************************
54750
54751C...PYWIDX
54752C...Calculates full and partial widths of resonances.
54753C....copy of PYWIDT, used for techniparticle widths
54754
54755 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
54756
54757C...Double precision and integer declarations.
54758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54759 IMPLICIT INTEGER(I-N)
54760 INTEGER PYK,PYCHGE,PYCOMP
54761C...Parameter statement to help give large particle numbers.
54762 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54763 &KEXCIT=4000000,KDIMEN=5000000)
54764C...Commonblocks.
54765 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54766 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54767 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54768 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54769 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54770 COMMON/PYINT1/MINT(400),VINT(400)
54771 COMMON/PYINT4/MWID(500),WIDS(500,5)
54772 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54773 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54774 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
54775 &/PYINT4/,/PYMSSM/,/PYTCSM/
54776C...Local arrays and saved variables.
54777 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
54778 &WID2SV(3,2)
54779 SAVE MOFSV,WIDWSV,WID2SV
54780 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
54781
54782C...Compressed code and sign; mass.
54783 KFLA=IABS(KFLR)
54784 KFLS=ISIGN(1,KFLR)
54785 KC=PYCOMP(KFLA)
54786 SHR=SQRT(SH)
54787 PMR=PMAS(KC,1)
54788
54789C...Reset width information.
54790 DO I=0,400
54791 WDTP(I)=0D0
54792 ENDDO
54793
54794C...Common electroweak and strong constants.
54795 XW=PARU(102)
54796 XWV=XW
54797 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
54798 XW1=1D0-XW
54799 AEM=PYALEM(SH)
54800 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
54801 AS=PYALPS(SH)
54802 RADC=1D0+AS/PARU(1)
54803
54804 IF(KFLA.EQ.23) THEN
54805C...Z0:
54806 XWC=1D0/(16D0*XW*XW1)
54807 FAC=(AEM*XWC/3D0)*SHR
54808 120 CONTINUE
54809 DO 130 I=1,MDCY(KC,3)
54810 IDC=I+MDCY(KC,2)-1
54811 IF(MDME(IDC,1).LT.0) GOTO 130
54812 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54813 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54814 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
54815 IF(I.LE.8) THEN
54816C...Z0 -> q + qbar
54817 EF=KCHG(I,1)/3D0
54818 AF=SIGN(1D0,EF+0.1D0)
54819 VF=AF-4D0*EF*XWV
54820 FCOF=3D0*RADC
54821 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
54822 ELSEIF(I.LE.16) THEN
54823C...Z0 -> l+ + l-, nu + nubar
54824 EF=KCHG(I+2,1)/3D0
54825 AF=SIGN(1D0,EF+0.1D0)
54826 VF=AF-4D0*EF*XWV
54827 FCOF=1D0
54828 ENDIF
54829 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
54830 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
54831 & BE34
54832 WDTP(0)=WDTP(0)+WDTP(I)
54833 130 CONTINUE
54834
54835
54836 ELSEIF(KFLA.EQ.24) THEN
54837C...W+/-:
54838 FAC=(AEM/(24D0*XW))*SHR
54839 DO 140 I=1,MDCY(KC,3)
54840 IDC=I+MDCY(KC,2)-1
54841 IF(MDME(IDC,1).LT.0) GOTO 140
54842 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54843 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54844 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
54845 WID2=1D0
54846 IF(I.LE.16) THEN
54847C...W+/- -> q + qbar'
54848 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
54849 ELSEIF(I.LE.20) THEN
54850C...W+/- -> l+/- + nu
54851 FCOF=1D0
54852 ENDIF
54853 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
54854 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
54855 WDTP(0)=WDTP(0)+WDTP(I)
54856 140 CONTINUE
54857
54858C.....V8 -> quark anti-quark
54859 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
54860 FAC=AS/6D0*SHR
54861 TANT3=RTCM(21)
54862 IF(ITCM(2).EQ.0) THEN
54863 IMDL=1
54864 ELSEIF(ITCM(2).EQ.1) THEN
54865 IMDL=2
54866 ENDIF
54867 DO 150 I=1,MDCY(KC,3)
54868 IDC=I+MDCY(KC,2)-1
54869 IF(MDME(IDC,1).LT.0) GOTO 150
54870 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
54871 RM1=PM1**2/SH
54872 IF(RM1.GT.0.25D0) GOTO 150
54873 WID2=1D0
54874 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
54875 FMIX=1D0/TANT3**2
54876 ELSE
54877 FMIX=TANT3**2
54878 ENDIF
54879 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
54880 IF(I.EQ.6) WID2=WIDS(6,1)
54881 WDTP(0)=WDTP(0)+WDTP(I)
54882 150 CONTINUE
54883 ENDIF
54884
54885 RETURN
54886 END
54887
54888C*********************************************************************
54889
54890C...PYRVSF
54891C...Calculates R-violating decays of sfermions.
54892C...P. Z. Skands
54893
54894 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
54895
54896C...Double precision and integer declarations.
54897 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54898 IMPLICIT INTEGER(I-N)
54899C...Parameter statement to help give large particle numbers.
54900 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54901 &KEXCIT=4000000,KDIMEN=5000000)
54902C...Commonblocks.
54903 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54904 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54905 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54906 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54907 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54908C...Local variables.
54909 DOUBLE PRECISION XLAM(0:400)
54910 INTEGER IDLAM(400,3), PYCOMP
54911 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
54912
54913C...IS R-VIOLATION ON ?
54914 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54915C...Mass eigenstate counter
54916 ICNT=INT(KFIN/KSUSY1)
54917C...SM KF code of SUSY particle
54918 KFSM=KFIN-ICNT*KSUSY1
54919C...Squared Sparticle Mass
54920 SM=PMAS(PYCOMP(KFIN),1)**2
54921C... Squared mass of top quark
54922 SMT=PMAS(PYCOMP(6),1)**2
54923C...IS L-VIOLATION ON ?
54924 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
54925C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
54926 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
54927 & THEN
54928 K=INT((KFSM-9)/2)
54929 DO 110 I=1,3
54930 DO 100 J=1,3
54931 IF(I.NE.J) THEN
54932C...~e,~mu,~tau -> nu_I + lepton-_J
54933 LKNT = LKNT+1
54934 IDLAM(LKNT,1)= 12 +2*(I-1)
54935 IDLAM(LKNT,2)= 11 +2*(J-1)
54936 IDLAM(LKNT,3)= 0
54937 XLAM(LKNT)=0D0
54938 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54939 IF (IMSS(51).NE.0) XLAM(LKNT) =
54940 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54941C...KINEMATICS CHECK
54942 IF (XLAM(LKNT).EQ.0D0) THEN
54943 LKNT=LKNT-1
54944 ENDIF
54945 ENDIF
54946 100 CONTINUE
54947 110 CONTINUE
54948C...~e,~mu,~tau -> nu_Ibar + lepton-_K
54949 J=INT((KFSM-9)/2)
54950 DO 130 I=1,3
54951 IF(I.NE.J) THEN
54952 DO 120 K=1,3
54953 LKNT = LKNT+1
54954 IDLAM(LKNT,1)=-12 -2*(I-1)
54955 IDLAM(LKNT,2)= 11 +2*(K-1)
54956 IDLAM(LKNT,3)= 0
54957 XLAM(LKNT)=0D0
54958 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54959 IF (IMSS(51).NE.0) XLAM(LKNT) =
54960 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54961C...KINEMATICS CHECK
54962 IF (XLAM(LKNT).EQ.0D0) THEN
54963 LKNT=LKNT-1
54964 ENDIF
54965 120 CONTINUE
54966 ENDIF
54967 130 CONTINUE
54968C...~e,~mu,~tau -> u_Jbar + d_K
54969 I=INT((KFSM-9)/2)
54970 DO 150 J=1,3
54971 DO 140 K=1,3
54972 LKNT = LKNT+1
54973 IDLAM(LKNT,1)=-2 -2*(J-1)
54974 IDLAM(LKNT,2)= 1 +2*(K-1)
54975 IDLAM(LKNT,3)= 0
54976 XLAM(LKNT)=0
54977 IF (IMSS(52).NE.0) THEN
54978C...Use massive top quark
54979 IF (IDLAM(LKNT,1).EQ.-6) THEN
54980 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
54981 & * (SM-SMT)
54982 XLAM(LKNT) =
54983 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54984C...If no top quark, all decay products massless
54985 ELSE
54986 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54987 XLAM(LKNT) =
54988 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54989 ENDIF
54990C...KINEMATICS CHECK
54991 IF (XLAM(LKNT).EQ.0D0) THEN
54992 LKNT=LKNT-1
54993 ENDIF
54994 ENDIF
54995 140 CONTINUE
54996 150 CONTINUE
54997 ENDIF
54998C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
54999C...No right-handed neutrinos
55000 IF(ICNT.EQ.1) THEN
55001 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
55002 J=INT((KFSM-10)/2)
55003 DO 170 I=1,3
55004 DO 160 K=1,3
55005 IF (I.NE.J) THEN
55006C...~nu_J -> lepton+_I + lepton-_K
55007 LKNT = LKNT+1
55008 IDLAM(LKNT,1)=-11 -2*(I-1)
55009 IDLAM(LKNT,2)= 11 +2*(K-1)
55010 IDLAM(LKNT,3)= 0
55011 XLAM(LKNT)=0D0
55012 RM2=RVLAM(I,J,K)**2 * SM
55013 IF (IMSS(51).NE.0) XLAM(LKNT) =
55014 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55015C...KINEMATICS CHECK
55016 IF (XLAM(LKNT).EQ.0D0) THEN
55017 LKNT=LKNT-1
55018 ENDIF
55019 ENDIF
55020 160 CONTINUE
55021 170 CONTINUE
55022C...~nu_I -> dbar_J + d_K
55023 I=INT((KFSM-10)/2)
55024 DO 190 J=1,3
55025 DO 180 K=1,3
55026 LKNT = LKNT+1
55027 IDLAM(LKNT,1)=-1 -2*(J-1)
55028 IDLAM(LKNT,2)= 1 +2*(K-1)
55029 IDLAM(LKNT,3)= 0
55030 XLAM(LKNT)=0D0
55031 RM2=3*RVLAMP(I,J,K)**2 * SM
55032 IF (IMSS(52).NE.0) XLAM(LKNT) =
55033 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55034C...KINEMATICS CHECK
55035 IF (XLAM(LKNT).EQ.0D0) THEN
55036 LKNT=LKNT-1
55037 ENDIF
55038 180 CONTINUE
55039 190 CONTINUE
55040 ENDIF
55041 ENDIF
55042C * SDOWN -> NU(BAR) + D and LEPTON- + U
55043 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55044 J=INT((KFSM+1)/2)
55045 DO 210 I=1,3
55046 DO 200 K=1,3
55047C...~d_J -> nu_Ibar + d_K
55048 LKNT = LKNT+1
55049 IDLAM(LKNT,1)=-12 -2*(I-1)
55050 IDLAM(LKNT,2)= 1 +2*(K-1)
55051 IDLAM(LKNT,3)= 0
55052 XLAM(LKNT)=0D0
55053 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55054 IF (IMSS(52).NE.0) XLAM(LKNT) =
55055 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55056C...KINEMATICS CHECK
55057 IF (XLAM(LKNT).EQ.0D0) THEN
55058 LKNT=LKNT-1
55059 ENDIF
55060 200 CONTINUE
55061 210 CONTINUE
55062 K=INT((KFSM+1)/2)
55063 DO 240 I=1,3
55064 DO 230 J=1,3
55065C...~d_K -> nu_I + d_J
55066 LKNT = LKNT+1
55067 IDLAM(LKNT,1)= 12 +2*(I-1)
55068 IDLAM(LKNT,2)= 1 +2*(J-1)
55069 IDLAM(LKNT,3)= 0
55070 XLAM(LKNT)=0D0
55071 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55072 IF (IMSS(52).NE.0) XLAM(LKNT) =
55073 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55074C...KINEMATICS CHECK
55075 IF (XLAM(LKNT).EQ.0D0) THEN
55076 LKNT=LKNT-1
55077 ENDIF
55078C...~d_K -> lepton_I- + u_J
55079 220 LKNT = LKNT+1
55080 IDLAM(LKNT,1)= 11 +2*(I-1)
55081 IDLAM(LKNT,2)= 2 +2*(J-1)
55082 IDLAM(LKNT,3)= 0
55083 XLAM(LKNT)=0D0
55084 IF (IMSS(52).NE.0) THEN
55085C...Use massive top quark
55086 IF (IDLAM(LKNT,2).EQ.6) THEN
55087 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
55088 XLAM(LKNT) =
55089 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
55090C...If no top quark, all decay products massless
55091 ELSE
55092 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55093 XLAM(LKNT) =
55094 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55095 ENDIF
55096C...KINEMATICS CHECK
55097 IF (XLAM(LKNT).EQ.0D0) THEN
55098 LKNT=LKNT-1
55099 ENDIF
55100 ENDIF
55101 230 CONTINUE
55102 240 CONTINUE
55103 ENDIF
55104C * SUP -> LEPTON+ + D
55105 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55106 J=NINT(KFSM/2.)
55107 DO 260 I=1,3
55108 DO 250 K=1,3
55109C...~u_J -> lepton_I+ + d_K
55110 LKNT = LKNT+1
55111 IDLAM(LKNT,1)=-11 -2*(I-1)
55112 IDLAM(LKNT,2)= 1 +2*(K-1)
55113 IDLAM(LKNT,3)= 0
55114 XLAM(LKNT)=0D0
55115 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55116 IF (IMSS(52).NE.0) XLAM(LKNT) =
55117 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55118C...KINEMATICS CHECK
55119 IF (XLAM(LKNT).EQ.0D0) THEN
55120 LKNT=LKNT-1
55121 ENDIF
55122 250 CONTINUE
55123 260 CONTINUE
55124 ENDIF
55125 ENDIF
55126C...BARYON NUMBER VIOLATING DECAYS
55127 IF (IMSS(53).GE.1) THEN
55128C * SUP -> DBAR + DBAR
55129 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55130 I = KFSM/2
55131 DO 280 J=1,3
55132 DO 270 K=1,3
55133C...~u_I -> dbar_J + dbar_K
55134 IF (J.LT.K) THEN
55135C...(anti-) symmetry J <-> K.
55136 LKNT = LKNT + 1
55137 IDLAM(LKNT,1) = -1 -2*(J-1)
55138 IDLAM(LKNT,2) = -1 -2*(K-1)
55139 IDLAM(LKNT,3) = 0
55140 XLAM(LKNT) = 0D0
55141 RM2 = 2.*(RVLAMB(I,J,K)**2)
55142 & * SFMIX(KFSM,2*ICNT)**2 * SM
55143 XLAM(LKNT) =
55144 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55145C...KINEMATICS CHECK
55146 IF (XLAM(LKNT).EQ.0D0) THEN
55147 LKNT = LKNT-1
55148 ENDIF
55149 ENDIF
55150 270 CONTINUE
55151 280 CONTINUE
55152 ENDIF
55153C * SDOWN -> UBAR + DBAR
55154 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55155 K=(KFSM+1)/2
55156 DO 300 I=1,3
55157 DO 290 J=1,3
55158C...LAMB coupling antisymmetric in J and K.
55159 IF (J.NE.K) THEN
55160C...~d_K -> ubar_I + dbar_K
55161 LKNT = LKNT + 1
55162 IDLAM(LKNT,1)= -2 -2*(I-1)
55163 IDLAM(LKNT,2)= -1 -2*(J-1)
55164 IDLAM(LKNT,3)= 0
55165 XLAM(LKNT)=0D0
55166C...Use massive top quark
55167 IF (IDLAM(LKNT,1).EQ.-6) THEN
55168 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
55169 & )
55170 XLAM(LKNT) =
55171 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
55172C...If no top quark, all decay products massless
55173 ELSE
55174 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55175 XLAM(LKNT) =
55176 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55177 ENDIF
55178C...KINEMATICS CHECK
55179 IF (XLAM(LKNT).EQ.0D0) THEN
55180 LKNT=LKNT-1
55181 ENDIF
55182 ENDIF
55183 290 CONTINUE
55184 300 CONTINUE
55185 ENDIF
55186 ENDIF
55187 ENDIF
55188
55189 RETURN
55190 END
55191
55192C*********************************************************************
55193
55194C...PYRVNE
55195C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
55196C...P. Z. Skands
55197
55198 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
55199
55200C...Double precision and integer declarations.
55201 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55202 IMPLICIT INTEGER(I-N)
55203C...Parameter statement to help give large particle numbers.
55204 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55205 &KEXCIT=4000000,KDIMEN=5000000)
55206C...Commonblocks.
55207 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55208 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55209 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55210 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55211 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55212 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55213C...Local variables.
55214 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55215 & ,DCMASS,KFR(3)
55216 DOUBLE PRECISION XLAM(0:400)
55217 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
55218 INTEGER IDLAM(400,3), PYCOMP
55219 LOGICAL DCMASS
55220 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
55221
55222C...R-VIOLATING DECAYS
55223 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55224 KFSM=KFIN-KSUSY1
55225 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
55226C...WHICH NEUTRALINO ?
55227 NCHI=1
55228 IF (KFSM.EQ.23) NCHI=2
55229 IF (KFSM.EQ.25) NCHI=3
55230 IF (KFSM.EQ.35) NCHI=4
55231C...SIGN OF MASS (Opposite convention as HERWIG)
55232 ISM = 1
55233 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
55234
55235C...Useful parameters for the calculation of the A and B constants.
55236 WMASS = PMAS(PYCOMP(24),1)
55237 ECHG = 2*SQRT(PARU(103)*PARU(1))
55238 COSB=1/(SQRT(1+RMSS(5)**2))
55239 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
55240 COSW=SQRT(1-PARU(102))
55241 SINW=SQRT(PARU(102))
55242 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
55243C...Run quark masses to neutralino mass squared (for Higgs-type
55244C...couplings)
55245 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
55246 DO 100 I=1,6
55247 RMQ(I)=PYMRUN(I,SQMCHI)
55248 100 CONTINUE
55249C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
55250 DO 110 NCHJ=1,4
55251 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
55252 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
55253 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
55254 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
55255 110 CONTINUE
55256 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
55257 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
55258 C2=ECHG*ZPMIX(NCHI,1)
55259 C3=GW*ZPMIX(NCHI,2)/COSW
55260 EU=2D0/3D0
55261 ED=-1D0/3D0
55262C... AB(x,y,z):
55263C x=1-2 : Select A or B constant (1:A ; 2:B)
55264C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55265C 11-16:e,nu_e,mu,...)
55266C z=1-2 : Mass eigenstate number
55267C...CALCULATE COUPLINGS
55268 DO 120 I = 11,15,2
55269 CMS=PMAS(PYCOMP(I),1)
55270C...Intermediate sleptons
55271 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
55272 & *(C2-C3*SINW**2))
55273 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
55274 & *(C2-C3*SINW**2))
55275 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
55276 & **2))
55277 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
55278 & **2))
55279C...Inermediate sneutrinos
55280 AB(1,I+1,1)=0D0
55281 AB(2,I+1,1)=5D-1*C3
55282 AB(1,I+1,2)=0D0
55283 AB(2,I+1,2)=0D0
55284C...Inermediate sdown
55285 J=I-10
55286 CMS=RMQ(J)
55287 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
55288 & *ED*(C2-C3*SINW**2))
55289 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
55290 & *ED*(C2-C3*SINW**2))
55291 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
55292 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55293 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
55294 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55295C...Inermediate sup
55296 J=J+1
55297 CMS=RMQ(J)
55298 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
55299 & *EU*(C2-C3*SINW**2))
55300 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
55301 & *EU*(C2-C3*SINW**2))
55302 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
55303 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55304 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
55305 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55306 120 CONTINUE
55307
55308 IF (IMSS(51).GE.1) THEN
55309C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
55310C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
55311C...STEP IN I,J,K USING SINGLE COUNTER
55312 DO 130 ISC=0,26
55313C...LAMBDA COUPLING ASYM IN I,J
55314 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55315 LKNT = LKNT+1
55316 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55317 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55318 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55319 XLAM(LKNT) = 0D0
55320C...Set coupling, and decay product masses on/off
55321 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55322 & ,MOD(ISC,3)+1)**2
55323 DCMASS=.FALSE.
55324 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
55325 & DCMASS = .TRUE.
55326C...Resonance KF codes (1=I,2=J,3=K)
55327 KFR(1)=-IDLAM(LKNT,1)
55328 KFR(2)=-IDLAM(LKNT,2)
55329 KFR(3)=-IDLAM(LKNT,3)
55330C...Calculate width.
55331 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55332 & IDLAM(LKNT,3),XLAM(LKNT))
55333 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55334C...Charge conjugate mode.
55335 LKNT=LKNT+1
55336 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55337 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55338 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55339 XLAM(LKNT)=XLAM(LKNT-1)
55340C...KINEMATICS CHECK
55341 IF (XLAM(LKNT).EQ.0D0) THEN
55342 LKNT=LKNT-2
55343 ENDIF
55344 ENDIF
55345 130 CONTINUE
55346 ENDIF
55347
55348 IF (IMSS(52).GE.1) THEN
55349C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
55350C * CHI0 -> NUBAR_I + DBAR_J + D_K
55351 DO 140 ISC=0,26
55352 LKNT = LKNT+1
55353 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55354 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55355 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55356 XLAM(LKNT) = 0D0
55357C...Set coupling, and decay product masses on/off
55358 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55359 & ,MOD(ISC,3)+1)**2
55360 DCMASS=.FALSE.
55361 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
55362 & DCMASS = .TRUE.
55363C...Resonance KF codes (1=I,2=J,3=K)
55364 KFR(1)=-IDLAM(LKNT,1)
55365 KFR(2)=-IDLAM(LKNT,2)
55366 KFR(3)=-IDLAM(LKNT,3)
55367C...Calculate width.
55368 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55369 & ,XLAM(LKNT))
55370 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55371C...Charge conjugate mode.
55372 LKNT=LKNT+1
55373 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55374 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55375 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55376 XLAM(LKNT)=XLAM(LKNT-1)
55377C...KINEMATICS CHECK
55378 IF (XLAM(LKNT).EQ.0D0) THEN
55379 LKNT=LKNT-2
55380 ENDIF
55381
55382C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
55383 LKNT = LKNT+1
55384 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55385 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55386 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55387 XLAM(LKNT) = 0D0
55388C...Set coupling, and decay product masses on/off
55389 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55390 & ,MOD(ISC,3)+1)**2
55391 DCMASS=.FALSE.
55392 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
55393 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55394C...Resonance KF codes (1=I,2=J,3=K)
55395 KFR(1)=-IDLAM(LKNT,1)
55396 KFR(2)=-IDLAM(LKNT,2)
55397 KFR(3)=-IDLAM(LKNT,3)
55398C...Calculate width.
55399 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55400 & ,XLAM(LKNT))
55401 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55402C...Charge conjugate mode.
55403 LKNT=LKNT+1
55404 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55405 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55406 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55407 XLAM(LKNT)=XLAM(LKNT-1)
55408C...KINEMATICS CHECK
55409 IF (XLAM(LKNT).EQ.0D0) THEN
55410 LKNT=LKNT-2
55411 ENDIF
55412 140 CONTINUE
55413 ENDIF
55414
55415 IF (IMSS(53).GE.1) THEN
55416C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
55417C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
55418 DO 150 ISC=0,26
55419C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
55420 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
55421 LKNT = LKNT+1
55422 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
55423 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55424 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55425 XLAM(LKNT) = 0D0
55426C...Set coupling, and decay product masses on/off
55427 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
55428 & +1,MOD(ISC,3)+1)**2
55429 DCMASS=.FALSE.
55430 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
55431 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
55432C...Resonance KF codes (1=I,2=J,3=K)
55433 KFR(1) = IDLAM(LKNT,1)
55434 KFR(2) = IDLAM(LKNT,2)
55435 KFR(3) = IDLAM(LKNT,3)
55436C...Calculate width.
55437 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55438 & IDLAM(LKNT,3),XLAM(LKNT))
55439 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55440C...Charge conjugate mode.
55441 LKNT=LKNT+1
55442 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55443 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55444 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55445 XLAM(LKNT)=XLAM(LKNT-1)
55446C...KINEMATICS CHECK
55447 IF (XLAM(LKNT).EQ.0D0) THEN
55448 LKNT=LKNT-2
55449 ENDIF
55450 ENDIF
55451 150 CONTINUE
55452 ENDIF
55453 ENDIF
55454 ENDIF
55455
55456 RETURN
55457 END
55458
55459C*********************************************************************
55460
55461C...PYRVCH
55462C...Calculates R-violating chargino decay widths.
55463C...P. Z. Skands
55464
55465 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
55466
55467C...Double precision and integer declarations.
55468 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55469 IMPLICIT INTEGER(I-N)
55470C...Parameter statement to help give large particle numbers.
55471 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55472 &KEXCIT=4000000,KDIMEN=5000000)
55473C...Commonblocks.
55474 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55475 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55476 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55477 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55478 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55479 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55480C...Local variables.
55481 DOUBLE PRECISION XLAM(0:400)
55482 INTEGER IDLAM(400,3), PYCOMP
55483C...Information from main routine to PYRVGW
55484 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55485 & ,DCMASS,KFR(3)
55486C...Auxiliary variables needed for BV (RV Gauge STOre)
55487 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55488 & ,RVLJKI,RVLJIK
55489C...Running quark masses
55490 DOUBLE PRECISION RMQ(6)
55491C...Decay product masses on/off
55492 LOGICAL DCMASS
55493 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55494 & /RVGSTO/
55495
55496
55497C...IF R-VIOLATION ON.
55498 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55499 KFSM=KFIN-KSUSY1
55500 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
55501C...WHICH CHARGINO ?
55502 NCHI = 1
55503 IF (KFSM.EQ.37) NCHI = 2
55504
55505C...Useful parameters for calculating the A and B constants.
55506C...SIGN OF MASS (Opposite convention as HERWIG)
55507 ISM = 1
55508 IF (SMW(NCHI).LT.0D0) ISM = -1
55509 WMASS = PMAS(PYCOMP(24),1)
55510 COSB = 1/(SQRT(1+RMSS(5)**2))
55511 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
55512 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
55513 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
55514 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
55515 C2 = UMIX(NCHI,1)
55516 C3 = VMIX(NCHI,1)
55517C...Running masses at Q^2=MCHI^2.
55518 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
55519 DO 100 I=1,6
55520 RMQ(I)=PYMRUN(I,SQMCHI)
55521 100 CONTINUE
55522
55523C... AB(x,y,z) coefficients:
55524C x=1-2 : A or B coefficient (1:A ; 2:B)
55525C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55526C 11-16:e,nu_e,mu,...)
55527C z=1-2 : Mass eigenstate number
55528 DO 110 I = 11,15,2
55529C...Intermediate sleptons
55530 AB(1,I,1) = 0D0
55531 AB(1,I,2) = 0D0
55532 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
55533 & SFMIX(I,1)*C2
55534 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
55535 & SFMIX(I,3)*C2
55536C...Intermediate sneutrinos
55537 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
55538 AB(1,I+1,2) = 0D0
55539 AB(2,I+1,1) = ISM*C3
55540 AB(2,I+1,2) = 0D0
55541C...Intermediate sdown
55542 J=I-10
55543 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
55544 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
55545 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
55546 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
55547C...Intermediate sup
55548 J=J+1
55549 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
55550 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
55551 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
55552 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
55553 110 CONTINUE
55554
55555C...LLE TYPE R-VIOLATION
55556 IF (IMSS(51).GE.1) THEN
55557C...LOOP OVER DECAY MODES
55558 DO 140 ISC=0,26
55559
55560C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
55561 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55562 LKNT = LKNT+1
55563 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
55564 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
55565 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
55566 XLAM(LKNT) = 0D0
55567C...Set coupling, and decay product masses on/off
55568 RVLAMC = GW2 * 5D-1 *
55569 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
55570 & **2
55571 DCMASS=.FALSE.
55572 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
55573C...Resonance KF codes (1=I,2=J,3=K).
55574 KFR(1) = 0
55575 KFR(2) = 0
55576 KFR(3) = -IDLAM(LKNT,3)+1
55577C...Calculate width.
55578 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55579 & IDLAM(LKNT,3),XLAM(LKNT))
55580 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55581C...KINEMATICS CHECK
55582 IF (XLAM(LKNT).EQ.0D0) THEN
55583 LKNT=LKNT-1
55584 ENDIF
55585
55586C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
55587 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
55588 LKNT = LKNT+1
55589 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55590 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
55591 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
55592 XLAM(LKNT) = 0D0
55593C...Set coupling, and decay product masses on/off
55594 RVLAMC = GW2 * 5D-1 *
55595 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55596C...I,J SYMMETRY => FACTOR 2
55597 RVLAMC=2*RVLAMC
55598 DCMASS=.FALSE.
55599 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
55600C...Resonance KF codes (1=I,2=J,3=K)
55601 KFR(1)=IDLAM(LKNT,1)-1
55602 KFR(2)=IDLAM(LKNT,2)-1
55603 KFR(3)=0
55604C...Calculate width.
55605 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55606 & IDLAM(LKNT,3),XLAM(LKNT))
55607 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55608C...KINEMATICS CHECK
55609 IF (XLAM(LKNT).EQ.0D0) THEN
55610 LKNT=LKNT-1
55611 ENDIF
55612 130 ENDIF
55613
55614C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
55615 LKNT = LKNT+1
55616 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55617 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55618 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55619 XLAM(LKNT) = 0D0
55620C...Set coupling, and decay product masses on/off
55621 RVLAMC = GW2 * 5D-1 *
55622 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55623C...I,J SYMMETRY => FACTOR 2
55624 RVLAMC=2*RVLAMC
55625 DCMASS=.FALSE.
55626 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
55627 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
55628C...Resonance KF codes (1=I,2=J,3=K)
55629 KFR(1) =-IDLAM(LKNT,1)+1
55630 KFR(2) =-IDLAM(LKNT,2)+1
55631 KFR(3) = 0
55632C...Calculate width.
55633 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55634 & IDLAM(LKNT,3),XLAM(LKNT))
55635 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55636C...KINEMATICS CHECK
55637 IF (XLAM(LKNT).EQ.0D0) THEN
55638 LKNT=LKNT-1
55639 ENDIF
55640 ENDIF
55641 140 CONTINUE
55642 ENDIF
55643
55644C...LQD TYPE R-VIOLATION
55645 IF (IMSS(52).GE.1) THEN
55646C...LOOP OVER DECAY MODES
55647 DO 180 ISC=0,26
55648
55649C...CHI+ -> NUBAR_I + DBAR_J + U_K
55650 LKNT = LKNT+1
55651 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55652 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55653 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55654 XLAM(LKNT) = 0D0
55655C...Set coupling, and decay product masses on/off
55656 RVLAMC = 3. * GW2 * 5D-1 *
55657 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55658 DCMASS=.FALSE.
55659 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
55660 & DCMASS = .TRUE.
55661C...Resonance KF codes (1=I,2=J,3=K)
55662 KFR(1)=0
55663 KFR(2)=0
55664 KFR(3)=-IDLAM(LKNT,3)+1
55665C...Calculate width.
55666 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55667 & ,XLAM(LKNT))
55668 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55669C...KINEMATICS CHECK
55670 IF (XLAM(LKNT).EQ.0D0) THEN
55671 LKNT=LKNT-1
55672 ENDIF
55673
55674C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
55675 150 LKNT = LKNT+1
55676 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55677 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55678 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55679 XLAM(LKNT) = 0D0
55680C...Set coupling, and decay product masses on/off
55681 RVLAMC = 3. * GW2 * 5D-1 *
55682 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55683 DCMASS=.FALSE.
55684 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
55685 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
55686C...Resonance KF codes (1=I,2=J,3=K)
55687 KFR(1)=0
55688 KFR(2)=0
55689 KFR(3)=-IDLAM(LKNT,3)+1
55690C...Calculate width.
55691 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55692 & ,XLAM(LKNT))
55693 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55694C...KINEMATICS CHECK
55695 IF (XLAM(LKNT).EQ.0D0) THEN
55696 LKNT=LKNT-1
55697 ENDIF
55698
55699C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
55700 160 LKNT = LKNT+1
55701 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55702 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55703 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55704 XLAM(LKNT) = 0D0
55705C...Set coupling, and decay product masses on/off
55706 RVLAMC = 3. * GW2 * 5D-1 *
55707 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55708 DCMASS = .FALSE.
55709 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
55710 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
55711C...Resonance KF codes (1=I,2=J,3=K)
55712 KFR(1)=-IDLAM(LKNT,1)+1
55713 KFR(2)=-IDLAM(LKNT,2)+1
55714 KFR(3)=0
55715C...Calculate width.
55716 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55717 & ,XLAM(LKNT))
55718 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55719C...KINEMATICS CHECK
55720 IF (XLAM(LKNT).EQ.0D0) THEN
55721 LKNT=LKNT-1
55722 ENDIF
55723
55724C * CHI+ -> NU_I + U_J + DBAR_K.
55725 170 LKNT = LKNT+1
55726 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55727 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55728 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55729 XLAM(LKNT) = 0D0
55730C...Set coupling, and decay product masses on/off
55731 DCMASS = .FALSE.
55732 RVLAMC = 3. * GW2 * 5D-1 *
55733 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55734 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
55735 & DCMASS = .TRUE.
55736C...Resonance KF codes (1=I,2=J,3=K)
55737 KFR(1)=IDLAM(LKNT,1)-1
55738 KFR(2)=IDLAM(LKNT,2)-1
55739 KFR(3)=0
55740C...Calculate width.
55741 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55742 & ,XLAM(LKNT))
55743 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55744C...KINEMATICS CHECK
55745 IF (XLAM(LKNT).EQ.0D0) THEN
55746 LKNT=LKNT-1
55747 ENDIF
55748
55749 180 CONTINUE
55750 ENDIF
55751
55752C...UDD TYPE R-VIOLATION
55753C...These decays need special treatment since more than one BV coupling
55754C...contributes (with interference). Consider e.g. (symbolically)
55755C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
55756C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
55757C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
55758C...The problem is that a single call to PYRVGW would evaluate all
55759C...these terms and sum them, but without the different couplings. The
55760C...way out is to call PYRVGW three times, once for the first line, once
55761C...for the second line, and then once for all the lines (it is
55762C...impossible to get just the last line out) without multiplying by
55763C...couplings. The last line is then obtained as the result of the third
55764C...call minus the results of the two first calls. Each term is then
55765C...multiplied by its respective coupling before the whole thing is
55766C...summed up in XLAM.
55767C...Note that with three interfering resonances, this procedure becomes
55768C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
55769
55770 IF (IMSS(53).GE.1) THEN
55771C...LOOP OVER DECAY MODES
55772 DO 190 ISC=1,25
55773
55774C...CHI+ -> U_I + U_J + D_K
55775C...Decay mode I<->J symmetric.
55776 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
55777 LKNT = LKNT+1
55778 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
55779 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55780 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55781 XLAM(LKNT) = 0D0
55782C...Set coupling, and decay product masses on/off
55783 RVLAMC= 6. * GW2 * 5D-1
55784 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
55785 & +1)
55786 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55787 & +1)
55788 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
55789 & * RVLAMC
55790 DCMASS=.FALSE.
55791 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
55792 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
55793C...Resonance KF codes (1=I,2=J,3=K)
55794 KFR(1) = -IDLAM(LKNT,1)+1
55795 KFR(2) = 0
55796 KFR(3) = 0
55797C...Calculate width.
55798 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55799 & IDLAM(LKNT,3),XRESI)
55800C...Resonance KF codes (1=I,2=J,3=K)
55801 KFR(1) = 0
55802 KFR(2) = -IDLAM(LKNT,2)+1
55803 KFR(3) = 0
55804C...Calculate width.
55805 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55806 & IDLAM(LKNT,3),XRESJ)
55807C...Resonance KF codes (1=I,2=J,3=K)
55808 KFR(1) = -IDLAM(LKNT,1)+1
55809 KFR(2) = -IDLAM(LKNT,2)+1
55810 KFR(3) = 0
55811C...Calculate width.
55812 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55813 & IDLAM(LKNT,3),XRESIJ)
55814 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
55815 XRESIJ = XRESIJ-XRESI-XRESJ
55816 ELSE
55817 XRESIJ = 0D0
55818 ENDIF
55819C...CALCULATE TOTAL WIDTH
55820 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
55821 & + RVLJIK*RVLIJK * XRESIJ
55822 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55823C...KINEMATICS CHECK
55824 IF (XLAM(LKNT).EQ.0D0) THEN
55825 LKNT=LKNT-1
55826 ENDIF
55827 ENDIF
55828C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
55829C...Symmetry I<->J<->K.
55830 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
55831 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
55832 LKNT = LKNT+1
55833 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
55834 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55835 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55836 XLAM(LKNT) = 0D0
55837C...Set coupling, and decay product masses on/off
55838 RVLAMC = 6. * GW2 * 5D-1
55839 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55840 & +1)
55841 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
55842 & +1)
55843 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
55844 & +1)
55845 DCMASS = .FALSE.
55846 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
55847 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
55848C...Collect symmetry factors
55849 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
55850 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
55851 & RVLAMC = 5D-1 * RVLAMC
55852C...Resonance KF codes (1=I,2=J,3=K)
55853 KFR(1) = IDLAM(LKNT,1)-1
55854 KFR(2) = 0
55855 KFR(3) = 0
55856C...Calculate width.
55857 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55858 & IDLAM(LKNT,3),XRESI)
55859C...Resonance KF codes (1=I,2=J,3=K)
55860 KFR(1) = 0
55861 KFR(2) = IDLAM(LKNT,2)-1
55862 KFR(3) = 0
55863C...Calculate width.
55864 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55865 & IDLAM(LKNT,3),XRESJ)
55866C...Resonance KF codes (1=I,2=J,3=K)
55867 KFR(1) = 0
55868 KFR(2) = 0
55869 KFR(3) = IDLAM(LKNT,3)-1
55870C...Calculate width.
55871 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55872 & IDLAM(LKNT,3),XRESK)
55873C...Resonance KF codes (1=I,2=J,3=K)
55874 KFR(1) = IDLAM(LKNT,1)-1
55875 KFR(2) = IDLAM(LKNT,2)-1
55876 KFR(3) = 0
55877C...Calculate width.
55878 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55879 & IDLAM(LKNT,3),XRESIJ)
55880 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
55881 XRESIJ = XRESI+XRESJ-XRESIJ
55882 ELSE
55883 XRESIJ = 0D0
55884 ENDIF
55885C...Resonance KF codes (1=I,2=J,3=K)
55886 KFR(1) = 0
55887 KFR(2) = IDLAM(LKNT,2)-1
55888 KFR(3) = IDLAM(LKNT,3)-1
55889C...Calculate width.
55890 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55891 & IDLAM(LKNT,3),XRESJK)
55892 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
55893 XRESJK = XRESJ+XRESK-XRESJK
55894 ELSE
55895 XRESJK = 0D0
55896 ENDIF
55897C...Resonance KF codes (1=I,2=J,3=K)
55898 KFR(1) = IDLAM(LKNT,1)-1
55899 KFR(2) = 0
55900 KFR(3) = IDLAM(LKNT,3)-1
55901C...Calculate width.
55902 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55903 & IDLAM(LKNT,3),XRESIK)
55904 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
55905 XRESIK = XRESI+XRESK-XRESIK
55906 ELSE
55907 XRESIK = 0D0
55908 ENDIF
55909C...CALCULATE TOTAL WIDTH
55910 XLAM(LKNT) =
55911 & RVLIJK**2 * XRESI
55912 & + RVLJKI**2 * XRESJ
55913 & + RVLKIJ**2 * XRESK
55914 & + RVLIJK*RVLJKI * XRESIJ
55915 & + RVLIJK*RVLKIJ * XRESIK
55916 & + RVLJKI*RVLKIJ * XRESJK
55917 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
55918C...KINEMATICS CHECK
55919 IF (XLAM(LKNT).EQ.0D0) THEN
55920 LKNT=LKNT-1
55921 ENDIF
55922 ENDIF
55923 190 CONTINUE
55924 ENDIF
55925 ENDIF
55926 ENDIF
55927
55928 RETURN
55929 END
55930
55931C*********************************************************************
55932
55933C...PYRVGL
55934C...Calculates R-violating gluino decay widths.
55935C...See BV part of PYRVCH for comments about the way the BV decay width
55936C...is calculated. Same comments apply here.
55937C...P. Z. Skands
55938
55939 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
55940
55941C...Double precision and integer declarations.
55942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55943 IMPLICIT INTEGER(I-N)
55944C...Parameter statement to help give large particle numbers.
55945 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55946 &KEXCIT=4000000,KDIMEN=5000000)
55947C...Commonblocks.
55948 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55949 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55950 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55951 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55952 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55953 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55954C...Local variables.
55955 DOUBLE PRECISION XLAM(0:400)
55956 INTEGER IDLAM(400,3), PYCOMP
55957C...Information from main routine to PYRVGW
55958 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55959 & ,DCMASS,KFR(3)
55960C...Auxiliary variables needed for BV (RV Gauge STOre)
55961 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55962 & ,RVLJKI,RVLJIK
55963C...Running quark masses
55964 DOUBLE PRECISION RMQ(6)
55965C...Decay product masses on/off
55966 LOGICAL DCMASS
55967 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55968 & /RVGSTO/
55969
55970C...IF LQD OR UDD TYPE R-VIOLATION ON.
55971 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
55972 KFSM=KFIN-KSUSY1
55973
55974C... AB(x,y,z):
55975C x=1-2 : Select A or B coupling (1:A ; 2:B)
55976C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55977C 11-16:e,nu_e,mu,... not used here)
55978C z=1-2 : Mass eigenstate number
55979 DO 100 I = 1,6
55980C...A Couplings
55981 AB(1,I,1) = SFMIX(I,2)
55982 AB(1,I,2) = SFMIX(I,4)
55983C...B Couplings
55984 AB(2,I,1) = -SFMIX(I,1)
55985 AB(2,I,2) = -SFMIX(I,3)
55986 100 CONTINUE
55987 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
55988C...LQD DECAYS.
55989 IF (IMSS(52).GE.1) THEN
55990C...STEP IN I,J,K USING SINGLE COUNTER
55991 DO 120 ISC=0,26
55992C * GLUINO -> NUBAR_I + DBAR_J + D_K.
55993 LKNT = LKNT+1
55994 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55995 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55996 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55997 XLAM(LKNT)=0D0
55998C...Set coupling, and decay product masses on/off
55999 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
56000 & * 5D-1 * GSTR2
56001 DCMASS = .FALSE.
56002 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
56003C...Resonance KF codes (1=I,2=J,3=K)
56004 KFR(1) = 0
56005 KFR(2) = -IDLAM(LKNT,2)
56006 KFR(3) = -IDLAM(LKNT,3)
56007C...Calculate width.
56008 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56009 & ,XLAM(LKNT))
56010C...Normalize
56011 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56012C...Charge conjugate mode.
56013 110 LKNT = LKNT+1
56014 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56015 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56016 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56017 XLAM(LKNT) = XLAM(LKNT-1)
56018C...KINEMATICS CHECK
56019 IF (XLAM(LKNT).EQ.0D0) THEN
56020 LKNT=LKNT-2
56021 ENDIF
56022
56023C * GLUINO -> LEPTON+_I + UBAR_J + D_K
56024 LKNT = LKNT+1
56025 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
56026 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
56027 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
56028 XLAM(LKNT)=0D0
56029C...Set coupling, and decay product masses on/off
56030 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56031 & **2* 5D-1 * GSTR2
56032 DCMASS = .FALSE.
56033 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
56034 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
56035C...Resonance KF codes (1=I,2=J,3=K)
56036 KFR(1) = 0
56037 KFR(2) = -IDLAM(LKNT,2)
56038 KFR(3) = -IDLAM(LKNT,3)
56039C...Calculate width.
56040 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56041 & ,XLAM(LKNT))
56042 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56043C...Charge conjugate mode.
56044 LKNT=LKNT+1
56045 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
56046 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
56047 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
56048 XLAM(LKNT) = XLAM(LKNT-1)
56049C...KINEMATICS CHECK
56050 IF (XLAM(LKNT).EQ.0D0) THEN
56051 LKNT=LKNT-2
56052 ENDIF
56053
56054 120 CONTINUE
56055 ENDIF
56056
56057C...UDD DECAYS.
56058 IF (IMSS(53).GE.1) THEN
56059C...STEP IN I,J,K USING SINGLE COUNTER
56060 DO 130 ISC=0,26
56061C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
56062 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
56063 LKNT = LKNT+1
56064 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
56065 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
56066 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
56067 XLAM(LKNT)=0D0
56068C...Set coupling, and decay product masses on/off. A factor of 2 for
56069C...(N_C-1) has been used to cancel a factor 0.5.
56070 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56071 & **2 * GSTR2
56072 DCMASS = .FALSE.
56073 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
56074 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
56075C...Resonance KF codes (1=I,2=J,3=K)
56076 KFR(1) = IDLAM(LKNT,1)
56077 KFR(2) = 0
56078 KFR(3) = 0
56079C...Calculate width.
56080 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56081 & ,XRESI)
56082C...Resonance KF codes (1=I,2=J,3=K)
56083 KFR(1) = 0
56084 KFR(2) = IDLAM(LKNT,2)
56085 KFR(3) = 0
56086C...Calculate width.
56087 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56088 & ,XRESJ)
56089C...Resonance KF codes (1=I,2=J,3=K)
56090 KFR(1) = 0
56091 KFR(2) = 0
56092 KFR(3) = IDLAM(LKNT,3)
56093C...Calculate width.
56094 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56095 & ,XRESK)
56096C...Resonance KF codes (1=I,2=J,3=K)
56097 KFR(1) = IDLAM(LKNT,1)
56098 KFR(2) = IDLAM(LKNT,2)
56099 KFR(3) = 0
56100C...Calculate width.
56101 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56102 & ,XRESIJ)
56103C...Calculate interference function. (Factor -1/2 to make up for factor
56104C...-2 in PYRVGW.
56105 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
56106 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
56107 ELSE
56108 XRESIJ = 0D0
56109 ENDIF
56110C...Resonance KF codes (1=I,2=J,3=K)
56111 KFR(1) = 0
56112 KFR(2) = IDLAM(LKNT,2)
56113 KFR(3) = IDLAM(LKNT,3)
56114C...Calculate width.
56115 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56116 & ,XRESJK)
56117 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
56118 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
56119 ELSE
56120 XRESJK = 0D0
56121 ENDIF
56122C...Resonance KF codes (1=I,2=J,3=K)
56123 KFR(1) = IDLAM(LKNT,1)
56124 KFR(2) = 0
56125 KFR(3) = IDLAM(LKNT,3)
56126C...Calculate width.
56127 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56128 & ,XRESIK)
56129 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
56130 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
56131 ELSE
56132 XRESIK = 0D0
56133 ENDIF
56134C...Calculate total width (factor 1/2 from 1/(N_C-1))
56135 XLAM(LKNT) = XRESI + XRESJ + XRESK
56136 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
56137C...Normalize
56138 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56139C...Charge conjugate mode.
56140 LKNT = LKNT+1
56141 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56142 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56143 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56144 XLAM(LKNT) = XLAM(LKNT-1)
56145C...KINEMATICS CHECK
56146 IF (XLAM(LKNT).EQ.0D0) THEN
56147 LKNT=LKNT-2
56148 ENDIF
56149 ENDIF
56150 130 CONTINUE
56151 ENDIF
56152 ENDIF
56153 RETURN
56154 END
56155
56156C*********************************************************************
56157
56158C...PYRVSB
56159C...Auxiliary function to PYRVSF for calculating R-Violating
56160C...sfermion widths. Though the decay products are most often treated
56161C...as massless in the calculation, the kinematical boundary of phase
56162C...space is tested using the true masses.
56163C...MODE = 1: All decay products massive
56164C...MODE = 2: Decay product 1 massless
56165C...MODE = 3: Decay product 2 massless
56166C...MODE = 4: All decay products massless
56167
56168 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
56169
56170 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56171 IMPLICIT INTEGER (I-N)
56172 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56173 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56174 SAVE /PYDAT1/,/PYDAT2/
56175 DOUBLE PRECISION SM(3)
56176 INTEGER PYCOMP, KC(3)
56177 KC(1)=PYCOMP(KFIN)
56178 KC(2)=PYCOMP(ID1)
56179 KC(3)=PYCOMP(ID2)
56180 SM(1)=PMAS(KC(1),1)**2
56181 SM(2)=PMAS(KC(2),1)**2
56182 SM(3)=PMAS(KC(3),1)**2
56183C...Kinematics check
56184 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
56185 PYRVSB=0D0
56186 RETURN
56187 ENDIF
56188C...CM momenta squared
56189 IF (MODE.EQ.1) THEN
56190 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
56191 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
56192 ELSE IF (MODE.EQ.2) THEN
56193 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
56194 ELSE IF (MODE.EQ.3) THEN
56195 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
56196 ELSE
56197 P2CM=SM(1)/4.
56198 ENDIF
56199C...Calculate Width
56200 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
56201 RETURN
56202 END
56203
56204C*********************************************************************
56205
56206C...PYRVGW
56207C...Generalized Matrix Element for R-Violating 3-body widths.
56208C...P. Z. Skands
56209 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
56210
56211 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56212 IMPLICIT INTEGER (I-N)
56213 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56214 &KEXCIT=4000000,KDIMEN=5000000)
56215 PARAMETER (EPS=1D-4)
56216 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56217 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56218 & ,DCMASS,KFR(3)
56219 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56220 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56221 DOUBLE PRECISION XLIM(3,3)
56222 INTEGER KC(0:3), PYCOMP
56223 LOGICAL DCMASS, DCHECK(6)
56224 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
56225
56226 XLAM = 0D0
56227
56228 KC(0) = PYCOMP(KFIN)
56229 KC(1) = PYCOMP(ID1)
56230 KC(2) = PYCOMP(ID2)
56231 KC(3) = PYCOMP(ID3)
56232 RMS(0) = PMAS(KC(0),1)
56233 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
56234 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
56235 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
56236C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
56237 XLIM(1,1)=(RMS(1)+RMS(2))**2
56238 XLIM(1,2)=(RMS(0)-RMS(3))**2
56239 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
56240 XLIM(2,1)=(RMS(2)+RMS(3))**2
56241 XLIM(2,2)=(RMS(0)-RMS(1))**2
56242 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
56243 XLIM(3,1)=(RMS(1)+RMS(3))**2
56244 XLIM(3,2)=(RMS(0)-RMS(2))**2
56245 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
56246C...Check Phase Space
56247 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
56248 RETURN
56249 ENDIF
56250
56251C...INITIALIZE RESONANCE INFORMATION
56252 DO 110 JRES = 1,3
56253 DO 100 IMASS = 1,2
56254 IRES = 2*(JRES-1)+IMASS
56255 INTRES(IRES,1) = 0
56256 DCHECK(IRES) =.FALSE.
56257C...NO RIGHT-HANDED NEUTRINOS
56258 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
56259 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
56260 & .KFR(JRES).EQ.0) GOTO 100
56261 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
56262 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
56263 INTRES(IRES,1) = IABS(KFR(JRES))
56264 INTRES(IRES,2) = IMASS
56265 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
56266 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
56267 100 CONTINUE
56268 110 CONTINUE
56269
56270C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
56271
56272C...RESONANCE CONTRIBUTIONS
56273C...(Only sum contributions where the resonance is off shell).
56274C...Store whether diagram on/off in DCHECK.
56275C...LOOP OVER MASS STATES
56276 DO 120 J=1,2
56277 IDR=J
56278 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56279 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
56280 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56281 DCHECK(IDR) =.TRUE.
56282 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
56283 ENDIF
56284
56285 IDR=J+2
56286 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56287 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56288 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56289 DCHECK(IDR) =.TRUE.
56290 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
56291 ENDIF
56292
56293 IDR=J+4
56294 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56295 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56296 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56297 DCHECK(IDR) =.TRUE.
56298 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
56299 ENDIF
56300 120 CONTINUE
56301C... L-R INTERFERENCES
56302C... (Only add contributions where both contributing diagrams
56303C... are non-resonant).
56304 IDR=1
56305 IF (DCHECK(1).AND.DCHECK(2)) THEN
56306C...Bug corrected 11/12 2001. Skands.
56307 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
56308 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
56309 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
56310 ENDIF
56311
56312 IDR=3
56313 IF (DCHECK(3).AND.DCHECK(4)) THEN
56314 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
56315 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
56316 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
56317 ENDIF
56318
56319 IDR=5
56320 IF (DCHECK(5).AND.DCHECK(6)) THEN
56321 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
56322 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
56323 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
56324 ENDIF
56325C... TRUE INTERFERENCES
56326C... (Only add contributions where both contributing diagrams
56327C... are non-resonant).
56328 PREF=-2D0
56329 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
56330 DO 140 IKR1 = 1,2
56331 DO 130 IKR2 = 1,2
56332 IDR = IKR1+2
56333 IDR2 = IKR2
56334 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56335 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
56336 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56337 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56338 ENDIF
56339
56340 IDR = IKR1+4
56341 IDR2 = IKR2
56342 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56343 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
56344 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56345 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56346 ENDIF
56347
56348 IDR = IKR1+4
56349 IDR2 = IKR2+2
56350 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56351 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
56352 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56353 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56354 ENDIF
56355 130 CONTINUE
56356 140 CONTINUE
56357
56358 RETURN
56359 END
56360
56361C*********************************************************************
56362
56363C...PYRVI1
56364C...Function to integrate resonance contributions
56365
56366 FUNCTION PYRVI1(ID1,ID2,ID3)
56367
56368 IMPLICIT NONE
56369 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
56370 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56371 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56372 LOGICAL MFLAG,DCMASS
56373 EXTERNAL PYRVG1,PYGAUS
56374 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56375 & ,DCMASS,KFR(3)
56376 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56377 SAVE/PYRVNV/,/PYRVPM/
56378C...Initialize mass and width information
56379 PYRVI1 = 0D0
56380 RM(0) = RMS(0)
56381 RM(1) = RMS(ID1)
56382 RM(2) = RMS(ID2)
56383 RM(3) = RMS(ID3)
56384 RESM(1)= RES(IDR,1)
56385 RESW(1)= RES(IDR,2)
56386C...A->B and B->A for antisparticles
56387 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56388 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56389C...Integration boundaries and mass flag
56390 LO = (RM(1)+RM(2))**2
56391 HI = (RM(0)-RM(3))**2
56392 MFLAG = DCMASS
56393 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
56394 RETURN
56395 END
56396
56397C*********************************************************************
56398
56399C...PYRVI2
56400C...Function to integrate L-R interference contributions
56401
56402 FUNCTION PYRVI2(ID1,ID2,ID3)
56403
56404 IMPLICIT NONE
56405 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
56406 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56407 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56408 LOGICAL MFLAG,DCMASS
56409 EXTERNAL PYRVG2,PYGAUS
56410 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56411 & ,DCMASS,KFR(3)
56412 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56413 SAVE/PYRVNV/,/PYRVPM/
56414C...Initialize mass and width information
56415 PYRVI2 = 0D0
56416 RM(0) = RMS(0)
56417 RM(1) = RMS(ID1)
56418 RM(2) = RMS(ID2)
56419 RM(3) = RMS(ID3)
56420 RESM(1)= RES(IDR,1)
56421 RESW(1)= RES(IDR,2)
56422 RESM(2)= RES(IDR+1,1)
56423 RESW(2)= RES(IDR+1,2)
56424C...A->B and B->A for antisparticles
56425 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56426 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56427 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56428 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56429C...Boundaries and mass flag
56430 LO = (RM(1)+RM(2))**2
56431 HI = (RM(0)-RM(3))**2
56432 MFLAG = DCMASS
56433 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
56434 RETURN
56435 END
56436
56437C*********************************************************************
56438
56439C...PYRVI3
56440C...Function to integrate true interference contributions
56441
56442 FUNCTION PYRVI3(ID1,ID2,ID3)
56443
56444 IMPLICIT NONE
56445 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
56446 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56447 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56448 LOGICAL MFLAG,DCMASS
56449 EXTERNAL PYRVG3,PYGAUS
56450 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56451 & ,DCMASS,KFR(3)
56452 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56453 SAVE/PYRVNV/,/PYRVPM/
56454C...Initialize mass and width information
56455 PYRVI3 = 0D0
56456 RM(0) = RMS(0)
56457 RM(1) = RMS(ID1)
56458 RM(2) = RMS(ID2)
56459 RM(3) = RMS(ID3)
56460 RESM(1)= RES(IDR,1)
56461 RESW(1)= RES(IDR,2)
56462 RESM(2)= RES(IDR2,1)
56463 RESW(2)= RES(IDR2,2)
56464C...A -> B and B -> A for antisparticles
56465 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56466 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56467 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56468 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56469C...Boundaries and mass flag
56470 LO = (RM(1)+RM(2))**2
56471 HI = (RM(0)-RM(3))**2
56472 MFLAG = DCMASS
56473 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
56474 RETURN
56475 END
56476
56477C*********************************************************************
56478
56479C...PYRVG1
56480C...Integrand for resonance contributions
56481
56482 FUNCTION PYRVG1(X)
56483
56484 IMPLICIT NONE
56485 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56486 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
56487 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
56488 LOGICAL MFLAG
56489 SAVE/PYRVPM/
56490 RVR = PYRVR(X,RESM(1),RESW(1))
56491 C1 = 2D0*SQRT(MAX(0D0,X))
56492 IF (.NOT.MFLAG) THEN
56493 E2 = X/C1
56494 E3 = (RM(0)**2-X)/C1
56495 DELTAY = 4D0*E2*E3
56496 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
56497 ELSE
56498 E2 = (X-RM(1)**2+RM(2)**2)/C1
56499 E3 = (RM(0)**2-X-RM(3)**2)/C1
56500 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56501 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56502 DELTAY = 4D0*SR1*SR2
56503 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
56504 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
56505 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
56506 ENDIF
56507 RETURN
56508 END
56509
56510C*********************************************************************
56511
56512C...PYRVG2
56513C...Integrand for L-R interference contributions
56514
56515 FUNCTION PYRVG2(X)
56516
56517 IMPLICIT NONE
56518 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56519 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
56520 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
56521 LOGICAL MFLAG
56522 SAVE/PYRVPM/
56523 C1 = 2D0*SQRT(MAX(0D0,X))
56524 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
56525 IF (.NOT.MFLAG) THEN
56526 E2 = X/C1
56527 E3 = (RM(0)**2-X)/C1
56528 DELTAY = 4D0*E2*E3
56529 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
56530 ELSE
56531 E2 = (X-RM(1)**2+RM(2)**2)/C1
56532 E3 = (RM(0)**2-X-RM(3)**2)/C1
56533 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56534 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56535 DELTAY = 4D0*SR1*SR2
56536 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
56537 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
56538 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
56539 ENDIF
56540 RETURN
56541 END
56542
56543C*********************************************************************
56544
56545C...PYRVG3
56546C...Function to do Y integration over true interference contributions
56547
56548 FUNCTION PYRVG3(X)
56549
56550 IMPLICIT NONE
56551 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56552C...Second Dalitz variable for PYRVG4
56553 COMMON/PYG2DX/X1
56554 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
56555 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
56556 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
56557 LOGICAL MFLAG
56558 EXTERNAL PYGAU2,PYRVG4
56559 SAVE/PYRVPM/,/PYG2DX/
56560 PYRVG3=0D0
56561 C1=2D0*SQRT(MAX(1D-9,X))
56562 X1=X
56563 IF (.NOT.MFLAG) THEN
56564 E2 = X/C1
56565 E3 = (RM(0)**2-X)/C1
56566 YMIN = 0D0
56567 YMAX = 4D0*E2*E3
56568 ELSE
56569 E2 = (X-RM(1)**2+RM(2)**2)/C1
56570 E3 = (RM(0)**2-X-RM(3)**2)/C1
56571 SQ1 = (E2+E3)**2
56572 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56573 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56574 YMIN = SQ1-(SR1+SR2)**2
56575 YMAX = SQ1-(SR1-SR2)**2
56576 ENDIF
56577 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
56578 RETURN
56579 END
56580
56581C*********************************************************************
56582
56583C...PYRVG4
56584C...Integrand for true intereference contributions
56585
56586 FUNCTION PYRVG4(Y)
56587
56588 IMPLICIT NONE
56589 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56590 COMMON/PYG2DX/X
56591 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
56592 LOGICAL MFLAG
56593 SAVE /PYRVPM/,/PYG2DX/
56594 PYRVG4=0D0
56595 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
56596 IF (.NOT.MFLAG) THEN
56597 PYRVG4 = RVS*B(1)*B(2)*X*Y
56598 ELSE
56599 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
56600 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
56601 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
56602 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
56603 ENDIF
56604 RETURN
56605 END
56606
56607C*********************************************************************
56608
56609C...PYRVR
56610C...Breit-Wigner for resonance contributions
56611
56612 FUNCTION PYRVR(Mab2,RM,RW)
56613
56614 IMPLICIT NONE
56615 DOUBLE PRECISION Mab2,RM,RW,PYRVR
56616 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
56617 RETURN
56618 END
56619
56620C*********************************************************************
56621
56622C...PYRVS
56623C...Interference function
56624
56625 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
56626
56627 IMPLICIT NONE
56628 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
56629 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
56630 & +W1*W2*M1*M2)
56631 RETURN
56632 END
56633
56634C*********************************************************************
56635
56636C...PY1ENT
56637C...Stores one parton/particle in commonblock PYJETS.
56638
56639 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
56640
56641C...Double precision and integer declarations.
56642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56643 IMPLICIT INTEGER(I-N)
56644 INTEGER PYK,PYCHGE,PYCOMP
56645C...Commonblocks.
56646 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56649 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56650
56651C...Standard checks.
56652 MSTU(28)=0
56653 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56654 IPA=MAX(1,IABS(IP))
56655 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
56656 &'(PY1ENT:) writing outside PYJETS memory')
56657 KC=PYCOMP(KF)
56658 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
56659
56660C...Find mass. Reset K, P and V vectors.
56661 PM=0D0
56662 IF(MSTU(10).EQ.1) PM=P(IPA,5)
56663 IF(MSTU(10).GE.2) PM=PYMASS(KF)
56664 DO 100 J=1,5
56665 K(IPA,J)=0
56666 P(IPA,J)=0D0
56667 V(IPA,J)=0D0
56668 100 CONTINUE
56669
56670C...Store parton/particle in K and P vectors.
56671 K(IPA,1)=1
56672 IF(IP.LT.0) K(IPA,1)=2
56673 K(IPA,2)=KF
56674 P(IPA,5)=PM
56675 P(IPA,4)=MAX(PE,PM)
56676 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
56677 P(IPA,1)=PA*SIN(THE)*COS(PHI)
56678 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
56679 P(IPA,3)=PA*COS(THE)
56680
56681C...Set N. Optionally fragment/decay.
56682 N=IPA
56683 IF(IP.EQ.0) CALL PYEXEC
56684
56685 RETURN
56686 END
56687
56688C*********************************************************************
56689
56690C...PY2ENT
56691C...Stores two partons/particles in their CM frame,
56692C...with the first along the +z axis.
56693
56694 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
56695
56696C...Double precision and integer declarations.
56697 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56698 IMPLICIT INTEGER(I-N)
56699 INTEGER PYK,PYCHGE,PYCOMP
56700C...Commonblocks.
56701 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56702 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56703 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56704 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56705
56706C...Standard checks.
56707 MSTU(28)=0
56708 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56709 IPA=MAX(1,IABS(IP))
56710 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
56711 &'(PY2ENT:) writing outside PYJETS memory')
56712 KC1=PYCOMP(KF1)
56713 KC2=PYCOMP(KF2)
56714 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
56715 &'(PY2ENT:) unknown flavour code')
56716
56717C...Find masses. Reset K, P and V vectors.
56718 PM1=0D0
56719 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56720 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56721 PM2=0D0
56722 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56723 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56724 DO 110 I=IPA,IPA+1
56725 DO 100 J=1,5
56726 K(I,J)=0
56727 P(I,J)=0D0
56728 V(I,J)=0D0
56729 100 CONTINUE
56730 110 CONTINUE
56731
56732C...Check flavours.
56733 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56734 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56735 IF(MSTU(19).EQ.1) THEN
56736 MSTU(19)=0
56737 ELSE
56738 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
56739 & '(PY2ENT:) unphysical flavour combination')
56740 ENDIF
56741 K(IPA,2)=KF1
56742 K(IPA+1,2)=KF2
56743
56744C...Store partons/particles in K vectors for normal case.
56745 IF(IP.GE.0) THEN
56746 K(IPA,1)=1
56747 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
56748 K(IPA+1,1)=1
56749
56750C...Store partons in K vectors for parton shower evolution.
56751 ELSE
56752 K(IPA,1)=3
56753 K(IPA+1,1)=3
56754 K(IPA,4)=MSTU(5)*(IPA+1)
56755 K(IPA,5)=K(IPA,4)
56756 K(IPA+1,4)=MSTU(5)*IPA
56757 K(IPA+1,5)=K(IPA+1,4)
56758 ENDIF
56759
56760C...Check kinematics and store partons/particles in P vectors.
56761 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
56762 &'(PY2ENT:) energy smaller than sum of masses')
56763 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
56764 &(2D0*PECM)
56765 P(IPA,3)=PA
56766 P(IPA,4)=SQRT(PM1**2+PA**2)
56767 P(IPA,5)=PM1
56768 P(IPA+1,3)=-PA
56769 P(IPA+1,4)=SQRT(PM2**2+PA**2)
56770 P(IPA+1,5)=PM2
56771
56772C...Set N. Optionally fragment/decay.
56773 N=IPA+1
56774 IF(IP.EQ.0) CALL PYEXEC
56775
56776 RETURN
56777 END
56778
56779C*********************************************************************
56780
56781C...PY3ENT
56782C...Stores three partons or particles in their CM frame,
56783C...with the first along the +z axis and the third in the (x,z)
56784C...plane with x > 0.
56785
56786 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
56787
56788C...Double precision and integer declarations.
56789 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56790 IMPLICIT INTEGER(I-N)
56791 INTEGER PYK,PYCHGE,PYCOMP
56792C...Commonblocks.
56793 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56794 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56795 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56796 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56797
56798C...Standard checks.
56799 MSTU(28)=0
56800 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56801 IPA=MAX(1,IABS(IP))
56802 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
56803 &'(PY3ENT:) writing outside PYJETS memory')
56804 KC1=PYCOMP(KF1)
56805 KC2=PYCOMP(KF2)
56806 KC3=PYCOMP(KF3)
56807 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
56808 &'(PY3ENT:) unknown flavour code')
56809
56810C...Find masses. Reset K, P and V vectors.
56811 PM1=0D0
56812 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56813 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56814 PM2=0D0
56815 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56816 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56817 PM3=0D0
56818 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56819 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56820 DO 110 I=IPA,IPA+2
56821 DO 100 J=1,5
56822 K(I,J)=0
56823 P(I,J)=0D0
56824 V(I,J)=0D0
56825 100 CONTINUE
56826 110 CONTINUE
56827
56828C...Check flavours.
56829 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56830 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56831 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56832 IF(MSTU(19).EQ.1) THEN
56833 MSTU(19)=0
56834 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
56835 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
56836 & KQ1+KQ3.EQ.4)) THEN
56837 ELSE
56838 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
56839 ENDIF
56840 K(IPA,2)=KF1
56841 K(IPA+1,2)=KF2
56842 K(IPA+2,2)=KF3
56843
56844C...Store partons/particles in K vectors for normal case.
56845 IF(IP.GE.0) THEN
56846 K(IPA,1)=1
56847 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
56848 K(IPA+1,1)=1
56849 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
56850 K(IPA+2,1)=1
56851
56852C...Store partons in K vectors for parton shower evolution.
56853 ELSE
56854 K(IPA,1)=3
56855 K(IPA+1,1)=3
56856 K(IPA+2,1)=3
56857 KCS=4
56858 IF(KQ1.EQ.-1) KCS=5
56859 K(IPA,KCS)=MSTU(5)*(IPA+1)
56860 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
56861 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56862 K(IPA+1,9-KCS)=MSTU(5)*IPA
56863 K(IPA+2,KCS)=MSTU(5)*IPA
56864 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56865 ENDIF
56866
56867C...Check kinematics.
56868 MKERR=0
56869 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
56870 &0.5D0*X3*PECM.LE.PM3) MKERR=1
56871 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
56872 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
56873 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
56874 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
56875 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
56876 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
56877 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
56878 IF(MKERR.NE.0) CALL PYERRM(13,
56879 &'(PY3ENT:) unphysical kinematical variable setup')
56880
56881C...Store partons/particles in P vectors.
56882 P(IPA,3)=PA1
56883 P(IPA,4)=SQRT(PA1**2+PM1**2)
56884 P(IPA,5)=PM1
56885 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
56886 P(IPA+2,3)=PA3*CTHE3
56887 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
56888 P(IPA+2,5)=PM3
56889 P(IPA+1,1)=-P(IPA+2,1)
56890 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
56891 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
56892 P(IPA+1,5)=PM2
56893
56894C...Set N. Optionally fragment/decay.
56895 N=IPA+2
56896 IF(IP.EQ.0) CALL PYEXEC
56897
56898 RETURN
56899 END
56900
56901C*********************************************************************
56902
56903C...PY4ENT
56904C...Stores four partons or particles in their CM frame, with
56905C...the first along the +z axis, the last in the xz plane with x > 0
56906C...and the second having y < 0 and y > 0 with equal probability.
56907
56908 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
56909
56910C...Double precision and integer declarations.
56911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56912 IMPLICIT INTEGER(I-N)
56913 INTEGER PYK,PYCHGE,PYCOMP
56914C...Commonblocks.
56915 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56917 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56918 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56919
56920C...Standard checks.
56921 MSTU(28)=0
56922 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56923 IPA=MAX(1,IABS(IP))
56924 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
56925 &'(PY4ENT:) writing outside PYJETS momory')
56926 KC1=PYCOMP(KF1)
56927 KC2=PYCOMP(KF2)
56928 KC3=PYCOMP(KF3)
56929 KC4=PYCOMP(KF4)
56930 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
56931 &'(PY4ENT:) unknown flavour code')
56932
56933C...Find masses. Reset K, P and V vectors.
56934 PM1=0D0
56935 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56936 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56937 PM2=0D0
56938 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56939 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56940 PM3=0D0
56941 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56942 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56943 PM4=0D0
56944 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
56945 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
56946 DO 110 I=IPA,IPA+3
56947 DO 100 J=1,5
56948 K(I,J)=0
56949 P(I,J)=0D0
56950 V(I,J)=0D0
56951 100 CONTINUE
56952 110 CONTINUE
56953
56954C...Check flavours.
56955 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56956 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56957 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56958 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
56959 IF(MSTU(19).EQ.1) THEN
56960 MSTU(19)=0
56961 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
56962 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
56963 & KQ1+KQ4.EQ.4)) THEN
56964 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
56965 & THEN
56966 ELSE
56967 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
56968 ENDIF
56969 K(IPA,2)=KF1
56970 K(IPA+1,2)=KF2
56971 K(IPA+2,2)=KF3
56972 K(IPA+3,2)=KF4
56973
56974C...Store partons/particles in K vectors for normal case.
56975 IF(IP.GE.0) THEN
56976 K(IPA,1)=1
56977 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
56978 K(IPA+1,1)=1
56979 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
56980 & K(IPA+1,1)=2
56981 K(IPA+2,1)=1
56982 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
56983 K(IPA+3,1)=1
56984
56985C...Store partons for parton shower evolution from q-g-g-qbar or
56986C...g-g-g-g event.
56987 ELSEIF(KQ1+KQ2.NE.0) THEN
56988 K(IPA,1)=3
56989 K(IPA+1,1)=3
56990 K(IPA+2,1)=3
56991 K(IPA+3,1)=3
56992 KCS=4
56993 IF(KQ1.EQ.-1) KCS=5
56994 K(IPA,KCS)=MSTU(5)*(IPA+1)
56995 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
56996 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56997 K(IPA+1,9-KCS)=MSTU(5)*IPA
56998 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
56999 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
57000 K(IPA+3,KCS)=MSTU(5)*IPA
57001 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
57002
57003C...Store partons for parton shower evolution from q-qbar-q-qbar event.
57004 ELSE
57005 K(IPA,1)=3
57006 K(IPA+1,1)=3
57007 K(IPA+2,1)=3
57008 K(IPA+3,1)=3
57009 K(IPA,4)=MSTU(5)*(IPA+1)
57010 K(IPA,5)=K(IPA,4)
57011 K(IPA+1,4)=MSTU(5)*IPA
57012 K(IPA+1,5)=K(IPA+1,4)
57013 K(IPA+2,4)=MSTU(5)*(IPA+3)
57014 K(IPA+2,5)=K(IPA+2,4)
57015 K(IPA+3,4)=MSTU(5)*(IPA+2)
57016 K(IPA+3,5)=K(IPA+3,4)
57017 ENDIF
57018
57019C...Check kinematics.
57020 MKERR=0
57021 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
57022 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
57023 &MKERR=1
57024 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
57025 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
57026 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
57027 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
57028 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
57029 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
57030 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
57031 STHE4=SQRT(1D0-CTHE4**2)
57032 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
57033 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
57034 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
57035 STHE2=SQRT(1D0-CTHE2**2)
57036 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
57037 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
57038 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
57039 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
57040 IF(MKERR.EQ.1) CALL PYERRM(13,
57041 &'(PY4ENT:) unphysical kinematical variable setup')
57042
57043C...Store partons/particles in P vectors.
57044 P(IPA,3)=PA1
57045 P(IPA,4)=SQRT(PA1**2+PM1**2)
57046 P(IPA,5)=PM1
57047 P(IPA+3,1)=PA4*STHE4
57048 P(IPA+3,3)=PA4*CTHE4
57049 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
57050 P(IPA+3,5)=PM4
57051 P(IPA+1,1)=PA2*STHE2*CPHI2
57052 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
57053 P(IPA+1,3)=PA2*CTHE2
57054 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
57055 P(IPA+1,5)=PM2
57056 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
57057 P(IPA+2,2)=-P(IPA+1,2)
57058 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
57059 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
57060 P(IPA+2,5)=PM3
57061
57062C...Set N. Optionally fragment/decay.
57063 N=IPA+3
57064 IF(IP.EQ.0) CALL PYEXEC
57065
57066 RETURN
57067 END
57068
57069C*********************************************************************
57070
57071C...PY2FRM
57072C...An interface from a two-fermion generator to include
57073C...parton showers and hadronization.
57074
57075 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
57076
57077C...Double precision and integer declarations.
57078 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57079 IMPLICIT INTEGER(I-N)
57080 INTEGER PYK,PYCHGE,PYCOMP
57081C...Commonblocks.
57082 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57084 SAVE /PYJETS/,/PYDAT1/
57085C...Local arrays.
57086 DIMENSION IJOIN(2),INTAU(2)
57087
57088C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57089 IF(ICOM.EQ.0) THEN
57090 MSTU(28)=0
57091 CALL PYHEPC(2)
57092 ENDIF
57093
57094C...Loop through entries and pick up all final fermions/antifermions.
57095 I1=0
57096 I2=0
57097 DO 100 I=1,N
57098 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57099 KFA=IABS(K(I,2))
57100 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57101 IF(K(I,2).GT.0) THEN
57102 IF(I1.EQ.0) THEN
57103 I1=I
57104 ELSE
57105 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
57106 ENDIF
57107 ELSE
57108 IF(I2.EQ.0) THEN
57109 I2=I
57110 ELSE
57111 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
57112 ENDIF
57113 ENDIF
57114 ENDIF
57115 100 CONTINUE
57116
57117C...Check that event is arranged according to conventions.
57118 IF(I1.EQ.0.OR.I2.EQ.0) THEN
57119 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
57120 ENDIF
57121 IF(I2.LT.I1) THEN
57122 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
57123 ENDIF
57124
57125C...Check whether fermion pair is quarks or leptons.
57126 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57127 IQL12=1
57128 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57129 IQL12=2
57130 ELSE
57131 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
57132 ENDIF
57133
57134C...Decide whether to allow or not photon radiation in showers.
57135 MSTJ(41)=2
57136 IF(IRAD.EQ.0) MSTJ(41)=1
57137
57138C...Do colour joining and parton showers.
57139 IP1=I1
57140 IP2=I2
57141 IF(IQL12.EQ.1) THEN
57142 IJOIN(1)=IP1
57143 IJOIN(2)=IP2
57144 CALL PYJOIN(2,IJOIN)
57145 ENDIF
57146 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57147 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57148 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57149 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57150 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57151 ENDIF
57152
57153C...Do fragmentation and decays. Possibly except tau decay.
57154 IF(ITAU.EQ.0) THEN
57155 NTAU=0
57156 DO 110 I=1,N
57157 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57158 NTAU=NTAU+1
57159 INTAU(NTAU)=I
57160 K(I,1)=11
57161 ENDIF
57162 110 CONTINUE
57163 ENDIF
57164 CALL PYEXEC
57165 IF(ITAU.EQ.0) THEN
57166 DO 120 I=1,NTAU
57167 K(INTAU(I),1)=1
57168 120 CONTINUE
57169 ENDIF
57170
57171C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57172 IF(ICOM.EQ.0) THEN
57173 MSTU(28)=0
57174 CALL PYHEPC(1)
57175 ENDIF
57176
57177 END
57178
57179C*********************************************************************
57180
57181C...PY4FRM
57182C...An interface from a four-fermion generator to include
57183C...parton showers and hadronization.
57184
57185 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
57186
57187C...Double precision and integer declarations.
57188 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57189 IMPLICIT INTEGER(I-N)
57190 INTEGER PYK,PYCHGE,PYCOMP
57191C...Commonblocks.
57192 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57193 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57194 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57195 COMMON/PYINT1/MINT(400),VINT(400)
57196 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
57197C...Local arrays.
57198 DIMENSION IJOIN(2),INTAU(4)
57199
57200C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57201 IF(ICOM.EQ.0) THEN
57202 MSTU(28)=0
57203 CALL PYHEPC(2)
57204 ENDIF
57205
57206C...Loop through entries and pick up all final fermions/antifermions.
57207 I1=0
57208 I2=0
57209 I3=0
57210 I4=0
57211 DO 100 I=1,N
57212 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57213 KFA=IABS(K(I,2))
57214 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57215 IF(K(I,2).GT.0) THEN
57216 IF(I1.EQ.0) THEN
57217 I1=I
57218 ELSEIF(I3.EQ.0) THEN
57219 I3=I
57220 ELSE
57221 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
57222 ENDIF
57223 ELSE
57224 IF(I2.EQ.0) THEN
57225 I2=I
57226 ELSEIF(I4.EQ.0) THEN
57227 I4=I
57228 ELSE
57229 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
57230 ENDIF
57231 ENDIF
57232 ENDIF
57233 100 CONTINUE
57234
57235C...Check that event is arranged according to conventions.
57236 IF(I3.EQ.0.OR.I4.EQ.0) THEN
57237 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
57238 ENDIF
57239 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57240 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
57241 ENDIF
57242
57243C...Check which fermion pairs are quarks and which leptons.
57244 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57245 IQL12=1
57246 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57247 IQL12=2
57248 ELSE
57249 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
57250 ENDIF
57251 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57252 IQL34=1
57253 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57254 IQL34=2
57255 ELSE
57256 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
57257 ENDIF
57258
57259C...Decide whether to allow or not photon radiation in showers.
57260 MSTJ(41)=2
57261 IF(IRAD.EQ.0) MSTJ(41)=1
57262
57263C...Decide on dipole pairing.
57264 IP1=I1
57265 IP2=I2
57266 IP3=I3
57267 IP4=I4
57268 IF(IQL12.EQ.IQL34) THEN
57269 R1SQ=A1SQ
57270 R2SQ=A2SQ
57271 DELTA=ATOTSQ-A1SQ-A2SQ
57272 IF(ISTRAT.EQ.1) THEN
57273 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
57274 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
57275 ELSEIF(ISTRAT.EQ.2) THEN
57276 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
57277 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
57278 ENDIF
57279 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
57280 IP2=I4
57281 IP4=I2
57282 ENDIF
57283 ENDIF
57284
57285C...If colour reconnection then bookkeep W+W- or Z0Z0
57286C...and copy q qbar q qbar consecutively.
57287 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57288 K(N+1,1)=11
57289 K(N+1,3)=IP1
57290 K(N+1,4)=N+3
57291 K(N+1,5)=N+4
57292 K(N+2,1)=11
57293 K(N+2,3)=IP3
57294 K(N+2,4)=N+5
57295 K(N+2,5)=N+6
57296 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
57297 K(N+1,2)=23
57298 K(N+2,2)=23
57299 MINT(1)=22
57300 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
57301 K(N+1,2)=24
57302 K(N+2,2)=-24
57303 MINT(1)=25
57304 ELSE
57305 K(N+1,2)=-24
57306 K(N+2,2)=24
57307 MINT(1)=25
57308 ENDIF
57309 DO 110 J=1,5
57310 K(N+3,J)=K(IP1,J)
57311 K(N+4,J)=K(IP2,J)
57312 K(N+5,J)=K(IP3,J)
57313 K(N+6,J)=K(IP4,J)
57314 P(N+1,J)=P(IP1,J)+P(IP2,J)
57315 P(N+2,J)=P(IP3,J)+P(IP4,J)
57316 P(N+3,J)=P(IP1,J)
57317 P(N+4,J)=P(IP2,J)
57318 P(N+5,J)=P(IP3,J)
57319 P(N+6,J)=P(IP4,J)
57320 V(N+1,J)=V(IP1,J)
57321 V(N+2,J)=V(IP3,J)
57322 V(N+3,J)=V(IP1,J)
57323 V(N+4,J)=V(IP2,J)
57324 V(N+5,J)=V(IP3,J)
57325 V(N+6,J)=V(IP4,J)
57326 110 CONTINUE
57327 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57328 & P(N+1,3)**2))
57329 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57330 & P(N+2,3)**2))
57331 K(N+3,3)=N+1
57332 K(N+4,3)=N+1
57333 K(N+5,3)=N+2
57334 K(N+6,3)=N+2
57335C...Remove original q qbar q qbar and update counters.
57336 K(IP1,1)=K(IP1,1)+10
57337 K(IP2,1)=K(IP2,1)+10
57338 K(IP3,1)=K(IP3,1)+10
57339 K(IP4,1)=K(IP4,1)+10
57340 IW1=N+1
57341 IW2=N+2
57342 NSD1=N+2
57343 IP1=N+3
57344 IP2=N+4
57345 IP3=N+5
57346 IP4=N+6
57347 N=N+6
57348 ENDIF
57349
57350C...Do colour joinings and parton showers.
57351 IF(IQL12.EQ.1) THEN
57352 IJOIN(1)=IP1
57353 IJOIN(2)=IP2
57354 CALL PYJOIN(2,IJOIN)
57355 ENDIF
57356 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57357 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57358 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57359 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57360 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57361 ENDIF
57362 NAFT1=N
57363 IF(IQL34.EQ.1) THEN
57364 IJOIN(1)=IP3
57365 IJOIN(2)=IP4
57366 CALL PYJOIN(2,IJOIN)
57367 ENDIF
57368 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57369 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57370 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57371 if(parj(200).ne.1.) CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57372 if(parj(200).eq.1.) CALL PYSHOWQ(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57373 ENDIF
57374
57375C...Optionally do colour reconnection.
57376 MINT(32)=0
57377 MSTI(32)=0
57378 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57379 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
57380 MSTI(32)=MINT(32)
57381 ENDIF
57382
57383C...Do fragmentation and decays. Possibly except tau decay.
57384 IF(ITAU.EQ.0) THEN
57385 NTAU=0
57386 DO 120 I=1,N
57387 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57388 NTAU=NTAU+1
57389 INTAU(NTAU)=I
57390 K(I,1)=11
57391 ENDIF
57392 120 CONTINUE
57393 ENDIF
57394 CALL PYEXEC
57395 IF(ITAU.EQ.0) THEN
57396 DO 130 I=1,NTAU
57397 K(INTAU(I),1)=1
57398 130 CONTINUE
57399 ENDIF
57400
57401C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57402 IF(ICOM.EQ.0) THEN
57403 MSTU(28)=0
57404 CALL PYHEPC(1)
57405 ENDIF
57406
57407 END
57408
57409C*********************************************************************
57410
57411C...PY6FRM
57412C...An interface from a six-fermion generator to include
57413C...parton showers and hadronization.
57414
57415 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
57416
57417C...Double precision and integer declarations.
57418 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57419 IMPLICIT INTEGER(I-N)
57420 INTEGER PYK,PYCHGE,PYCOMP
57421C...Commonblocks.
57422 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57423 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57424 SAVE /PYJETS/,/PYDAT1/
57425C...Local arrays.
57426 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
57427
57428C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57429 IF(ICOM.EQ.0) THEN
57430 MSTU(28)=0
57431 CALL PYHEPC(2)
57432 ENDIF
57433
57434C...Loop through entries and pick up all final fermions/antifermions.
57435 I1=0
57436 I2=0
57437 I3=0
57438 I4=0
57439 I5=0
57440 I6=0
57441 DO 100 I=1,N
57442 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57443 KFA=IABS(K(I,2))
57444 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57445 IF(K(I,2).GT.0) THEN
57446 IF(I1.EQ.0) THEN
57447 I1=I
57448 ELSEIF(I3.EQ.0) THEN
57449 I3=I
57450 ELSEIF(I5.EQ.0) THEN
57451 I5=I
57452 ELSE
57453 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
57454 ENDIF
57455 ELSE
57456 IF(I2.EQ.0) THEN
57457 I2=I
57458 ELSEIF(I4.EQ.0) THEN
57459 I4=I
57460 ELSEIF(I6.EQ.0) THEN
57461 I6=I
57462 ELSE
57463 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
57464 ENDIF
57465 ENDIF
57466 ENDIF
57467 100 CONTINUE
57468
57469C...Check that event is arranged according to conventions.
57470 IF(I5.EQ.0.OR.I6.EQ.0) THEN
57471 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
57472 ENDIF
57473 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
57474 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
57475 ENDIF
57476
57477C...Check which fermion pairs are quarks and which leptons.
57478 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57479 IQL12=1
57480 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57481 IQL12=2
57482 ELSE
57483 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
57484 ENDIF
57485 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57486 IQL34=1
57487 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57488 IQL34=2
57489 ELSE
57490 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
57491 ENDIF
57492 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
57493 IQL56=1
57494 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
57495 IQL56=2
57496 ELSE
57497 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
57498 ENDIF
57499
57500C...Decide whether to allow or not photon radiation in showers.
57501 MSTJ(41)=2
57502 IF(IRAD.EQ.0) MSTJ(41)=1
57503
57504C...Allow dipole pairings only among leptons and quarks separately.
57505 P12D=P12
57506 P13D=0D0
57507 IF(IQL34.EQ.IQL56) P13D=P13
57508 P21D=0D0
57509 IF(IQL12.EQ.IQL34) P21D=P21
57510 P23D=0D0
57511 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
57512 P31D=0D0
57513 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
57514 P32D=0D0
57515 IF(IQL12.EQ.IQL56) P32D=P32
57516
57517C...Decide whether t+tbar.
57518 ITOP=0
57519 IF(PYR(0).LT.PTOP) THEN
57520 ITOP=1
57521
57522C...If t+tbar: reconstruct t's.
57523 IT=N+1
57524 ITB=N+2
57525 DO 110 J=1,5
57526 K(IT,J)=0
57527 K(ITB,J)=0
57528 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
57529 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
57530 V(IT,J)=0D0
57531 V(ITB,J)=0D0
57532 110 CONTINUE
57533 K(IT,1)=1
57534 K(ITB,1)=1
57535 K(IT,2)=6
57536 K(ITB,2)=-6
57537 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
57538 & P(IT,3)**2))
57539 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
57540 & P(ITB,3)**2))
57541 N=N+2
57542
57543C...If t+tbar: colour join t's and let them shower.
57544 IJOIN(1)=IT
57545 IJOIN(2)=ITB
57546 CALL PYJOIN(2,IJOIN)
57547 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
57548 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
57549 if(parj(200).ne.1.) CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57550 if(parj(200).eq.1.) CALL PYSHOWQ(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57551C...If t+tbar: pick up the t's after shower.
57552 ITNEW=IT
57553 ITBNEW=ITB
57554 DO 120 I=ITB+1,N
57555 IF(K(I,2).EQ.6) ITNEW=I
57556 IF(K(I,2).EQ.-6) ITBNEW=I
57557 120 CONTINUE
57558
57559C...If t+tbar: loop over two top systems.
57560 DO 200 IT1=1,2
57561 IF(IT1.EQ.1) THEN
57562 ITO=IT
57563 ITN=ITNEW
57564 IBO=I1
57565 IW1=I3
57566 IW2=I4
57567 ELSE
57568 ITO=ITB
57569 ITN=ITBNEW
57570 IBO=I2
57571 IW1=I5
57572 IW2=I6
57573 ENDIF
57574 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
57575 & '(PY6FRM:) not b in t decay')
57576
57577C...If t+tbar: find boost from original to new top frame.
57578 DO 130 J=1,3
57579 BETAO(J)=P(ITO,J)/P(ITO,4)
57580 BETAN(J)=P(ITN,J)/P(ITN,4)
57581 130 CONTINUE
57582
57583C...If t+tbar: boost copy of b by t shower and connect it in colour.
57584 N=N+1
57585 IB=N
57586 K(IB,1)=3
57587 K(IB,2)=K(IBO,2)
57588 K(IB,3)=ITN
57589 DO 140 J=1,5
57590 P(IB,J)=P(IBO,J)
57591 V(IB,J)=0D0
57592 140 CONTINUE
57593 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57594 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57595 K(IB,4)=MSTU(5)*ITN
57596 K(IB,5)=MSTU(5)*ITN
57597 K(ITN,4)=K(ITN,4)+IB
57598 K(ITN,5)=K(ITN,5)+IB
57599 K(ITN,1)=K(ITN,1)+10
57600 K(IBO,1)=K(IBO,1)+10
57601
57602C...If t+tbar: construct W recoiling against b.
57603 N=N+1
57604 IW=N
57605 DO 150 J=1,5
57606 K(IW,J)=0
57607 V(IW,J)=0D0
57608 150 CONTINUE
57609 K(IW,1)=1
57610 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
57611 IF(IABS(KCHW).EQ.3) THEN
57612 K(IW,2)=ISIGN(24,KCHW)
57613 ELSE
57614 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
57615 ENDIF
57616 K(IW,3)=IW1
57617
57618C...If t+tbar: construct W momentum, including boost by t shower.
57619 DO 160 J=1,4
57620 P(IW,J)=P(IW1,J)+P(IW2,J)
57621 160 CONTINUE
57622 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
57623 & P(IW,3)**2))
57624 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57625 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57626
57627C...If t+tbar: boost b and W to top rest frame.
57628 DO 170 J=1,3
57629 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
57630 170 CONTINUE
57631 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57632 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57633
57634C...If t+tbar: let b shower and pick up modified W.
57635 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
57636 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
57637 if(parj(200).ne.1.) CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
57638 if(parj(200).eq.1.) CALL PYSHOWQ(IB,IW,SQRT(MAX(0D0,PMTS)))
57639 DO 180 I=IW,N
57640 IF(IABS(K(I,2)).EQ.24) IWM=I
57641 180 CONTINUE
57642
57643C...If t+tbar: take copy of W decay products.
57644 DO 190 J=1,5
57645 K(N+1,J)=K(IW1,J)
57646 P(N+1,J)=P(IW1,J)
57647 V(N+1,J)=V(IW1,J)
57648 K(N+2,J)=K(IW2,J)
57649 P(N+2,J)=P(IW2,J)
57650 V(N+2,J)=V(IW2,J)
57651 190 CONTINUE
57652 K(IW1,1)=K(IW1,1)+10
57653 K(IW2,1)=K(IW2,1)+10
57654 K(IWM,1)=K(IWM,1)+10
57655 K(IWM,4)=N+1
57656 K(IWM,5)=N+2
57657 K(N+1,3)=IWM
57658 K(N+2,3)=IWM
57659 IF(IT1.EQ.1) THEN
57660 I3=N+1
57661 I4=N+2
57662 ELSE
57663 I5=N+1
57664 I6=N+2
57665 ENDIF
57666 N=N+2
57667
57668C...If t+tbar: boost W decay products, first by effects of t shower,
57669C...then by those of b shower. b and its shower simple boost back.
57670 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57671 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57672 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57673 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
57674 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
57675 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
57676 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
57677 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
57678 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
57679 200 CONTINUE
57680 ENDIF
57681
57682C...Decide on dipole pairing.
57683 IP1=I1
57684 IP3=I3
57685 IP5=I5
57686 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
57687 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
57688 IP2=I2
57689 IP4=I4
57690 IP6=I6
57691 ELSEIF(PRN.LT.P12D+P13D) THEN
57692 IP2=I2
57693 IP4=I6
57694 IP6=I4
57695 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
57696 IP2=I4
57697 IP4=I2
57698 IP6=I6
57699 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
57700 IP2=I4
57701 IP4=I6
57702 IP6=I2
57703 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
57704 IP2=I6
57705 IP4=I2
57706 IP6=I4
57707 ELSE
57708 IP2=I6
57709 IP4=I4
57710 IP6=I2
57711 ENDIF
57712
57713C...Do colour joinings and parton showers
57714C...(except ones already made for t+tbar).
57715 IF(ITOP.EQ.0) THEN
57716 IF(IQL12.EQ.1) THEN
57717 IJOIN(1)=IP1
57718 IJOIN(2)=IP2
57719 CALL PYJOIN(2,IJOIN)
57720 ENDIF
57721 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57722 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57723 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57724 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57725 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57726 ENDIF
57727 ENDIF
57728 IF(IQL34.EQ.1) THEN
57729 IJOIN(1)=IP3
57730 IJOIN(2)=IP4
57731 CALL PYJOIN(2,IJOIN)
57732 ENDIF
57733 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57734 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57735 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57736 if(parj(200).ne.1.) CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57737 if(parj(200).eq.1.) CALL PYSHOWQ(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57738 ENDIF
57739 IF(IQL56.EQ.1) THEN
57740 IJOIN(1)=IP5
57741 IJOIN(2)=IP6
57742 CALL PYJOIN(2,IJOIN)
57743 ENDIF
57744 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
57745 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
57746 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
57747 if(parj(200).ne.1.) CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57748 if(parj(200).eq.1.) CALL PYSHOWQ(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57749 ENDIF
57750
57751C...Do fragmentation and decays. Possibly except tau decay.
57752 IF(ITAU.EQ.0) THEN
57753 NTAU=0
57754 DO 210 I=1,N
57755 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57756 NTAU=NTAU+1
57757 INTAU(NTAU)=I
57758 K(I,1)=11
57759 ENDIF
57760 210 CONTINUE
57761 ENDIF
57762 CALL PYEXEC
57763 IF(ITAU.EQ.0) THEN
57764 DO 220 I=1,NTAU
57765 K(INTAU(I),1)=1
57766 220 CONTINUE
57767 ENDIF
57768
57769C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57770 IF(ICOM.EQ.0) THEN
57771 MSTU(28)=0
57772 CALL PYHEPC(1)
57773 ENDIF
57774
57775 END
57776
57777C*********************************************************************
57778
57779C...PY4JET
57780C...An interface from a four-parton generator to include
57781C...parton showers and hadronization.
57782
57783 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
57784
57785C...Double precision and integer declarations.
57786 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57787 IMPLICIT INTEGER(I-N)
57788 INTEGER PYK,PYCHGE,PYCOMP
57789C...Commonblocks.
57790 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57791 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57792 SAVE /PYJETS/,/PYDAT1/
57793C...Local arrays.
57794 DIMENSION IJOIN(2),PTOT(4),BETA(3)
57795
57796C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57797 IF(ICOM.EQ.0) THEN
57798 MSTU(28)=0
57799 CALL PYHEPC(2)
57800 ENDIF
57801
57802C...Loop through entries and pick up all final partons.
57803 I1=0
57804 I2=0
57805 I3=0
57806 I4=0
57807 DO 100 I=1,N
57808 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57809 KFA=IABS(K(I,2))
57810 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
57811 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
57812 IF(I1.EQ.0) THEN
57813 I1=I
57814 ELSEIF(I3.EQ.0) THEN
57815 I3=I
57816 ELSE
57817 CALL PYERRM(16,'(PY4JET:) more than two quarks')
57818 ENDIF
57819 ELSEIF(K(I,2).LT.0) THEN
57820 IF(I2.EQ.0) THEN
57821 I2=I
57822 ELSEIF(I4.EQ.0) THEN
57823 I4=I
57824 ELSE
57825 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
57826 ENDIF
57827 ELSE
57828 IF(I3.EQ.0) THEN
57829 I3=I
57830 ELSEIF(I4.EQ.0) THEN
57831 I4=I
57832 ELSE
57833 CALL PYERRM(16,'(PY4JET:) more than two gluons')
57834 ENDIF
57835 ENDIF
57836 ENDIF
57837 100 CONTINUE
57838
57839C...Check that event is arranged according to conventions.
57840 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
57841 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
57842 ENDIF
57843 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57844 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
57845 ENDIF
57846
57847C...Check whether second pair are quarks or gluons.
57848 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57849 IQG34=1
57850 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
57851 IQG34=2
57852 ELSE
57853 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
57854 ENDIF
57855
57856C...Boost partons to their cm frame.
57857 DO 110 J=1,4
57858 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
57859 110 CONTINUE
57860 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
57861 DO 120 J=1,3
57862 BETA(J)=PTOT(J)/PTOT(4)
57863 120 CONTINUE
57864 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57865 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57866 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57867 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57868 NSAV=N
57869
57870C...Decide and set up shower history for q qbar q' qbar' events.
57871 IF(IQG34.EQ.1) THEN
57872 W1=PY4JTW(0,I1,I3,I4)
57873 W2=PY4JTW(0,I2,I3,I4)
57874 IF(W1.GT.PYR(0)*(W1+W2)) THEN
57875 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57876 ELSE
57877 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57878 ENDIF
57879
57880C...Decide and set up shower history for q qbar g g events.
57881 ELSE
57882 W1=PY4JTW(I1,I3,I2,I4)
57883 W2=PY4JTW(I1,I4,I2,I3)
57884 W3=PY4JTW(0,I3,I1,I4)
57885 W4=PY4JTW(0,I4,I1,I3)
57886 W5=PY4JTW(0,I3,I2,I4)
57887 W6=PY4JTW(0,I4,I2,I3)
57888 W7=PY4JTW(0,I1,I3,I4)
57889 W8=PY4JTW(0,I2,I3,I4)
57890 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
57891 IF(W1.GT.WR) THEN
57892 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
57893 ELSEIF(W1+W2.GT.WR) THEN
57894 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
57895 ELSEIF(W1+W2+W3.GT.WR) THEN
57896 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
57897 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
57898 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
57899 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
57900 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
57901 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
57902 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
57903 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
57904 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57905 ELSE
57906 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57907 ENDIF
57908 ENDIF
57909
57910C...Boost back original partons and mark them as deleted.
57911 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
57912 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
57913 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
57914 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
57915 K(I1,1)=K(I1,1)+10
57916 K(I2,1)=K(I2,1)+10
57917 K(I3,1)=K(I3,1)+10
57918 K(I4,1)=K(I4,1)+10
57919
57920C...Rotate shower initiating partons to be along z axis.
57921 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
57922 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
57923 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
57924 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
57925
57926C...Set up copy of shower initiating partons as on mass shell.
57927 DO 140 I=N+1,N+2
57928 DO 130 J=1,5
57929 K(I,J)=0
57930 P(I,J)=0D0
57931 V(I,J)=V(I1,J)
57932 130 CONTINUE
57933 K(I,1)=1
57934 K(I,2)=K(I-6,2)
57935 140 CONTINUE
57936 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
57937 K(N+1,3)=I1
57938 P(N+1,5)=P(I1,5)
57939 K(N+2,3)=I2
57940 P(N+2,5)=P(I2,5)
57941 ELSE
57942 K(N+1,3)=I2
57943 P(N+1,5)=P(I2,5)
57944 K(N+2,3)=I1
57945 P(N+2,5)=P(I1,5)
57946 ENDIF
57947 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
57948 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
57949 P(N+1,3)=PABS
57950 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
57951 P(N+2,3)=-PABS
57952 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
57953 N=N+2
57954
57955C...Decide whether to allow or not photon radiation in showers.
57956C...Connect up colours.
57957 MSTJ(41)=2
57958 IF(IRAD.EQ.0) MSTJ(41)=1
57959 IJOIN(1)=N-1
57960 IJOIN(2)=N
57961 CALL PYJOIN(2,IJOIN)
57962
57963C...Decide on maximum virtuality and do parton shower.
57964 IF(PMAX.LT.PARJ(82)) THEN
57965 PQMAX=QMAX
57966 ELSE
57967 PQMAX=PMAX
57968 ENDIF
57969 if(parj(200).ne.1.) CALL PYSHOW(NSAV+1,-100,PQMAX)
57970 if(parj(200).eq.1.) CALL PYSHOWQ(NSAV+1,-100,PQMAX)
57971
57972C...Rotate and boost back system.
57973 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
57974
57975C...Do fragmentation and decays.
57976 CALL PYEXEC
57977
57978C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57979 IF(ICOM.EQ.0) THEN
57980 MSTU(28)=0
57981 CALL PYHEPC(1)
57982 ENDIF
57983
57984 RETURN
57985 END
57986
57987C*********************************************************************
57988
57989C...PY4JTW
57990C...Auxiliary to PY4JET, to evaluate weight of configuration.
57991
57992 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
57993
57994C...Double precision and integer declarations.
57995 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57996 IMPLICIT INTEGER(I-N)
57997 INTEGER PYK,PYCHGE,PYCOMP
57998C...Commonblocks.
57999 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58000 SAVE /PYJETS/
58001
58002C...First case: when both original partons radiate.
58003C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
58004 IF(IA1.NE.0) THEN
58005 DO 100 J=1,4
58006 P(N+1,J)=P(IA1,J)+P(IA2,J)
58007 P(N+2,J)=P(IA3,J)+P(IA4,J)
58008 100 CONTINUE
58009 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58010 & P(N+1,3)**2))
58011 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58012 & P(N+2,3)**2))
58013 Z1=P(IA1,4)/P(N+1,4)
58014 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
58015 Z2=P(IA3,4)/P(N+2,4)
58016 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
58017
58018C...Second case: when one original parton radiates to three.
58019C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
58020 ELSE
58021 DO 110 J=1,4
58022 P(N+2,J)=P(IA3,J)+P(IA4,J)
58023 P(N+1,J)=P(N+2,J)+P(IA2,J)
58024 110 CONTINUE
58025 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58026 & P(N+1,3)**2))
58027 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58028 & P(N+2,3)**2))
58029 IF(K(IA2,2).EQ.21) THEN
58030 Z1=P(N+2,4)/P(N+1,4)
58031 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58032 & P(IA3,5)**2)
58033 ELSE
58034 Z1=P(IA2,4)/P(N+1,4)
58035 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58036 & P(IA2,5)**2)
58037 ENDIF
58038 Z2=P(IA3,4)/P(N+2,4)
58039 IF(K(IA2,2).EQ.21) THEN
58040 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
58041 & P(IA3,5)**2)
58042 ELSEIF(K(IA3,2).EQ.21) THEN
58043 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
58044 ELSE
58045 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
58046 ENDIF
58047 ENDIF
58048
58049C...Total weight.
58050 PY4JTW=WT1*WT2
58051
58052 RETURN
58053 END
58054
58055C*********************************************************************
58056
58057C...PY4JTS
58058C...Auxiliary to PY4JET, to set up chosen configuration.
58059
58060 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
58061
58062C...Double precision and integer declarations.
58063 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58064 IMPLICIT INTEGER(I-N)
58065 INTEGER PYK,PYCHGE,PYCOMP
58066C...Commonblocks.
58067 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58068 SAVE /PYJETS/
58069
58070C...Reset info.
58071 DO 110 I=N+1,N+6
58072 DO 100 J=1,5
58073 K(I,J)=0
58074 V(I,J)=V(IA2,J)
58075 100 CONTINUE
58076 K(I,1)=16
58077 110 CONTINUE
58078
58079C...First case: when both original partons radiate.
58080C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
58081 IF(IA1.NE.0) THEN
58082
58083C...Set up flavour and history pointers for new partons.
58084 K(N+1,2)=K(IA1,2)
58085 K(N+2,2)=K(IA3,2)
58086 K(N+3,2)=K(IA1,2)
58087 K(N+4,2)=K(IA2,2)
58088 K(N+5,2)=K(IA3,2)
58089 K(N+6,2)=K(IA4,2)
58090 K(N+1,3)=IA1
58091 K(N+1,4)=N+3
58092 K(N+1,5)=N+4
58093 K(N+2,3)=IA3
58094 K(N+2,4)=N+5
58095 K(N+2,5)=N+6
58096 K(N+3,3)=N+1
58097 K(N+4,3)=N+1
58098 K(N+5,3)=N+2
58099 K(N+6,3)=N+2
58100
58101C...Set up momenta for new partons.
58102 DO 120 J=1,5
58103 P(N+1,J)=P(IA1,J)+P(IA2,J)
58104 P(N+2,J)=P(IA3,J)+P(IA4,J)
58105 P(N+3,J)=P(IA1,J)
58106 P(N+4,J)=P(IA2,J)
58107 P(N+5,J)=P(IA3,J)
58108 P(N+6,J)=P(IA4,J)
58109 120 CONTINUE
58110 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58111 & P(N+1,3)**2))
58112 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58113 & P(N+2,3)**2))
58114 QMAX=MIN(P(N+1,5),P(N+2,5))
58115
58116C...Second case: q radiates twice.
58117C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
58118C...IA5=N+2 does not radiate.
58119 ELSEIF(K(IA2,2).EQ.21) THEN
58120
58121C...Set up flavour and history pointers for new partons.
58122 K(N+1,2)=K(IA3,2)
58123 K(N+2,2)=K(IA5,2)
58124 K(N+3,2)=K(IA3,2)
58125 K(N+4,2)=K(IA2,2)
58126 K(N+5,2)=K(IA3,2)
58127 K(N+6,2)=K(IA4,2)
58128 K(N+1,3)=IA3
58129 K(N+1,4)=N+3
58130 K(N+1,5)=N+4
58131 K(N+2,3)=IA5
58132 K(N+3,3)=N+1
58133 K(N+3,4)=N+5
58134 K(N+3,5)=N+6
58135 K(N+4,3)=N+1
58136 K(N+5,3)=N+3
58137 K(N+6,3)=N+3
58138
58139C...Set up momenta for new partons.
58140 DO 130 J=1,5
58141 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58142 P(N+2,J)=P(IA5,J)
58143 P(N+3,J)=P(IA3,J)+P(IA4,J)
58144 P(N+4,J)=P(IA2,J)
58145 P(N+5,J)=P(IA3,J)
58146 P(N+6,J)=P(IA4,J)
58147 130 CONTINUE
58148 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58149 & P(N+1,3)**2))
58150 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
58151 & P(N+3,3)**2))
58152 QMAX=P(N+3,5)
58153
58154C...Third case: q radiates g, g branches.
58155C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
58156C...IA5=N+2 does not radiate.
58157 ELSE
58158
58159C...Set up flavour and history pointers for new partons.
58160 K(N+1,2)=K(IA2,2)
58161 K(N+2,2)=K(IA5,2)
58162 K(N+3,2)=K(IA2,2)
58163 K(N+4,2)=21
58164 K(N+5,2)=K(IA3,2)
58165 K(N+6,2)=K(IA4,2)
58166 K(N+1,3)=IA2
58167 K(N+1,4)=N+3
58168 K(N+1,5)=N+4
58169 K(N+2,3)=IA5
58170 K(N+3,3)=N+1
58171 K(N+4,3)=N+1
58172 K(N+4,4)=N+5
58173 K(N+4,5)=N+6
58174 K(N+5,3)=N+4
58175 K(N+6,3)=N+4
58176
58177C...Set up momenta for new partons.
58178 DO 140 J=1,5
58179 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58180 P(N+2,J)=P(IA5,J)
58181 P(N+3,J)=P(IA2,J)
58182 P(N+4,J)=P(IA3,J)+P(IA4,J)
58183 P(N+5,J)=P(IA3,J)
58184 P(N+6,J)=P(IA4,J)
58185 140 CONTINUE
58186 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58187 & P(N+1,3)**2))
58188 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
58189 & P(N+4,3)**2))
58190 QMAX=P(N+4,5)
58191
58192 ENDIF
58193 N=N+6
58194
58195 RETURN
58196 END
58197
58198C*********************************************************************
58199
58200C...PYJOIN
58201C...Connects a sequence of partons with colour flow indices,
58202C...as required for subsequent shower evolution (or other operations).
58203
58204 SUBROUTINE PYJOIN(NJOIN,IJOIN)
58205
58206C...Double precision and integer declarations.
58207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58208 IMPLICIT INTEGER(I-N)
58209 INTEGER PYK,PYCHGE,PYCOMP
58210C...Commonblocks.
58211 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58212 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58213 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58214 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58215C...Local array.
58216 DIMENSION IJOIN(*)
58217
58218C...Check that partons are of right types to be connected.
58219 IF(NJOIN.LT.2) GOTO 120
58220 KQSUM=0
58221 DO 100 IJN=1,NJOIN
58222 I=IJOIN(IJN)
58223 IF(I.LE.0.OR.I.GT.N) GOTO 120
58224 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
58225 KC=PYCOMP(K(I,2))
58226 IF(KC.EQ.0) GOTO 120
58227 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
58228 IF(KQ.EQ.0) GOTO 120
58229 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
58230 IF(KQ.NE.2) KQSUM=KQSUM+KQ
58231 IF(IJN.EQ.1) KQS=KQ
58232 100 CONTINUE
58233 IF(KQSUM.NE.0) GOTO 120
58234
58235C...Connect the partons sequentially (closing for gluon loop).
58236 KCS=(9-KQS)/2
58237 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
58238 DO 110 IJN=1,NJOIN
58239 I=IJOIN(IJN)
58240 K(I,1)=3
58241 IF(IJN.NE.1) IP=IJOIN(IJN-1)
58242 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
58243 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
58244 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
58245 K(I,KCS)=MSTU(5)*IN
58246 K(I,9-KCS)=MSTU(5)*IP
58247 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
58248 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
58249 110 CONTINUE
58250
58251C...Error exit: no action taken.
58252 RETURN
58253 120 CALL PYERRM(12,
58254 &'(PYJOIN:) given entries can not be joined by one string')
58255
58256 RETURN
58257 END
58258
58259C*********************************************************************
58260
58261C...PYGIVE
58262C...Sets values of commonblock variables.
58263
58264 SUBROUTINE PYGIVE(CHIN)
58265
58266C...Double precision and integer declarations.
58267 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58268 IMPLICIT INTEGER(I-N)
58269 INTEGER PYK,PYCHGE,PYCOMP
58270C...Commonblocks.
58271 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58272 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58273 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58274 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58275 COMMON/PYDAT4/CHAF(500,2)
58276 CHARACTER CHAF*16
58277 COMMON/PYDATR/MRPY(6),RRPY(100)
58278 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
58279 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58280 COMMON/PYINT1/MINT(400),VINT(400)
58281 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
58282 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
58283 COMMON/PYINT4/MWID(500),WIDS(500,5)
58284 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
58285 COMMON/PYINT6/PROC(0:500)
58286 CHARACTER PROC*28
58287 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
58288 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
58289 &XPDIR(-6:6)
58290 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58291 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58292 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
58293 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
58294 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
58295 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
58296C...Local arrays and character variables.
58297 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
58298 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
58299 &CHINR*16,CHDIG*10
58300 DIMENSION MSVAR(54,8)
58301
58302C...For each variable to be translated give: name,
58303C...integer/real/character, no. of indices, lower&upper index bounds.
58304 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
58305 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
58306 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
58307 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
58308 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
58309 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
58310 &'ITCM','RTCM'/
58311 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
58312 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
58313 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58314 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
58315 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
58316 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
58317 &1,1,1,6,4*0, 2,1,1,100,4*0,
58318 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
58319 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58320 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
58321 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
58322 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
58323 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
58324 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
58325 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
58326 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
58327 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
58328 &1,1,0,99,4*0, 2,1,0,99,4*0/
58329 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58330 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
58331
58332C...Length of character variable. Subdivide it into instructions.
58333 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
58334 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
58335 CHBIT=CHIN//' '
58336 LBIT=101
58337 100 LBIT=LBIT-1
58338 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
58339 LTOT=0
58340 DO 110 LCOM=1,LBIT
58341 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
58342 LTOT=LTOT+1
58343 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
58344 110 CONTINUE
58345 LLOW=0
58346 120 LHIG=LLOW+1
58347 130 LHIG=LHIG+1
58348 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
58349 LBIT=LHIG-LLOW-1
58350 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
58351
58352C...Send off decay-mode on/off commands to PYONOF.
58353 IONOF=0
58354 DO 135 LDIG=1,10
58355 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
58356 135 CONTINUE
58357 IF(IONOF.EQ.1) THEN
58358 CALL PYONOF(CHIN)
58359 RETURN
58360 ENDIF
58361
58362C...Peel off any text following exclamation mark.
58363 LHIG2=LBIT
58364 DO 140 LLOW2=LHIG2,1,-1
58365 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
58366 140 CONTINUE
58367 IF(LBIT.EQ.0) RETURN
58368
58369C...Identify commonblock variable.
58370 LNAM=1
58371 150 LNAM=LNAM+1
58372 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
58373 &LNAM.LE.6) GOTO 150
58374 CHNAM=CHBIT(1:LNAM-1)//' '
58375 DO 170 LCOM=1,LNAM-1
58376 DO 160 LALP=1,26
58377 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
58378 & CHALP(2)(LALP:LALP)
58379 160 CONTINUE
58380 170 CONTINUE
58381 IVAR=0
58382 DO 180 IV=1,54
58383 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
58384 180 CONTINUE
58385 IF(IVAR.EQ.0) THEN
58386 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
58387 LLOW=LHIG
58388 IF(LLOW.LT.LTOT) GOTO 120
58389 RETURN
58390 ENDIF
58391
58392C...Identify any indices.
58393 I1=0
58394 I2=0
58395 I3=0
58396 NINDX=0
58397 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
58398 LIND=LNAM
58399 190 LIND=LIND+1
58400 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
58401 CHIND=' '
58402 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
58403 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
58404 & IVAR.EQ.37)) THEN
58405 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
58406 READ(CHIND,'(I8)') KF
58407 I1=PYCOMP(KF)
58408 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
58409 & 'c') THEN
58410 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
58411 & CHNAM)
58412 LLOW=LHIG
58413 IF(LLOW.LT.LTOT) GOTO 120
58414 RETURN
58415 ELSE
58416 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58417 READ(CHIND,'(I8)') I1
58418 ENDIF
58419 LNAM=LIND
58420 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58421 NINDX=1
58422 ENDIF
58423 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58424 LIND=LNAM
58425 200 LIND=LIND+1
58426 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
58427 CHIND=' '
58428 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58429 READ(CHIND,'(I8)') I2
58430 LNAM=LIND
58431 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58432 NINDX=2
58433 ENDIF
58434 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58435 LIND=LNAM
58436 210 LIND=LIND+1
58437 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
58438 CHIND=' '
58439 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58440 READ(CHIND,'(I8)') I3
58441 LNAM=LIND+1
58442 NINDX=3
58443 ENDIF
58444
58445C...Check that indices allowed.
58446 IERR=0
58447 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
58448 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
58449 &IERR=2
58450 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
58451 &IERR=3
58452 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
58453 &IERR=4
58454 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
58455 IF(IERR.GE.1) THEN
58456 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
58457 & CHBIT(1:LNAM-1))
58458 LLOW=LHIG
58459 IF(LLOW.LT.LTOT) GOTO 120
58460 RETURN
58461 ENDIF
58462
58463C...Save old value of variable.
58464 IF(IVAR.EQ.1) THEN
58465 IOLD=N
58466 ELSEIF(IVAR.EQ.2) THEN
58467 IOLD=K(I1,I2)
58468 ELSEIF(IVAR.EQ.3) THEN
58469 ROLD=P(I1,I2)
58470 ELSEIF(IVAR.EQ.4) THEN
58471 ROLD=V(I1,I2)
58472 ELSEIF(IVAR.EQ.5) THEN
58473 IOLD=MSTU(I1)
58474 ELSEIF(IVAR.EQ.6) THEN
58475 ROLD=PARU(I1)
58476 ELSEIF(IVAR.EQ.7) THEN
58477 IOLD=MSTJ(I1)
58478 ELSEIF(IVAR.EQ.8) THEN
58479 ROLD=PARJ(I1)
58480 ELSEIF(IVAR.EQ.9) THEN
58481 IOLD=KCHG(I1,I2)
58482 ELSEIF(IVAR.EQ.10) THEN
58483 ROLD=PMAS(I1,I2)
58484 ELSEIF(IVAR.EQ.11) THEN
58485 ROLD=PARF(I1)
58486 ELSEIF(IVAR.EQ.12) THEN
58487 ROLD=VCKM(I1,I2)
58488 ELSEIF(IVAR.EQ.13) THEN
58489 IOLD=MDCY(I1,I2)
58490 ELSEIF(IVAR.EQ.14) THEN
58491 IOLD=MDME(I1,I2)
58492 ELSEIF(IVAR.EQ.15) THEN
58493 ROLD=BRAT(I1)
58494 ELSEIF(IVAR.EQ.16) THEN
58495 IOLD=KFDP(I1,I2)
58496 ELSEIF(IVAR.EQ.17) THEN
58497 CHOLD=CHAF(I1,I2)(1:8)
58498 ELSEIF(IVAR.EQ.18) THEN
58499 IOLD=MRPY(I1)
58500 ELSEIF(IVAR.EQ.19) THEN
58501 ROLD=RRPY(I1)
58502 ELSEIF(IVAR.EQ.20) THEN
58503 IOLD=MSEL
58504 ELSEIF(IVAR.EQ.21) THEN
58505 IOLD=MSUB(I1)
58506 ELSEIF(IVAR.EQ.22) THEN
58507 IOLD=KFIN(I1,I2)
58508 ELSEIF(IVAR.EQ.23) THEN
58509 ROLD=CKIN(I1)
58510 ELSEIF(IVAR.EQ.24) THEN
58511 IOLD=MSTP(I1)
58512 ELSEIF(IVAR.EQ.25) THEN
58513 ROLD=PARP(I1)
58514 ELSEIF(IVAR.EQ.26) THEN
58515 IOLD=MSTI(I1)
58516 ELSEIF(IVAR.EQ.27) THEN
58517 ROLD=PARI(I1)
58518 ELSEIF(IVAR.EQ.28) THEN
58519 IOLD=MINT(I1)
58520 ELSEIF(IVAR.EQ.29) THEN
58521 ROLD=VINT(I1)
58522 ELSEIF(IVAR.EQ.30) THEN
58523 IOLD=ISET(I1)
58524 ELSEIF(IVAR.EQ.31) THEN
58525 IOLD=KFPR(I1,I2)
58526 ELSEIF(IVAR.EQ.32) THEN
58527 ROLD=COEF(I1,I2)
58528 ELSEIF(IVAR.EQ.33) THEN
58529 IOLD=ICOL(I1,I2,I3)
58530 ELSEIF(IVAR.EQ.34) THEN
58531 ROLD=XSFX(I1,I2)
58532 ELSEIF(IVAR.EQ.35) THEN
58533 IOLD=ISIG(I1,I2)
58534 ELSEIF(IVAR.EQ.36) THEN
58535 ROLD=SIGH(I1)
58536 ELSEIF(IVAR.EQ.37) THEN
58537 IOLD=MWID(I1)
58538 ELSEIF(IVAR.EQ.38) THEN
58539 ROLD=WIDS(I1,I2)
58540 ELSEIF(IVAR.EQ.39) THEN
58541 IOLD=NGEN(I1,I2)
58542 ELSEIF(IVAR.EQ.40) THEN
58543 ROLD=XSEC(I1,I2)
58544 ELSEIF(IVAR.EQ.41) THEN
58545 CHOLD2=PROC(I1)
58546 ELSEIF(IVAR.EQ.42) THEN
58547 ROLD=SIGT(I1,I2,I3)
58548 ELSEIF(IVAR.EQ.43) THEN
58549 ROLD=XPVMD(I1)
58550 ELSEIF(IVAR.EQ.44) THEN
58551 ROLD=XPANL(I1)
58552 ELSEIF(IVAR.EQ.45) THEN
58553 ROLD=XPANH(I1)
58554 ELSEIF(IVAR.EQ.46) THEN
58555 ROLD=XPBEH(I1)
58556 ELSEIF(IVAR.EQ.47) THEN
58557 ROLD=XPDIR(I1)
58558 ELSEIF(IVAR.EQ.48) THEN
58559 IOLD=IMSS(I1)
58560 ELSEIF(IVAR.EQ.49) THEN
58561 ROLD=RMSS(I1)
58562 ELSEIF(IVAR.EQ.50) THEN
58563 ROLD=RVLAM(I1,I2,I3)
58564 ELSEIF(IVAR.EQ.51) THEN
58565 ROLD=RVLAMP(I1,I2,I3)
58566 ELSEIF(IVAR.EQ.52) THEN
58567 ROLD=RVLAMB(I1,I2,I3)
58568 ELSEIF(IVAR.EQ.53) THEN
58569 IOLD=ITCM(I1)
58570 ELSEIF(IVAR.EQ.54) THEN
58571 ROLD=RTCM(I1)
58572 ENDIF
58573
58574C...Print current value of variable. Loop back.
58575 IF(LNAM.GE.LBIT) THEN
58576 CHBIT(LNAM:14)=' '
58577 CHBIT(15:60)=' has the value '
58578 IF(MSVAR(IVAR,1).EQ.1) THEN
58579 WRITE(CHBIT(51:60),'(I10)') IOLD
58580 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58581 WRITE(CHBIT(47:60),'(F14.5)') ROLD
58582 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58583 CHBIT(53:60)=CHOLD
58584 ELSE
58585 CHBIT(33:60)=CHOLD
58586 ENDIF
58587 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58588 LLOW=LHIG
58589 IF(LLOW.LT.LTOT) GOTO 120
58590 RETURN
58591 ENDIF
58592
58593C...Read in new variable value.
58594 IF(MSVAR(IVAR,1).EQ.1) THEN
58595 CHINI=' '
58596 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
58597 READ(CHINI,'(I10)') INEW
58598 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58599 CHINR=' '
58600 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
58601 READ(CHINR,*) RNEW
58602 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58603 CHNEW=CHBIT(LNAM+1:LBIT)//' '
58604 ELSE
58605 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
58606 ENDIF
58607
58608C...Store new variable value.
58609 IF(IVAR.EQ.1) THEN
58610 N=INEW
58611 ELSEIF(IVAR.EQ.2) THEN
58612 K(I1,I2)=INEW
58613 ELSEIF(IVAR.EQ.3) THEN
58614 P(I1,I2)=RNEW
58615 ELSEIF(IVAR.EQ.4) THEN
58616 V(I1,I2)=RNEW
58617 ELSEIF(IVAR.EQ.5) THEN
58618 MSTU(I1)=INEW
58619 ELSEIF(IVAR.EQ.6) THEN
58620 PARU(I1)=RNEW
58621 ELSEIF(IVAR.EQ.7) THEN
58622 MSTJ(I1)=INEW
58623 ELSEIF(IVAR.EQ.8) THEN
58624 PARJ(I1)=RNEW
58625 ELSEIF(IVAR.EQ.9) THEN
58626 KCHG(I1,I2)=INEW
58627 ELSEIF(IVAR.EQ.10) THEN
58628 PMAS(I1,I2)=RNEW
58629 ELSEIF(IVAR.EQ.11) THEN
58630 PARF(I1)=RNEW
58631 ELSEIF(IVAR.EQ.12) THEN
58632 VCKM(I1,I2)=RNEW
58633 ELSEIF(IVAR.EQ.13) THEN
58634 MDCY(I1,I2)=INEW
58635 ELSEIF(IVAR.EQ.14) THEN
58636 MDME(I1,I2)=INEW
58637 ELSEIF(IVAR.EQ.15) THEN
58638 BRAT(I1)=RNEW
58639 ELSEIF(IVAR.EQ.16) THEN
58640 KFDP(I1,I2)=INEW
58641 ELSEIF(IVAR.EQ.17) THEN
58642 CHAF(I1,I2)=CHNEW
58643 ELSEIF(IVAR.EQ.18) THEN
58644 MRPY(I1)=INEW
58645 ELSEIF(IVAR.EQ.19) THEN
58646 RRPY(I1)=RNEW
58647 ELSEIF(IVAR.EQ.20) THEN
58648 MSEL=INEW
58649 ELSEIF(IVAR.EQ.21) THEN
58650 MSUB(I1)=INEW
58651 ELSEIF(IVAR.EQ.22) THEN
58652 KFIN(I1,I2)=INEW
58653 ELSEIF(IVAR.EQ.23) THEN
58654 CKIN(I1)=RNEW
58655 ELSEIF(IVAR.EQ.24) THEN
58656 MSTP(I1)=INEW
58657 ELSEIF(IVAR.EQ.25) THEN
58658 PARP(I1)=RNEW
58659 ELSEIF(IVAR.EQ.26) THEN
58660 MSTI(I1)=INEW
58661 ELSEIF(IVAR.EQ.27) THEN
58662 PARI(I1)=RNEW
58663 ELSEIF(IVAR.EQ.28) THEN
58664 MINT(I1)=INEW
58665 ELSEIF(IVAR.EQ.29) THEN
58666 VINT(I1)=RNEW
58667 ELSEIF(IVAR.EQ.30) THEN
58668 ISET(I1)=INEW
58669 ELSEIF(IVAR.EQ.31) THEN
58670 KFPR(I1,I2)=INEW
58671 ELSEIF(IVAR.EQ.32) THEN
58672 COEF(I1,I2)=RNEW
58673 ELSEIF(IVAR.EQ.33) THEN
58674 ICOL(I1,I2,I3)=INEW
58675 ELSEIF(IVAR.EQ.34) THEN
58676 XSFX(I1,I2)=RNEW
58677 ELSEIF(IVAR.EQ.35) THEN
58678 ISIG(I1,I2)=INEW
58679 ELSEIF(IVAR.EQ.36) THEN
58680 SIGH(I1)=RNEW
58681 ELSEIF(IVAR.EQ.37) THEN
58682 MWID(I1)=INEW
58683 ELSEIF(IVAR.EQ.38) THEN
58684 WIDS(I1,I2)=RNEW
58685 ELSEIF(IVAR.EQ.39) THEN
58686 NGEN(I1,I2)=INEW
58687 ELSEIF(IVAR.EQ.40) THEN
58688 XSEC(I1,I2)=RNEW
58689 ELSEIF(IVAR.EQ.41) THEN
58690 PROC(I1)=CHNEW2
58691 ELSEIF(IVAR.EQ.42) THEN
58692 SIGT(I1,I2,I3)=RNEW
58693 ELSEIF(IVAR.EQ.43) THEN
58694 XPVMD(I1)=RNEW
58695 ELSEIF(IVAR.EQ.44) THEN
58696 XPANL(I1)=RNEW
58697 ELSEIF(IVAR.EQ.45) THEN
58698 XPANH(I1)=RNEW
58699 ELSEIF(IVAR.EQ.46) THEN
58700 XPBEH(I1)=RNEW
58701 ELSEIF(IVAR.EQ.47) THEN
58702 XPDIR(I1)=RNEW
58703 ELSEIF(IVAR.EQ.48) THEN
58704 IMSS(I1)=INEW
58705 ELSEIF(IVAR.EQ.49) THEN
58706 RMSS(I1)=RNEW
58707 ELSEIF(IVAR.EQ.50) THEN
58708 RVLAM(I1,I2,I3)=RNEW
58709 ELSEIF(IVAR.EQ.51) THEN
58710 RVLAMP(I1,I2,I3)=RNEW
58711 ELSEIF(IVAR.EQ.52) THEN
58712 RVLAMB(I1,I2,I3)=RNEW
58713 ELSEIF(IVAR.EQ.53) THEN
58714 ITCM(I1)=INEW
58715 ELSEIF(IVAR.EQ.54) THEN
58716 RTCM(I1)=RNEW
58717 ENDIF
58718
58719C...Write old and new value. Loop back.
58720 CHBIT(LNAM:14)=' '
58721 CHBIT(15:60)=' changed from to '
58722 IF(MSVAR(IVAR,1).EQ.1) THEN
58723 WRITE(CHBIT(33:42),'(I10)') IOLD
58724 WRITE(CHBIT(51:60),'(I10)') INEW
58725 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58726 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58727 WRITE(CHBIT(29:42),'(F14.5)') ROLD
58728 WRITE(CHBIT(47:60),'(F14.5)') RNEW
58729 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58730 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58731 CHBIT(35:42)=CHOLD
58732 CHBIT(53:60)=CHNEW
58733 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58734 ELSE
58735 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
58736 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
58737 ENDIF
58738 LLOW=LHIG
58739 IF(LLOW.LT.LTOT) GOTO 120
58740
58741C...Format statement for output on unit MSTU(11) (by default 6).
58742 5000 FORMAT(5X,A60)
58743 5100 FORMAT(5X,A88)
58744
58745 RETURN
58746 END
58747
58748C*********************************************************************
58749
58750C...PYONOF
58751C...Switches on and off decay channel by search for match.
58752
58753 SUBROUTINE PYONOF(CHIN)
58754
58755C...Double precision and integer declarations.
58756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58757 IMPLICIT INTEGER(I-N)
58758 INTEGER PYK,PYCHGE,PYCOMP
58759C...Commonblocks.
58760 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58761 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58762 SAVE /PYDAT1/,/PYDAT3/
58763C...Local arrays and character variables.
58764 INTEGER KFCMP(10),KFTMP(10)
58765 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
58766 &CHALP(2)*26
58767 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58768 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
58769
58770C...Determine length of character variable.
58771 CHTMP=CHIN//' '
58772 LBEG=0
58773 100 LBEG=LBEG+1
58774 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
58775 LEND=LBEG-1
58776 105 LEND=LEND+1
58777 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
58778 110 LEND=LEND-1
58779 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
58780 LEN=1+LEND-LBEG
58781 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
58782
58783C...Find colon separator and particle code.
58784 LCOLON=0
58785 120 LCOLON=LCOLON+1
58786 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
58787 CHCODE=' '
58788 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
58789 READ(CHCODE,'(I8)',ERR=300) KF
58790 KC=PYCOMP(KF)
58791
58792C...Done if unknown code or no decay channels.
58793 IF(KC.EQ.0) THEN
58794 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
58795 RETURN
58796 ENDIF
58797 IDCBEG=MDCY(KC,2)
58798 IDCLEN=MDCY(KC,3)
58799 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
58800 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
58801 RETURN
58802 ENDIF
58803
58804C...Find command name up to blank or equal sign.
58805 LSEP=LCOLON
58806 130 LSEP=LSEP+1
58807 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
58808 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
58809 CHMODE=' '
58810 LMODE=LSEP-LCOLON-1
58811 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
58812
58813C...Convert to uppercase.
58814 DO 150 LCOM=1,LMODE
58815 DO 140 LALP=1,26
58816 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
58817 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
58818 140 CONTINUE
58819 150 CONTINUE
58820
58821C...Identify command. Failed if not identified.
58822 MODE=0
58823 IF(CHMODE.EQ.'ALLOFF') MODE=1
58824 IF(CHMODE.EQ.'ALLON') MODE=2
58825 IF(CHMODE.EQ.'OFFIFANY') MODE=3
58826 IF(CHMODE.EQ.'ONIFANY') MODE=4
58827 IF(CHMODE.EQ.'OFFIFALL') MODE=5
58828 IF(CHMODE.EQ.'ONIFALL') MODE=6
58829 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
58830 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
58831 IF(MODE.EQ.0) THEN
58832 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
58833 RETURN
58834 ENDIF
58835
58836C...Simple cases when all on or all off.
58837 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
58838 WRITE(MSTU(11),1000) KF,CHMODE
58839 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
58840 IF(MDME(IDC,1).LT.0) GOTO 160
58841 MDME(IDC,1)=MODE-1
58842 160 CONTINUE
58843 RETURN
58844 ENDIF
58845
58846C...Identify matching list.
58847 NCMP=0
58848 LBEG=LSEP
58849 170 LBEG=LBEG+1
58850 IF(LBEG.GT.LEN) GOTO 190
58851 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
58852 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
58853 LEND=LBEG-1
58854 180 LEND=LEND+1
58855 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
58856 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
58857 IF(LEND.LT.LEN) LEND=LEND-1
58858 CHCODE=' '
58859 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
58860 READ(CHCODE,'(I8)',ERR=300) KFREAD
58861 NCMP=NCMP+1
58862 KFCMP(NCMP)=IABS(KFREAD)
58863 LBEG=LEND
58864 IF(NCMP.LT.10) GOTO 170
58865 190 CONTINUE
58866 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
58867
58868C...Only one matching required.
58869 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
58870 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
58871 IF(MDME(IDC,1).LT.0) GOTO 220
58872 DO 210 IKF=1,5
58873 KFNOW=IABS(KFDP(IDC,IKF))
58874 IF(KFNOW.EQ.0) GOTO 210
58875 DO 200 ICMP=1,NCMP
58876 IF(KFCMP(ICMP).EQ.KFNOW) THEN
58877 MDME(IDC,1)=MODE-3
58878 GOTO 220
58879 ENDIF
58880 200 CONTINUE
58881 210 CONTINUE
58882 220 CONTINUE
58883 RETURN
58884 ENDIF
58885
58886C...Multiple matchings required.
58887 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
58888 IF(MDME(IDC,1).LT.0) GOTO 260
58889 NTMP=NCMP
58890 DO 230 ITMP=1,NTMP
58891 KFTMP(ITMP)=KFCMP(ITMP)
58892 230 CONTINUE
58893 NFIN=0
58894 DO 250 IKF=1,5
58895 KFNOW=IABS(KFDP(IDC,IKF))
58896 IF(KFNOW.EQ.0) GOTO 250
58897 NFIN=NFIN+1
58898 DO 240 ITMP=1,NTMP
58899 IF(KFTMP(ITMP).EQ.KFNOW) THEN
58900 KFTMP(ITMP)=KFTMP(NTMP)
58901 NTMP=NTMP-1
58902 GOTO 250
58903 ENDIF
58904 240 CONTINUE
58905 250 CONTINUE
58906 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
58907 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
58908 & MDME(IDC,1)=MODE-7
58909 260 CONTINUE
58910 RETURN
58911
58912C...Error exit for impossible read of particle code.
58913 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
58914 &//CHCODE)
58915
58916C...Formats for output.
58917 1000 FORMAT(' Decays for',I8,' set ',A10)
58918 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
58919
58920 RETURN
58921 END
58922C*********************************************************************
58923
58924C...PYTUNE
58925C...Presets for a few specific underlying-event and min-bias tunes
58926C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
58927C...others require particular versions of pythia (e.g. the SCI and GAL
58928C...models). See below for details.
58929 SUBROUTINE PYTUNE(ITUNE)
58930C
58931C ITUNE NAME (detailed descriptions below)
58932C 0 Default : No settings changed => linked Pythia version's defaults.
58933C ====== Old UE, Q2-ordered showers ==========================================
58934C 100 A : Rick Field's CDF Tune A
58935C 101 AW : Rick Field's CDF Tune AW
58936C 102 BW : Rick Field's CDF Tune BW
58937C 103 DW : Rick Field's CDF Tune DW
58938C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling
58939C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally)
58940C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome)
58941C 107 ACR : Tune A modified with annealing CR
58942C 108 D6 : Rick Field's CDF Tune D6 (NB: needs CTEQ6L pdfs externally)
58943C 109 D6T : Rick Field's CDF Tune D6T (NB: needs CTEQ6L pdfs externally)
58944C ====== Intermediate Models =================================================
58945C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
58946C 201 APT : Tune A modified to use pT-ordered final-state showers
58947C ====== New UE, interleaved pT-ordered showers, annealing CR ================
58948C 300 S0 : Sandhoff-Skands Tune 0
58949C 301 S1 : Sandhoff-Skands Tune 1
58950C 302 S2 : Sandhoff-Skands Tune 2
58951C 303 S0A : S0 with "Tune A" UE energy scaling
58952C 304 NOCR : New UE "best try" without colour reconnections
58953C 305 Old : New UE, original (primitive) colour reconnections
58954C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune (needs CTEQ6L externally)
58955C ======= The Uppsala models =================================================
58956C ( NB! must be run with special modified Pythia 6.215 version )
58957C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
58958C 400 GAL 0 : Generalized area-law model. Old parameters
58959C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters
58960C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands)
58961C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands)
58962C
58963C More details;
58964C
58965C Quick Dictionary:
58966C BE : Bose-Einstein
58967C BR : Beam Remnants
58968C CR : Colour Reconnections
58969C HAD: Hadronization
58970C ISR/FSR: Initial-State Radiation / Final-State Radiation
58971C FSI: Final-State Interactions (=CR+BE)
58972C MB : Minimum-bias
58973C MI : Multiple Interactions
58974C UE : Underlying Event
58975C
58976C A (100) and AW (101). Old UE model, Q2-ordered showers.
58977C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58978C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58979C...Key feature: extensively compared to CDF data (R.D. Field).
58980C...* Large starting scale for ISR (PARP(67)=4)
58981C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
58982C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58983C
58984C BW (102). Old UE model, Q2-ordered showers.
58985C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58986C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58987C...Key feature: extensively compared to CDF data (R.D. Field).
58988C...NB: Can also be run with Pythia 6.2 or 6.312+
58989C...* Small starting scale for ISR (PARP(67)=1)
58990C...* BW has more radiation due to smaller mu_R choice in alpha_s.
58991C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58992C
58993C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
58994C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58995C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58996C...Key feature: extensively compared to CDF data (R.D. Field).
58997C...NB: Can also be run with Pythia 6.2 or 6.312+
58998C...* Intermediate starting scale for ISR (PARP(67)=2.5)
58999C...* DWT has a different reference energy, the same as the "S" models
59000C... below, leading to more UE activity at the LHC, but less at RHIC.
59001C...* See: http://www.phys.ufl.edu/~rfield/cdf/
59002C
59003C QW (105). Old UE model, Q2-ordered showers.
59004C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
59005C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
59006C...Key feature: uses CTEQ61 (external pdf library must be linked)
59007C
59008C ATLAS-DC2 (106). Old UE model, Q2-ordered showers.
59009C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
59010C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
59011C...Key feature: tune used by the ATLAS collaboration.
59012C
59013C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
59014C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
59015C...Key feature: Tune A modified to use annealing CR.
59016C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
59017C
59018C D6 (108) and D6T (109). Old UE model, Q2-ordered showers, CTEQ6L PDF.
59019C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
59020C
59021C...IM1 (200). Intermediate model, Q2-ordered showers.
59022C...Key feature: new UE model with Q2-ordered showers and no interleaving.
59023C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
59024C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
59025C
59026C...APT (201). Old UE model, pT-ordered final-state showers
59027C...Key feature: Rick Field's Tune A, but with new final-state showers
59028C
59029C S0 (300) and S0A (303). New UE model, pT-ordered showers.
59030C...Key feature: large amount of multiple interactions
59031C...* Somewhat faster than the other colour annealing scenarios.
59032C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
59033C... from Tune A, leading to less UE at the LHC, but more at RHIC.
59034C...* Small amount of radiation.
59035C...* Large amount of low-pT MI
59036C...* Low degree of proton lumpiness (broad matter dist.)
59037C...* CR Type S (driven by free triplets), of medium strength.
59038C...* See: Pythia6402 update notes or later.
59039C
59040C S1 (301). New UE model, pT-ordered showers.
59041C...Key feature: large amount of radiation.
59042C...* Large amount of low-pT perturbative ISR
59043C...* Large amount of FSR off ISR partons
59044C...* Small amount of low-pT multiple interactions
59045C...* Moderate degree of proton lumpiness
59046C...* Least aggressive CR type (S+S Type I), but with large strength
59047C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59048C
59049C S2 (302). New UE model, pT-ordered showers.
59050C...Key feature: very lumpy proton + gg string cluster formation allowed
59051C...* Small amount of radiation
59052C...* Moderate amount of low-pT MI
59053C...* High degree of proton lumpiness (more spiky matter distribution)
59054C...* Most aggressive CR type (S+S Type II), but with small strength
59055C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59056C
59057C NOCR (304). New UE model, pT-ordered showers.
59058C...Key feature: no colour reconnections (NB: "Best fit" only).
59059C...* NB: <pT>(Nch) problematic in this tune.
59060C...* Small amount of radiation
59061C...* Small amount of low-pT MI
59062C...* Low degree of proton lumpiness
59063C...* Large BR composite x enhancement factor
59064C...* Most clever colour flow without CR ("Lambda ordering")
59065C
59066C ATLAS-CSC (306). New UE mode, pT-ordered showers, CTEQ6L.
59067C...Key feature: 11-parameter ATLAS tune of the new framework.
59068C...* Old (pre-annealing) colour reconnections a la 305.
59069C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
59070C
59071C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
59072C...with an unmodified Pythia distribution.
59073C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
59074C
59075C ::: + Future improvements?
59076C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
59077C (problem: K-factor affects everything so only works as
59078C intended for min-bias, not for UE ... probably need a
59079C better long-term solution to handle UE as well. Anyway,
59080C Mark uses MSTP(33) and PARP(31)-PARP(33).)
59081
59082C...Global statements
59083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59084 INTEGER PYK,PYCHGE,PYCOMP
59085
59086C...Commonblocks.
59087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59089
59090C...SCI and GAL Commonblocks
59091 COMMON /SCIPAR/MSWI(2),PARSCI(2)
59092
59093C...Internal parameters
59094 PARAMETER(MXTUNS=500)
59095 CHARACTER*8 CHVERS, CHDOC
59096 PARAMETER (CHVERS='1.012 ',CHDOC='Sep 2007')
59097 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
59098 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
59099 & CHPARJ(41:100), CH40
59100 CHARACTER*60 CH60
59101 CHARACTER*70 CH70
59102 DATA (CHNAMS(I),I=0,1)/'Default',' '/
59103 DATA (CHNAMS(I),I=100,110)/
59104 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
59105 & 'ATLAS Tune','Tune ACR','Tune D6','Tune D6T',' '/
59106 DATA (CHNAMS(I),I=300,310)/
59107 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
59108 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',2*' '/
59109 DATA (CHNAMS(I),I=200,210)/
59110 & 'IM Tune 1','Tune APT',9*' '/
59111 DATA (CHNAMS(I),I=400,410)/
59112 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
59113 DATA (CHMSTJ(I),I=11,20)/
59114 & 'HAD choice of fragmentation function(s)',4*' ',
59115 & 'HAD treatment of small-mass systems',4*' '/
59116 DATA (CHMSTJ(I),I=41,50)/
59117 & 'FSR type (Q2 or pT) for old framework',9*' '/
59118 DATA (CHMSTP(I),I=51,100)/
59119 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
59120 6 'ISR master switch',6*' ',
59121 6 'ISR phase space choice & ME corrections',' ',
59122 7 'ISR IR regularization scheme',' ',
59123 7 'ISR scheme for FSR off ISR',8*' ',
59124 8 'UE model',
59125 8 'UE hadron transverse mass distribution',5*' ',
59126 8 'BR composite scheme','BR colour scheme',
59127 9 'BR primordial kT compensation',
59128 9 'BR primordial kT distribution',
59129 9 'BR energy partitioning scheme',2*' ',
59130 9 'FSI colour (re-)connection model',5*' '/
59131 DATA (CHPARP(I),I=61,100)/
59132 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
59133 6 2*' ','ISR Q2max factor',3*' ',
59134 7 'FSR Q2max factor for non-s-channel procs',5*' ',
59135 7 'FSI colour reconnection turnoff scale',
59136 7 'FSI colour reconnection strength',
59137 7 'BR composite x enhancement','BR breakup suppression',
59138 8 2*'UE IR cutoff at reference ecm',
59139 8 2*'UE mass distribution parameter',
59140 8 'UE gg colour correlated fraction','UE total gg fraction',
59141 8 2*' ',
59142 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
59143 9 'BR primordial kT width <|kT|>',' ',
59144 9 'BR primordial kT UV cutoff',7*' '/
59145 DATA (CHPARJ(I),I=41,90)/
59146 4 ' ','HAD string parameter b',8*' ',
59147 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
59148 6 10*' ',10*' ',
59149 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
59150 SAVE /PYDAT1/,/PYPARS/
59151 SAVE /SCIPAR/
59152
59153C...1) Shorthand notation
59154 M13=MSTU(13)
59155 M11=MSTU(11)
59156 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
59157 CHNAME=CHNAMS(ITUNE)
59158 IF (ITUNE.EQ.0) GOTO 9999
59159 ELSE
59160 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
59161 GOTO 9999
59162 ENDIF
59163
59164C...2) Hello World
59165 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
59166
59167C...3) Tune parameters
59168
59169C=============================================================================
59170C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
59171 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
59172 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59173 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59174 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59175 & ' with tune.')
59176 ENDIF
59177
59178C...PDFs
59179 MSTP(52)=1
59180 MSTP(51)=7
59181C...ISR
59182 PARP(64)=1D0
59183C...UE on, new model.
59184 MSTP(81)=21
59185C...Slow IR cutoff energy scaling by default
59186 PARP(89)=1800D0
59187 PARP(90)=0.16D0
59188C...Switch off trial joinings
59189 MSTP(96)=0
59190C...Primordial kT cutoff
59191 PARP(93)=5D0
59192
59193C...S0 (300), S0A (303)
59194 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
59195 IF (M13.GE.1) THEN
59196 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59197 WRITE(M11,5030) CH60
59198 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
59199 WRITE(M11,5030) CH60
59200 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59201 WRITE(M11,5030) CH60
59202 ENDIF
59203C...Smooth ISR, low FSR
59204 MSTP(70)=2
59205 MSTP(72)=0
59206C...pT0
59207 PARP(82)=1.85D0
59208C...Transverse density profile.
59209 MSTP(82)=5
59210 PARP(83)=1.6D0
59211C...Colour Reconnections
59212 MSTP(95)=6
59213 PARP(78)=0.20D0
59214 PARP(77)=0.0D0
59215C... Reference energy for pT0 and energy scaling pace.
59216 IF (ITUNE.EQ.303) PARP(90)=0.25D0
59217C...Lambda_FSR scale.
59218 PARJ(81)=0.23D0
59219C...FSR activity.
59220 PARP(71)=4D0
59221C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59222 MSTP(89)=1
59223 MSTP(88)=0
59224 PARP(79)=2D0
59225 PARP(80)=0.01D0
59226
59227C...S1 (301)
59228 ELSEIF(ITUNE.EQ.301) THEN
59229 IF (M13.GE.1) THEN
59230 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59231 WRITE(M11,5030) CH60
59232 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59233 WRITE(M11,5030) CH60
59234 ENDIF
59235C...Sharp ISR, high FSR
59236 MSTP(70)=0
59237 MSTP(72)=1
59238C...pT0
59239 PARP(82)=2.1D0
59240C...Colour Reconnections
59241 MSTP(95)=2
59242 PARP(78)=0.35D0
59243C...Transverse density profile.
59244 MSTP(82)=5
59245 PARP(83)=1.4D0
59246C...Lambda_FSR scale.
59247 PARJ(81)=0.23D0
59248C...FSR activity.
59249 PARP(71)=4D0
59250C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59251 MSTP(89)=1
59252 MSTP(88)=0
59253 PARP(79)=2D0
59254 PARP(80)=0.01D0
59255
59256C...S2 (302)
59257 ELSEIF(ITUNE.EQ.302) THEN
59258 IF (M13.GE.1) THEN
59259 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59260 WRITE(M11,5030) CH60
59261 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59262 WRITE(M11,5030) CH60
59263 ENDIF
59264C...Smooth ISR, low FSR
59265 MSTP(70)=2
59266 MSTP(72)=0
59267C...pT0
59268 PARP(82)=1.9D0
59269C...Transverse density profile.
59270 MSTP(82)=5
59271 PARP(83)=1.2D0
59272C...Colour Reconnections
59273 MSTP(95)=4
59274 PARP(78)=0.15D0
59275C...Lambda_FSR scale.
59276 PARJ(81)=0.23D0
59277C...FSR activity.
59278 PARP(71)=4D0
59279C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59280 MSTP(89)=1
59281 MSTP(88)=0
59282 PARP(79)=2D0
59283 PARP(80)=0.01D0
59284
59285C...NOCR (304)
59286 ELSEIF(ITUNE.EQ.304) THEN
59287 IF (M13.GE.1) THEN
59288 CH60='"best try" without colour reconnections'
59289 WRITE(M11,5030) CH60
59290 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59291 WRITE(M11,5030) CH60
59292 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59293 WRITE(M11,5030) CH60
59294 ENDIF
59295C...Smooth ISR, low FSR
59296 MSTP(70)=2
59297 MSTP(72)=0
59298C...pT0
59299 PARP(82)=2.05D0
59300C...Transverse density profile.
59301 MSTP(82)=5
59302 PARP(83)=1.8D0
59303C...Colour Reconnections
59304 MSTP(95)=0
59305C...Lambda_FSR scale.
59306 PARJ(81)=0.23D0
59307C...FSR activity.
59308 PARP(71)=4D0
59309C...Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
59310 MSTP(89)=2
59311 MSTP(88)=0
59312 PARP(79)=3D0
59313 PARP(80)=0.01D0
59314
59315C..."Lo FSR" retune (305)
59316 ELSEIF(ITUNE.EQ.305) THEN
59317 IF (M13.GE.1) THEN
59318 CH60='"Lo FSR retune" with primitive colour reconnections'
59319 WRITE(M11,5030) CH60
59320 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
59321 WRITE(M11,5030) CH60
59322 ENDIF
59323C...Smooth ISR, low FSR
59324 MSTP(70)=2
59325 MSTP(72)=0
59326C...pT0
59327 PARP(82)=1.9D0
59328C...Transverse density profile.
59329 MSTP(82)=5
59330 PARP(83)=2.0D0
59331C...Colour Reconnections
59332 MSTP(95)=1
59333 PARP(78)=1.0D0
59334C...Lambda_FSR scale.
59335 PARJ(81)=0.23D0
59336C...FSR activity.
59337 PARP(71)=4D0
59338C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59339 MSTP(89)=1
59340 MSTP(88)=0
59341 PARP(79)=2D0
59342 PARP(80)=0.01D0
59343 ENDIF
59344C...Output
59345 IF (M13.GE.1) THEN
59346 WRITE(M11,5030) ' '
59347 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59348 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59349 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59350 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59351 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59352 WRITE(M11,5030) CH60
59353 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59354 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59355 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59356 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59357 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59358 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59359 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59360 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59361 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59362 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59363 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59364 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59365 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59366 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59367 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59368 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59369 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59370 ENDIF
59371
59372C=============================================================================
59373C...ATLAS-CSC 11-parameter tune (By A. Moraes)
59374 ELSEIF (ITUNE.EQ.306) THEN
59375 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59376 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59377 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59378 & ' with tune.')
59379 ENDIF
59380
59381C...PDFs
59382 MSTP(52)=2
59383 MSTP(54)=2
59384 MSTP(56)=2
59385 MSTP(51)=10042
59386 MSTP(53)=10042
59387 MSTP(55)=10042
59388C...ISR
59389C PARP(64)=1D0
59390C...UE on, new model.
59391 MSTP(81)=21
59392C...Energy scaling
59393 PARP(89)=1800D0
59394 PARP(90)=0.22D0
59395C...Switch off trial joinings
59396 MSTP(96)=0
59397C...Primordial kT cutoff
59398
59399 IF (M13.GE.1) THEN
59400 CH60='see presentations by A. Moraes (ATLAS),'
59401 WRITE(M11,5030) CH60
59402 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59403 WRITE(M11,5030) CH60
59404 WRITE(M11,5030) ' '
59405 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59406 & 'externally linked and'
59407 WRITE(M11,5035) CH70
59408 CH70='MSTP(51) should be set manually according to '//
59409 & 'the library used'
59410 WRITE(M11,5035) CH70
59411 ENDIF
59412C...Smooth ISR, low FSR
59413 MSTP(70)=2
59414 MSTP(72)=0
59415C...pT0
59416 PARP(82)=1.9D0
59417C...Transverse density profile.
59418 MSTP(82)=4
59419 PARP(83)=0.3D0
59420 PARP(84)=0.5D0
59421C...ISR & FSR in interactions after the first (default)
59422 MSTP(84)=1
59423 MSTP(85)=1
59424C...No double-counting (default)
59425 MSTP(86)=2
59426C...Companion quark parent gluon (1-x) power
59427 MSTP(87)=4
59428C...Primordial kT compensation along chaings (default = 0 : uniform)
59429 MSTP(90)=1
59430C...Colour Reconnections
59431 MSTP(95)=1
59432 PARP(78)=0.2D0
59433C...Lambda_FSR scale.
59434 PARJ(81)=0.23D0
59435C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59436 MSTP(89)=1
59437 MSTP(88)=0
59438C PARP(79)=2D0
59439 PARP(80)=0.01D0
59440C...Peterson charm frag, and c and b hadr parameters
59441 MSTJ(11)=3
59442 PARJ(54)=-0.07
59443 PARJ(55)=-0.006
59444C... Output
59445 IF (M13.GE.1) THEN
59446 WRITE(M11,5030) ' '
59447 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59448 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59449 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59450 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59451 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59452 WRITE(M11,5030) CH60
59453 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59454 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59455 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59456 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59457 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
59458 WRITE(M11,5030) CH60
59459 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59460 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59461 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59462 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59463 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59464 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59465 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59466 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59467 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59468 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
59469 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59470 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59471 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59472 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59473 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59474 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59475 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59476 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59477 ENDIF
59478
59479C=============================================================================
59480C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
59481C...(100-105,108-109) and ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
59482 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
59483 & ITUNE.EQ.109) THEN
59484 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
59485 WRITE(M11,5010) ITUNE, CHNAME
59486 CH60='see R.D. Field (CDF), in hep-ph/0610012'
59487 WRITE(M11,5030) CH60
59488 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59489 WRITE(M11,5030) CH60
59490 ENDIF
59491C...Multiple interactions on, old framework
59492 MSTP(81)=1
59493C...Fast IR cutoff energy scaling by default
59494 PARP(89)=1800D0
59495 PARP(90)=0.25D0
59496C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
59497 MSTP(51)=7
59498 MSTP(52)=1
59499 IF (ITUNE.EQ.105) THEN
59500 MSTP(51)=10150
59501 MSTP(52)=2
59502 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59503 MSTP(52)=2
59504 MSTP(54)=2
59505 MSTP(56)=2
59506 MSTP(51)=10042
59507 MSTP(53)=10042
59508 MSTP(55)=10042
59509 ENDIF
59510C...Double Gaussian matter distribution.
59511 MSTP(82)=4
59512 PARP(83)=0.5D0
59513 PARP(84)=0.4D0
59514C...FSR activity.
59515 PARP(71)=4D0
59516C...Lambda_FSR scale.
59517 PARJ(81)=0.29D0
59518C...Fragmentation functions and c and b parameters
59519 MSTJ(11)=4
59520 PARJ(54)=-0.05
59521 PARJ(55)=-0.005
59522
59523C...Tune A and AW
59524 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
59525C...pT0.
59526 PARP(82)=2.0D0
59527c...String drawing almost completely minimizes string length.
59528 PARP(85)=0.9D0
59529 PARP(86)=0.95D0
59530C...ISR cutoff, muR scale factor, and phase space size
59531 PARP(62)=1D0
59532 PARP(64)=1D0
59533 PARP(67)=4D0
59534C...Intrinsic kT, size, and max
59535 MSTP(91)=1
59536 PARP(91)=1D0
59537 PARP(93)=5D0
59538C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
59539 IF (ITUNE.EQ.101) THEN
59540 PARP(62)=1.25D0
59541 PARP(64)=0.2D0
59542 PARP(91)=2.1D0
59543 PARP(92)=15.0D0
59544 ENDIF
59545
59546C...Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
59547 ELSEIF (ITUNE.EQ.102) THEN
59548C...pT0.
59549 PARP(82)=1.9D0
59550c...String drawing completely minimizes string length.
59551 PARP(85)=1.0D0
59552 PARP(86)=1.0D0
59553C...ISR cutoff, muR scale factor, and phase space size
59554 PARP(62)=1.25D0
59555 PARP(64)=0.2D0
59556 PARP(67)=1D0
59557C...Intrinsic kT, size, and max
59558 MSTP(91)=1
59559 PARP(91)=2.1D0
59560 PARP(93)=15D0
59561
59562C...Tune DW
59563 ELSEIF (ITUNE.EQ.103) THEN
59564C...pT0.
59565 PARP(82)=1.9D0
59566c...String drawing completely minimizes string length.
59567 PARP(85)=1.0D0
59568 PARP(86)=1.0D0
59569C...ISR cutoff, muR scale factor, and phase space size
59570 PARP(62)=1.25D0
59571 PARP(64)=0.2D0
59572 PARP(67)=2.5D0
59573C...Intrinsic kT, size, and max
59574 MSTP(91)=1
59575 PARP(91)=2.1D0
59576 PARP(93)=15D0
59577
59578C...Tune DWT
59579 ELSEIF (ITUNE.EQ.104) THEN
59580C...pT0.
59581 PARP(82)=1.9409D0
59582C...Run II ref scale and slow scaling
59583 PARP(89)=1960D0
59584 PARP(90)=0.16D0
59585c...String drawing completely minimizes string length.
59586 PARP(85)=1.0D0
59587 PARP(86)=1.0D0
59588C...ISR cutoff, muR scale factor, and phase space size
59589 PARP(62)=1.25D0
59590 PARP(64)=0.2D0
59591 PARP(67)=2.5D0
59592C...Intrinsic kT, size, and max
59593 MSTP(91)=1
59594 PARP(91)=2.1D0
59595 PARP(93)=15D0
59596
59597C...Tune QW
59598 ELSEIF(ITUNE.EQ.105) THEN
59599 IF (M13.GE.1) THEN
59600 WRITE(M11,5030) ' '
59601 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59602 & 'externally linked and'
59603 WRITE(M11,5035) CH70
59604 CH70='MSTP(51) should be set manually according to '//
59605 & 'the library used'
59606 WRITE(M11,5035) CH70
59607 ENDIF
59608C...pT0.
59609 PARP(82)=1.1D0
59610c...String drawing completely minimizes string length.
59611 PARP(85)=1.0D0
59612 PARP(86)=1.0D0
59613C...ISR cutoff, muR scale factor, and phase space size
59614 PARP(62)=1.25D0
59615 PARP(64)=0.2D0
59616 PARP(67)=2.5D0
59617C...Intrinsic kT, size, and max
59618 MSTP(91)=1
59619 PARP(91)=2.1D0
59620 PARP(93)=15D0
59621
59622C...Tune D6 and D6T
59623 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59624 IF (M13.GE.1) THEN
59625 WRITE(M11,5030) ' '
59626 CH70='NB! This tune requires CTEQ6L pdfs to be '//
59627 & 'externally linked and'
59628 WRITE(M11,5035) CH70
59629 CH70='MSTP(51) should be set manually according to '//
59630 & 'the library used'
59631 WRITE(M11,5035) CH70
59632 ENDIF
59633C...The "Rick" proton, double gauss with 0.5/0.4
59634 MSTP(82)=4
59635 PARP(83)=0.5D0
59636 PARP(84)=0.4D0
59637c...String drawing completely minimizes string length.
59638 PARP(85)=1.0D0
59639 PARP(86)=1.0D0
59640 IF (ITUNE.EQ.108) THEN
59641C...D6: pT0, Run I ref scale, and fast energy scaling
59642 PARP(82)=1.8D0
59643 PARP(89)=1800D0
59644 PARP(90)=0.25D0
59645 ELSE
59646C...D6T: pT0, Run II ref scale, and slow energy scaling
59647 PARP(82)=1.8387D0
59648 PARP(89)=1960D0
59649 PARP(90)=0.16D0
59650 ENDIF
59651C...ISR cutoff, muR scale factor, and phase space size
59652 PARP(62)=1.25D0
59653 PARP(64)=0.2D0
59654 PARP(67)=2.5D0
59655C...Intrinsic kT, size, and max
59656 MSTP(91)=1
59657 PARP(91)=2.1D0
59658 PARP(93)=15D0
59659
59660C...Old ATLAS-DC2 5-parameter tune
59661 ELSEIF(ITUNE.EQ.106) THEN
59662 IF (M13.GE.1) THEN
59663 WRITE(M11,5010) ITUNE, CHNAME
59664 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
59665 WRITE(M11,5030) CH60
59666 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59667 WRITE(M11,5030) CH60
59668 ENDIF
59669C... pT0.
59670 PARP(82)=1.8D0
59671C... Different ref and rescaling pacee
59672 PARP(89)=1000D0
59673 PARP(90)=0.16D0
59674C... Parameters of mass distribution
59675 PARP(83)=0.5D0
59676 PARP(84)=0.5D0
59677C... Old default string drawing
59678 PARP(85)=0.33D0
59679 PARP(86)=0.66D0
59680C... ISR, phase space equivalent to Tune B
59681 PARP(62)=1D0
59682 PARP(64)=1D0
59683 PARP(67)=1D0
59684C... FSR
59685 PARP(71)=4D0
59686 PARJ(81)=0.29D0
59687C... Intrinsic kT
59688 MSTP(91)=1
59689 PARP(91)=1D0
59690 PARP(93)=5D0
59691 ENDIF
59692
59693C... Output
59694 IF (M13.GE.1) THEN
59695 WRITE(M11,5030) ' '
59696 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59697 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59698 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59699 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59700 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59701 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59702 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59703 WRITE(M11,5030) CH60
59704 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59705 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59706 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59707 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59708 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59709 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59710 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59711 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59712 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59713 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59714 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59715 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59716 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59717 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59718 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59719 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59720 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59721 ENDIF
59722
59723C=============================================================================
59724C... ACR, tune A with new CR (107)
59725 ELSEIF(ITUNE.EQ.107) THEN
59726 IF (M13.GE.1) THEN
59727 WRITE(M11,5010) ITUNE, CHNAME
59728 CH60='Tune A modified with new colour reconnections'
59729 WRITE(M11,5030) CH60
59730 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
59731 WRITE(M11,5030) CH60
59732 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
59733 WRITE(M11,5030) CH60
59734 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59735 WRITE(M11,5030) CH60
59736 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59737 WRITE(M11,5030) CH60
59738 ENDIF
59739 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
59740 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59741 & ' with tune. Using defaults.')
59742 GOTO 9998
59743 ENDIF
59744 MSTP(81)=1
59745 PARP(89)=1800D0
59746 PARP(90)=0.25D0
59747 MSTP(82)=4
59748 PARP(83)=0.5D0
59749 PARP(84)=0.4D0
59750 MSTP(51)=7
59751 MSTP(52)=1
59752 PARP(71)=4D0
59753 PARJ(81)=0.29D0
59754 PARP(82)=2.0D0
59755 PARP(85)=0.0D0
59756 PARP(86)=0.66D0
59757 PARP(62)=1D0
59758 PARP(64)=1D0
59759 PARP(67)=4D0
59760 MSTP(91)=1
59761 PARP(91)=1D0
59762 PARP(93)=5D0
59763 MSTP(95)=6
59764 PARP(78)=0.25D0
59765C...Fragmentation functions and c and b parameters
59766 MSTJ(11)=4
59767 PARJ(54)=-0.05
59768 PARJ(55)=-0.005
59769C...Output
59770 IF (M13.GE.1) THEN
59771 WRITE(M11,5030) ' '
59772 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59773 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59774 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59775 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59776 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59777 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59778 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59779 WRITE(M11,5030) CH60
59780 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59781 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59782 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59783 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59784 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59785 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59786 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59787 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59788 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59789 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59790 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59791 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59792 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59793 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59794 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59795 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59796 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59797 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59798 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59799 ENDIF
59800
59801C=============================================================================
59802C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
59803 ELSEIF(ITUNE.EQ.200) THEN
59804 IF (M13.GE.1) THEN
59805 WRITE(M11,5010) ITUNE, CHNAME
59806 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
59807 WRITE(M11,5030) CH60
59808 ENDIF
59809 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59810 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59811 & ' with tune.')
59812 ENDIF
59813C...PDF
59814 MSTP(51)=7
59815 MSTP(52)=1
59816C...ISR
59817 PARP(62)=1D0
59818 PARP(64)=1D0
59819 PARP(67)=4D0
59820C...FSR
59821 PARP(71)=4D0
59822 PARJ(81)=0.29D0
59823C...UE
59824 MSTP(81)=11
59825 PARP(82)=2.25D0
59826 PARP(89)=1800D0
59827 PARP(90)=0.25D0
59828C... ExpOfPow(1.8) overlap profile
59829 MSTP(82)=5
59830 PARP(83)=1.8D0
59831C... Valence qq
59832 MSTP(88)=0
59833C... Rap Tune
59834 MSTP(89)=1
59835C... Default diquark, BR-g-BR supp
59836 PARP(79)=2D0
59837 PARP(80)=0.01D0
59838C... Final state reconnect.
59839 MSTP(95)=1
59840 PARP(78)=0.55D0
59841C...Fragmentation functions and c and b parameters
59842 MSTJ(11)=4
59843 PARJ(54)=-0.05
59844 PARJ(55)=-0.005
59845C... Output
59846 IF (M13.GE.1) THEN
59847 WRITE(M11,5030) ' '
59848 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59849 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59850 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59851 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59852 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59853 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59854 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59855 WRITE(M11,5030) CH60
59856 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59857 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59858 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59859 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59860 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59861 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59862 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59863 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59864 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59865 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59866 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59867 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59868 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59869 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59870 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59871 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59872 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59873 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59874 ENDIF
59875
59876C...APT. Tune A modified to use new pT-ordered FSR.
59877 ELSEIF(ITUNE.EQ.201) THEN
59878 IF (M13.GE.1) THEN
59879 WRITE(M11,5010) ITUNE, CHNAME
59880 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
59881 WRITE(M11,5030) CH60
59882 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59883 WRITE(M11,5030) CH60
59884 CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59885 WRITE(M11,5030) CH60
59886 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59887 WRITE(M11,5030) CH60
59888 ENDIF
59889 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
59890 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59891 & ' with tune.')
59892 ENDIF
59893C...First set as if Pythia tune A
59894C...Multiple interactions on, old framework
59895 MSTP(81)=1
59896C...Fast IR cutoff energy scaling by default
59897 PARP(89)=1800D0
59898 PARP(90)=0.25D0
59899C...Default CTEQ5L (internal)
59900 MSTP(51)=7
59901 MSTP(52)=1
59902C...Double Gaussian matter distribution.
59903 MSTP(82)=4
59904 PARP(83)=0.5D0
59905 PARP(84)=0.4D0
59906C...FSR activity.
59907 PARP(71)=4D0
59908c...String drawing almost completely minimizes string length.
59909 PARP(85)=0.9D0
59910 PARP(86)=0.95D0
59911C...ISR cutoff, muR scale factor, and phase space size
59912 PARP(62)=1D0
59913 PARP(64)=1D0
59914 PARP(67)=4D0
59915C...Intrinsic kT, size, and max
59916 MSTP(91)=1
59917 PARP(91)=1D0
59918 PARP(93)=5D0
59919C...Use pT-ordered FSR
59920 MSTJ(41)=12
59921C...Lambda_FSR scale for pT-ordering
59922 PARJ(81)=0.23D0
59923C...Retune pT0
59924 PARP(82)=2.1D0
59925C...Fragmentation functions and c and b parameters
59926 MSTJ(11)=4
59927 PARJ(54)=-0.05
59928 PARJ(55)=-0.005
59929
59930C... Output
59931 IF (M13.GE.1) THEN
59932 WRITE(M11,5030) ' '
59933 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59934 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59935 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59936 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59937 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59938 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59939 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59940 WRITE(M11,5030) CH60
59941 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
59942 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59943 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59944 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59945 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59946 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59947 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59948 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59949 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59950 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59951 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59952 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59953 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59954 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59955 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59956 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59957 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59958 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59959 ENDIF
59960
59961C=============================================================================
59962C...Uppsala models: Generalized Area Law and Soft Colour Interactions
59963 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
59964 IF (M13.GE.1) THEN
59965 WRITE(M11,5010) ITUNE, CHNAME
59966 CH60='see J. Rathsman, PLB452(1999)364'
59967 WRITE(M11,5030) CH60
59968C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
59969C ? WRITE(M11,5030)
59970 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59971 WRITE(M11,5030) CH60
59972 WRITE(M11,5030) ' '
59973 CH70='NB! The GAL model must be run with modified '//
59974 & 'Pythia v6.215:'
59975 WRITE(M11,5035) CH70
59976 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
59977 WRITE(M11,5035) CH70
59978 WRITE(M11,5030) ' '
59979 ENDIF
59980C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
59981 MSWI(2) = 3
59982 PARSCI(2) = 0.10
59983 MSWI(1) = 2
59984 PARSCI(1) = 0.44
59985 MSTJ(16) = 0
59986 PARJ(42) = 0.45
59987 PARJ(82) = 2.0
59988 PARP(62) = 2.0
59989 MSTP(81) = 1
59990 MSTP(82) = 1
59991 PARP(81) = 1.9
59992 MSTP(92) = 1
59993 IF(CHNAME.EQ.'GAL Tune 1') THEN
59994C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
59995 MSTP(82)=4
59996 PARP(83)=0.25D0
59997 PARP(84)=0.5D0
59998 PARP(82) = 1.75
59999 IF (M13.GE.1) THEN
60000 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60001 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60002 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60003 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60004 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
60005 ENDIF
60006 ELSE
60007 IF (M13.GE.1) THEN
60008 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60009 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60010 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60011 ENDIF
60012 ENDIF
60013C...Output
60014 IF (M13.GE.1) THEN
60015 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60016 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
60017 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60018 CH40='FSI SCI/GAL selection'
60019 WRITE(M11,6040) 1, MSWI(1), CH40
60020 CH40='FSI SCI/GAL sea quark treatment'
60021 WRITE(M11,6040) 2, MSWI(2), CH40
60022 CH40='FSI SCI/GAL sea quark treatment parm'
60023 WRITE(M11,6050) 1, PARSCI(1), CH40
60024 CH40='FSI SCI/GAL string reco probability R_0'
60025 WRITE(M11,6050) 2, PARSCI(2), CH40
60026 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
60027 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60028 ENDIF
60029 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
60030 IF (M13.GE.1) THEN
60031 WRITE(M11,5010) ITUNE, CHNAME
60032 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
60033 WRITE(M11,5030) CH60
60034 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
60035 WRITE(M11,5030) CH60
60036 WRITE(M11,5030) ' '
60037 CH70='NB! The SCI model must be run with modified '//
60038 & 'Pythia v6.215:'
60039 WRITE(M11,5035) CH70
60040 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
60041 WRITE(M11,5035) CH70
60042 WRITE(M11,5030) ' '
60043 ENDIF
60044C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
60045 MSTP(81)=1
60046 MSTP(82)=1
60047 PARP(81)=2.2
60048 MSTP(92)=1
60049 MSWI(2)=2
60050 PARSCI(2)=0.50
60051 MSWI(1)=2
60052 PARSCI(1)=0.44
60053 MSTJ(16)=0
60054 IF (CHNAME.EQ.'SCI Tune 1') THEN
60055C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
60056 MSTP(81) = 1
60057 MSTP(82) = 3
60058 PARP(82) = 2.4
60059 PARP(83) = 0.5D0
60060 PARP(62) = 1.5
60061 PARP(84)=0.25D0
60062 IF (M13.GE.1) THEN
60063 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60064 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60065 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60066 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60067 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60068 ENDIF
60069 ELSE
60070 IF (M13.GE.1) THEN
60071 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60072 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60073 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60074 ENDIF
60075 ENDIF
60076C...Output
60077 IF (M13.GE.1) THEN
60078 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60079 CH40='FSI SCI/GAL selection'
60080 WRITE(M11,6040) 1, MSWI(1), CH40
60081 CH40='FSI SCI/GAL sea quark treatment'
60082 WRITE(M11,6040) 2, MSWI(2), CH40
60083 CH40='FSI SCI/GAL sea quark treatment parm'
60084 WRITE(M11,6050) 1, PARSCI(1), CH40
60085 CH40='FSI SCI/GAL string reco probability R_0'
60086 WRITE(M11,6050) 2, PARSCI(2), CH40
60087 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60088 ENDIF
60089
60090 ELSE
60091 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
60092
60093 ENDIF
60094
60095 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
60096
60097 9999 RETURN
60098
60099 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
60100 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
60101 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
60102 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
60103 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
60104 5030 FORMAT(' *',3x,10x,A60,3x,'*')
60105 5035 FORMAT(' *',3x,A70,3x,'*')
60106 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
60107 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
60108 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
60109 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
60110 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
60111 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
60112 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
60113 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
60114 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
60115
60116 END
60117
60118C*********************************************************************
60119
60120C...PYEXEC
60121C...Administrates the fragmentation and decay chain.
60122
60123 SUBROUTINE PYEXEC
60124
60125C...Double precision and integer declarations.
60126 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60127 IMPLICIT INTEGER(I-N)
60128 INTEGER PYK,PYCHGE,PYCOMP
60129C...Commonblocks.
60130 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60131 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60132 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60133 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60134 COMMON/PYINT1/MINT(400),VINT(400)
60135 COMMON/PYINT4/MWID(500),WIDS(500,5)
60136 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
60137C...Local array.
60138 DIMENSION PS(2,6),IJOIN(100)
60139
60140C...Initialize and reset.
60141 MSTU(24)=0
60142 IF(MSTU(12).NE.12345) CALL PYLIST(0)
60143 MSTU(29)=0
60144 MSTU(31)=MSTU(31)+1
60145 MSTU(1)=0
60146 MSTU(2)=0
60147 MSTU(3)=0
60148 IF(MSTU(17).LE.0) MSTU(90)=0
60149 MCONS=1
60150
60151C...Sum up momentum, energy and charge for starting entries.
60152 NSAV=N
60153 DO 110 I=1,2
60154 DO 100 J=1,6
60155 PS(I,J)=0D0
60156 100 CONTINUE
60157 110 CONTINUE
60158 DO 130 I=1,N
60159 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
60160 DO 120 J=1,4
60161 PS(1,J)=PS(1,J)+P(I,J)
60162 120 CONTINUE
60163 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
60164 130 CONTINUE
60165 PARU(21)=PS(1,4)
60166
60167C...Start by all decays of coloured resonances involved in shower.
60168 NORIG=N
60169 DO 140 I=1,NORIG
60170 IF(K(I,1).EQ.3) THEN
60171 KC=PYCOMP(K(I,2))
60172 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
60173 ENDIF
60174 140 CONTINUE
60175
60176C...Prepare system for subsequent fragmentation/decay.
60177 CALL PYPREP(0)
60178 IF(MINT(51).NE.0) RETURN
60179
60180C...Loop through jet fragmentation and particle decays.
60181 MBE=0
60182 150 MBE=MBE+1
60183 IP=0
60184 160 IP=IP+1
60185 KC=0
60186 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
60187 IF(KC.EQ.0) THEN
60188
60189C...Deal with any remaining undecayed resonance
60190C...(normally the task of PYEVNT, so seldom used).
60191 ELSEIF(MWID(KC).NE.0) THEN
60192 IBEG=IP
60193 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
60194 IBEG=IP+1
60195 170 IBEG=IBEG-1
60196 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
60197 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
60198 IEND=IP-1
60199 180 IEND=IEND+1
60200 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
60201 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
60202 NJOIN=0
60203 DO 190 I=IBEG,IEND
60204 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
60205 NJOIN=NJOIN+1
60206 IJOIN(NJOIN)=I
60207 ENDIF
60208 190 CONTINUE
60209 ENDIF
60210 CALL PYRESD(IP)
60211 CALL PYPREP(IBEG)
60212 IF(MINT(51).NE.0) RETURN
60213
60214C...Particle decay if unstable and allowed. Save long-lived particle
60215C...decays until second pass after Bose-Einstein effects.
60216 ELSEIF(KCHG(KC,2).EQ.0) THEN
60217 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
60218 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
60219 & CALL PYDECY(IP)
60220
60221C...Decay products may develop a shower.
60222 IF(MSTJ(92).GT.0) THEN
60223 IP1=MSTJ(92)
60224 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
60225 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
60226 MINT(33)=0
60227 if(parj(200).ne.1.) CALL PYSHOW(IP1,IP1+1,QMAX)
60228 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP1+1,QMAX)
60229 CALL PYPREP(IP1)
60230 IF(MINT(51).NE.0) RETURN
60231 MSTJ(92)=0
60232 ELSEIF(MSTJ(92).LT.0) THEN
60233 IP1=-MSTJ(92)
60234 MINT(33)=0
60235 if(parj(200).ne.1.) CALL PYSHOW(IP1,-3,P(IP,5))
60236 if(parj(200).eq.1.) CALL PYSHOWQ(IP1,-3,P(IP,5))
60237 CALL PYPREP(IP1)
60238 IF(MINT(51).NE.0) RETURN
60239 MSTJ(92)=0
60240 ENDIF
60241
60242C...Jet fragmentation: string or independent fragmentation.
60243 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
60244 MFRAG=MSTJ(1)
60245 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
60246 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
60247 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
60248 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
60249 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
60250 ENDIF
60251 ENDIF
60252 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
60253 IF(MFRAG.EQ.2) CALL PYINDF(IP)
60254 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
60255 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
60256 ENDIF
60257
60258C...Loop back if enough space left in PYJETS and no error abort.
60259 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
60260 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
60261 GOTO 160
60262 ELSEIF(IP.LT.N) THEN
60263 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
60264 ENDIF
60265
60266C...Include simple Bose-Einstein effect parametrization if desired.
60267 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
60268 CALL PYBOEI(NSAV)
60269 GOTO 150
60270 ENDIF
60271
60272C...Check that momentum, energy and charge were conserved.
60273 DO 210 I=1,N
60274 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
60275 DO 200 J=1,4
60276 PS(2,J)=PS(2,J)+P(I,J)
60277 200 CONTINUE
60278 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
60279 210 CONTINUE
60280 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
60281 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
60282 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
60283 &'(PYEXEC:) four-momentum was not conserved')
60284 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
60285 &'(PYEXEC:) charge was not conserved')
60286
60287 RETURN
60288 END
60289
60290C*********************************************************************
60291
60292C...PYPREP
60293C...Rearranges partons along strings.
60294C...Special considerations for systems with junctions, with
60295C...possibility of junction-antijunction annihilation.
60296C...Allows small systems to collapse into one or two particles.
60297C...Checks flavours and colour singlet invariant masses.
60298
60299 SUBROUTINE PYPREP(IP)
60300
60301C...Double precision and integer declarations.
60302 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60303 INTEGER PYK,PYCHGE,PYCOMP
60304C...Commonblocks.
60305 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60306 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60307 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60308 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60309 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60310 COMMON/PYINT1/MINT(400),VINT(400)
60311C...The common block of colour tags.
60312 COMMON/PYCTAG/NCT,MCT(4000,2)
60313 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
60314 &/PYPARS/
60315 DATA NERRPR/0/
60316 SAVE NERRPR
60317C...Local arrays.
60318 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
60319 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
60320 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
60321 &IJCP(0:6),TJUOLD(5)
60322 CHARACTER CHTMP*6
60323
60324C...Function to give four-product.
60325 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)
60326
60327C...Rearrange parton shower product listing along strings: begin loop.
60328 MSTU(24)=0
60329 NOLD=N
60330 I1=N
60331 NJUNC=0
60332 NPIECE=0
60333 NJJSTR=0
60334 MSTU32=MSTU(32)+1
60335 DO 100 I=MAX(1,IP),N
60336C...First store junction positions.
60337 IF(K(I,1).EQ.42) THEN
60338 NJUNC=NJUNC+1
60339 IJUNC(NJUNC,0)=I
60340 IJUNC(NJUNC,4)=0
60341 ENDIF
60342 100 CONTINUE
60343
60344 DO 250 MQGST=1,3
60345 DO 240 I=MAX(1,IP),N
60346C...Special treatment for junctions
60347 IF (K(I,1).LE.0) GOTO 240
60348 IF(K(I,1).EQ.42) THEN
60349C...MQGST=2: Look for junction-junction strings (not detected in the
60350C...main search below).
60351 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
60352 IF (NJJSTR.EQ.0) THEN
60353 NJJSTR = (3*NJUNC-NPIECE)/2
60354 ENDIF
60355C...Check how many already identified strings end on this junction
60356 ILC=0
60357 DO 110 J=1,NPIECE
60358 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
60359 110 CONTINUE
60360C...If less than 3, remaining must be to another junction
60361 IF (ILC.LT.3) THEN
60362 IF (ILC.NE.2) THEN
60363C...Multiple j-j connections not handled yet.
60364 CALL PYERRM(2,
60365 & '(PYPREP:) Too many junction-junction strings.')
60366 MINT(51)=1
60367 RETURN
60368 ENDIF
60369C...The colour information in the junction is unreadable for the
60370C...colour space search further down in this routine, so we must
60371C...start on the colour mother of this junction and then "artificially"
60372C...prevent the colour mother from connecting here again.
60373 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
60374 KCS=4
60375 IF (MOD(ITJUNC,2).EQ.0) KCS=5
60376C...Switch colour if the junction-junction leg is presumably a
60377C...junction mother leg rather than a junction daughter leg.
60378 IF (ITJUNC.GE.3) KCS=9-KCS
60379 IF (MINT(33).EQ.0) THEN
60380C...Find the unconnected leg and reorder junction daughter pointers so
60381C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
60382C...piece.
60383 IA=MOD(K(I,4),MSTU(5))
60384 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
60385 ITMP=MOD(K(I,5),MSTU(5))
60386 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
60387 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
60388 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
60389 ELSE
60390 K(I,5)=K(I,5)+(IA-ITMP)
60391 ENDIF
60392 K(I,4)=K(I,4)+(ITMP-IA)
60393 IA=ITMP
60394 ENDIF
60395 IF (ITJUNC.LE.2) THEN
60396C...Beam baryon junction
60397 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
60398 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
60399C...Else 1 -> 2 decay junction
60400 ELSE
60401 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
60402 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
60403 ENDIF
60404 I1BEG = I1
60405 NSTP = 0
60406 GOTO 170
60407C...Alternatively use colour tag information.
60408 ELSE
60409C...Find a final state parton with appropriate dangling colour tag.
60410 JCT=0
60411 IA=0
60412 IJUMO=K(I,3)
60413 DO 140 J1=MAX(1,IP),N
60414 IF (K(J1,1).NE.3) GOTO 140
60415C...Check for matching final-state colour tag
60416 IMATCH=0
60417 DO 120 J2=MAX(1,IP),N
60418 IF (K(J2,1).NE.3) GOTO 120
60419 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
60420 120 CONTINUE
60421 IF (IMATCH.EQ.1) GOTO 140
60422C...Check whether this colour tag belongs to the present junction
60423C...by seeing whether any parton with this colour tag has the same
60424C...mother as the junction.
60425 JCT=MCT(J1,KCS-3)
60426 IMATCH=0
60427 DO 130 J2=MINT(84)+1,N
60428 IMO2=K(J2,3)
60429C...First scattering partons have IMO1 = 3 and 4.
60430 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
60431 & IMO2=IMO2-2
60432 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
60433 & IMATCH=1
60434 130 CONTINUE
60435 IF (IMATCH.EQ.0) GOTO 140
60436 IA=J1
60437 140 CONTINUE
60438C...Check for junction-junction strings without intermediate final state
60439C...glue (not detected above).
60440 IF (IA.EQ.0) THEN
60441 DO 160 MJU=1,NJUNC
60442 IJU2=IJUNC(MJU,0)
60443 IF (IJU2.EQ.I) GOTO 160
60444 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
60445C...Only opposite types of junctions can connect to each other.
60446 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
60447 IS=0
60448 DO 150 J=1,NPIECE
60449 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
60450 150 CONTINUE
60451 IF (IS.EQ.3) GOTO 160
60452 IB=I
60453 IA=IJU2
60454 160 CONTINUE
60455 ENDIF
60456C...Switch to other side of adjacent parton and step from there.
60457 KCS=9-KCS
60458 I1BEG = I1
60459 NSTP = 0
60460 GOTO 170
60461 ENDIF
60462 ELSE IF (ILC.NE.3) THEN
60463 ENDIF
60464 ENDIF
60465 ENDIF
60466
60467C...Look for coloured string endpoint, or (later) leftover gluon.
60468 IF(K(I,1).NE.3) GOTO 240
60469 KC=PYCOMP(K(I,2))
60470 IF(KC.EQ.0) GOTO 240
60471 KQ=KCHG(KC,2)
60472 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
60473
60474C...Pick up loose string end.
60475 KCS=4
60476 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
60477 IA=I
60478 IB=I
60479 I1BEG=I1
60480 NSTP=0
60481 170 NSTP=NSTP+1
60482 IF(NSTP.GT.4*N) THEN
60483 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
60484 MINT(51)=1
60485 RETURN
60486 ENDIF
60487
60488C...Copy undecayed parton. Finished if reached string endpoint.
60489 IF(K(IA,1).EQ.3) THEN
60490 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
60491 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60492 MINT(51)=1
60493 MSTU(24)=1
60494 RETURN
60495 ENDIF
60496 I1=I1+1
60497 K(I1,1)=2
60498 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
60499 K(I1,2)=K(IA,2)
60500 K(I1,3)=IA
60501 K(I1,4)=0
60502 K(I1,5)=0
60503 DO 180 J=1,5
60504 P(I1,J)=P(IA,J)
60505 V(I1,J)=V(IA,J)
60506 180 CONTINUE
60507 K(IA,1)=K(IA,1)+10
60508 IF(K(I1,1).EQ.1) GOTO 240
60509 ENDIF
60510
60511C...Also finished (for now) if reached junction; then copy to end.
60512 IF(K(IA,1).EQ.42) THEN
60513 NCOPY=I1-I1BEG
60514 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
60515 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60516 MINT(51)=1
60517 MSTU(24)=1
60518 RETURN
60519 ENDIF
60520 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
60521 DO 200 ICOPY=1,NCOPY
60522 DO 190 J=1,5
60523 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
60524 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
60525 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
60526 190 CONTINUE
60527 200 CONTINUE
60528 ENDIF
60529C...For junction-junction strings, find end leg and reorder junction
60530C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
60531C...junction-junction string piece.
60532 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
60533 ITMP=MOD(K(IA,4),MSTU(5))
60534 IF (ITMP.NE.IB) THEN
60535 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
60536 K(IA,5)=K(IA,5)+(ITMP-IB)
60537 ELSE
60538 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
60539 ENDIF
60540 K(IA,4)=K(IA,4)+(IB-ITMP)
60541 ENDIF
60542 ENDIF
60543 NPIECE=NPIECE+1
60544C...IPIECE:
60545C...0: endpoint in original ER
60546C...1:
60547C...2:
60548C...3: Parton immediately next to junction
60549C...4: Junction
60550 IPIECE(NPIECE,0)=I
60551 IPIECE(NPIECE,1)=MSTU32+1
60552 IPIECE(NPIECE,2)=MSTU32+NCOPY
60553 IPIECE(NPIECE,3)=IB
60554 IPIECE(NPIECE,4)=IA
60555 MSTU32=MSTU32+NCOPY
60556 I1=I1BEG
60557 GOTO 240
60558 ENDIF
60559
60560C...GOTO next parton in colour space.
60561 IB=IA
60562 IF (MINT(33).EQ.0) THEN
60563 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
60564 & )).NE.0) THEN
60565 IA=MOD(K(IB,KCS),MSTU(5))
60566 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
60567 MREV=0
60568 ELSE
60569 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
60570 & MSTU(5)).EQ.0) KCS=9-KCS
60571 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
60572 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
60573 MREV=1
60574 ENDIF
60575 IF(IA.LE.0.OR.IA.GT.N) THEN
60576 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
60577 IF(NERRPR.LT.5) THEN
60578 NERRPR=NERRPR+1
60579 WRITE(MSTU(11),*) 'started at:', I
60580 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
60581 WRITE(MSTU(11),*) 'MQGST =',MQGST
60582 CALL PYLIST(4)
60583 ENDIF
60584 MINT(51)=1
60585 RETURN
60586 ENDIF
60587 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
60588 & ,MSTU(5)).EQ.IB) THEN
60589 IF(MREV.EQ.1) KCS=9-KCS
60590 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
60591 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
60592 ELSE
60593 IF(MREV.EQ.0) KCS=9-KCS
60594 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
60595 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
60596 ENDIF
60597 IF(IA.NE.I) GOTO 170
60598C...Use colour tag information
60599 ELSE
60600C...First create colour tags starting on IB if none already present.
60601 IF (MCT(IB,KCS-3).EQ.0) THEN
60602 CALL PYCTTR(IB,KCS,IB)
60603 IF(MINT(51).NE.0) RETURN
60604 ENDIF
60605 JCT=MCT(IB,KCS-3)
60606 IFOUND=0
60607C...Find final state tag partner
60608 DO 210 IT=MAX(1,IP),N
60609 IF (IT.EQ.IB) GOTO 210
60610 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
60611 & .0) THEN
60612 IFOUND=IFOUND+1
60613 IA=IT
60614 ENDIF
60615 210 CONTINUE
60616C...Just copy and goto next if exactly one partner found.
60617 IF (IFOUND.EQ.1) THEN
60618 GOTO 170
60619C...When no match found, match is presumably junction.
60620 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
60621C...Check whether this colour tag matches a junction
60622C...by seeing whether any parton with this colour tag has the same
60623C...mother as a junction.
60624C...NB: Only type 1 and 2 junctions handled presently.
60625 DO 230 IJU=1,NJUNC
60626 IJUMO=K(IJUNC(IJU,0),3)
60627 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
60628C...Colours only connect to junctions, anti-colours to antijunctions:
60629 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
60630 IMATCH=0
60631 DO 220 J1=MAX(1,IP),N
60632 IF (K(J1,1).LE.0) GOTO 220
60633C...First scattering partons have IMO1 = 3 and 4.
60634 IMO=K(J1,3)
60635 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
60636 & IMO=IMO-2
60637 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
60638 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
60639 & IMATCH=1
60640C...Attempt at handling type > 3 junctions also. Not tested.
60641 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
60642 & .IJUMO) IMATCH=1
60643 220 CONTINUE
60644 IF (IMATCH.EQ.0) GOTO 230
60645 IA=IJUNC(IJU,0)
60646 IFOUND=IFOUND+1
60647 230 CONTINUE
60648
60649 IF (IFOUND.EQ.1) THEN
60650 GOTO 170
60651 ELSEIF (IFOUND.EQ.0) THEN
60652 WRITE(CHTMP,*) JCT
60653 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
60654 & //CHTMP)
60655 IF(NERRPR.LT.5) THEN
60656 NERRPR=NERRPR+1
60657 CALL PYLIST(4)
60658 ENDIF
60659 MINT(51)=1
60660 RETURN
60661 ENDIF
60662 ELSEIF (IFOUND.GE.2) THEN
60663 WRITE(CHTMP,*) JCT
60664 CALL PYERRM(12
60665 & ,'(PYPREP:) too many occurences of colour line: '//
60666 & CHTMP)
60667 IF(NERRPR.LT.5) THEN
60668 NERRPR=NERRPR+1
60669 CALL PYLIST(4)
60670 ENDIF
60671 MINT(51)=1
60672 RETURN
60673 ENDIF
60674 ENDIF
60675 K(I1,1)=1
60676 240 CONTINUE
60677 250 CONTINUE
60678
60679C...Junction systems remain.
60680 IJU=0
60681 IJUS=0
60682 IJUCNT=0
60683 MREV=0
60684 IJJSTR=0
60685 260 IJUCNT=IJUCNT+1
60686 IF (IJUCNT.LE.NJUNC) THEN
60687C...If we are not processing a j-j string, treat this junction as new.
60688 IF (IJJSTR.EQ.0) THEN
60689 IJU=IJUNC(IJUCNT,0)
60690 MREV=0
60691C...If junction has already been read, ignore it.
60692 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
60693C...If we are on a j-j string, goto second j-j junction.
60694 ELSE
60695 IJUCNT=IJUCNT-1
60696 IJU=IJUS
60697 ENDIF
60698C...Mark selected junction read.
60699 DO 270 J=1,NJUNC
60700 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
60701 270 CONTINUE
60702C...Determine junction type
60703 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
60704C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
60705C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
60706C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
60707 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
60708 IHK=0
60709 280 IHK=IHK+1
60710C...Find which quarks belong to given junction.
60711 IHF=0
60712 DO 290 IPC=1,NPIECE
60713 IF (IPIECE(IPC,4).EQ.IJU) THEN
60714 IHF=IHF+1
60715 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
60716 ENDIF
60717 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
60718 290 CONTINUE
60719C...IHK = 3 is special. Either normal string piece, or j-j string.
60720 IF(IHK.EQ.3) THEN
60721 IF (MREV.NE.1) THEN
60722 DO 300 IPC=1,NPIECE
60723C...If there is a j-j string starting on the present junction which has
60724C...zero length, insert next junction immediately.
60725 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
60726 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
60727 IJJSTR = 1
60728 GOTO 340
60729 ENDIF
60730 300 CONTINUE
60731 MREV = 1
60732C...If MREV is 1 and IHK is 3 we are finished with this system.
60733 ELSE
60734 MREV=0
60735 GOTO 260
60736 ENDIF
60737 ENDIF
60738
60739C...If we've gotten this far, then either IHK < 3, or
60740C...an interjunction string exists, or just a third normal string.
60741 IJUNC(IJUCNT,IHK)=0
60742 IJJSTR = 0
60743C..Order pieces belonging to this junction. Also look for j-j.
60744 DO 310 IPC=1,NPIECE
60745 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
60746 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
60747 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
60748 IJUNC(IJUCNT,IHK)=IPC
60749 IJJSTR = 1
60750 MREV = 0
60751 ENDIF
60752 310 CONTINUE
60753C...Copy back chains in proper order. MREV=0/1 : descending/ascending
60754 IPC=IJUNC(IJUCNT,IHK)
60755C...Temporary solution to cover for bug.
60756 IF(IPC.LE.0) THEN
60757 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
60758 MINT(51)=1
60759 RETURN
60760 ENDIF
60761 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
60762 I1=I1+1
60763 DO 320 J=1,5
60764 K(I1,J)=K(MSTU(4)-ICP,J)
60765 P(I1,J)=P(MSTU(4)-ICP,J)
60766 V(I1,J)=V(MSTU(4)-ICP,J)
60767 320 CONTINUE
60768 330 CONTINUE
60769 K(I1,1)=2
60770C...Mark last quark.
60771 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
60772C...Do not insert junctions at wrong places.
60773 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
60774C...Insert junction.
60775 340 IJUS = IJU
60776 IF (IHK.EQ.3) THEN
60777C...Shift to end junction if a j-j string has been processed.
60778 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
60779 MREV= 1
60780 ENDIF
60781 I1=I1+1
60782 DO 350 J=1,5
60783 K(I1,J)=0
60784 P(I1,J)=0.
60785 V(I1,J)=0.
60786 350 CONTINUE
60787 K(I1,1)=41
60788 K(IJUS,1)=K(IJUS,1)+10
60789 K(I1,2)=K(IJUS,2)
60790 K(I1,3)=IJUS
60791 360 IF (IHK.LT.3) GOTO 280
60792 ELSE
60793 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
60794 MINT(51)=1
60795 RETURN
60796 ENDIF
60797 IF (IJUCNT.NE.NJUNC) GOTO 260
60798 ENDIF
60799 N=I1
60800
60801C...Rearrange three strings from junction, e.g. in case one has been
60802C...shortened by shower, so the last is the largest-energy one.
60803 IF(NJUNC.GE.1) THEN
60804C...Find systems with exactly one junction.
60805 MJUN1=0
60806 NBEG=NOLD+1
60807 DO 470 I=NOLD+1,N
60808 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
60809 ELSEIF(K(I,1).EQ.41) THEN
60810 MJUN1=MJUN1+1
60811 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
60812 MJUN1=0
60813 NBEG=I+1
60814 ELSE
60815 NEND=I
60816C...Sum up energy-momentum in each junction string.
60817 DO 370 J=1,5
60818 PJU(1,J)=0D0
60819 PJU(2,J)=0D0
60820 PJU(3,J)=0D0
60821 370 CONTINUE
60822 NJU=0
60823 DO 390 I1=NBEG,NEND
60824 IF(K(I1,2).NE.21) THEN
60825 NJU=NJU+1
60826 IJUR(NJU)=I1
60827 ENDIF
60828 DO 380 J=1,5
60829 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
60830 380 CONTINUE
60831 390 CONTINUE
60832C...Find which of them has highest energy (minus mass) in rest frame.
60833 DO 400 J=1,5
60834 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
60835 400 CONTINUE
60836 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
60837 & PJU(4,3)**2))
60838 DO 410 I2=1,3
60839 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
60840 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
60841 410 CONTINUE
60842 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
60843C...Decide how to rearrange so that new last has highest energy.
60844 IF(PJU(1,6).LT.PJU(2,6)) THEN
60845 IRNG(1,1)=IJUR(1)
60846 IRNG(1,2)=IJUR(2)-1
60847 IRNG(2,1)=IJUR(4)
60848 IRNG(2,2)=IJUR(3)+1
60849 IRNG(4,1)=IJUR(3)-1
60850 IRNG(4,2)=IJUR(2)
60851 ELSE
60852 IRNG(1,1)=IJUR(4)
60853 IRNG(1,2)=IJUR(3)+1
60854 IRNG(2,1)=IJUR(2)
60855 IRNG(2,2)=IJUR(3)-1
60856 IRNG(4,1)=IJUR(2)-1
60857 IRNG(4,2)=IJUR(1)
60858 ENDIF
60859 IRNG(3,1)=IJUR(3)
60860 IRNG(3,2)=IJUR(3)
60861C...Copy in correct order below bottom of current event record.
60862 I2=N
60863 DO 440 II=1,4
60864 DO 430 I1=IRNG(II,1),IRNG(II,2),
60865 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
60866 I2=I2+1
60867 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
60868 CALL PYERRM(11,
60869 & '(PYPREP:) no more memory left in PYJETS')
60870 MINT(51)=1
60871 MSTU(24)=1
60872 RETURN
60873 ENDIF
60874 DO 420 J=1,5
60875 K(I2,J)=K(I1,J)
60876 P(I2,J)=P(I1,J)
60877 V(I2,J)=V(I1,J)
60878 420 CONTINUE
60879 IF(K(I2,1).EQ.1) K(I2,1)=2
60880 430 CONTINUE
60881 440 CONTINUE
60882 K(I2,1)=1
60883C...Copy back up, overwriting but now in correct order.
60884 DO 460 I1=NBEG,NEND
60885 I2=I1-NBEG+N+1
60886 DO 450 J=1,5
60887 K(I1,J)=K(I2,J)
60888 P(I1,J)=P(I2,J)
60889 V(I1,J)=V(I2,J)
60890 450 CONTINUE
60891 460 CONTINUE
60892 ENDIF
60893 MJUN1=0
60894 NBEG=I+1
60895 ENDIF
60896 470 CONTINUE
60897
60898C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
60899C...to two q-qbar systems.
60900C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
60901 IF (MSTJ(19).NE.1) THEN
60902 MJUN1 = 0
60903 JJGLUE = 0
60904 NBEG = NOLD+1
60905C...Force collapse when MSTJ(19)=2.
60906 IF (MSTJ(19).EQ.2) THEN
60907 DELMJJ = 1D9
60908 DELMQQ = 0D0
60909 ENDIF
60910C...Find systems with exactly two junctions.
60911 DO 700 I=NOLD+1,N
60912C...Count junctions
60913 IF (K(I,1).EQ.41) THEN
60914 MJUN1 = MJUN1+1
60915C...Check for interjunction gluons
60916 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
60917 JJGLUE = 1
60918 ENDIF
60919 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
60920C...If end of system reached with either zero or one junction, restart
60921C...with next system.
60922 MJUN1 = 0
60923 JJGLUE = 0
60924 NBEG = I+1
60925 ELSEIF(K(I,1).EQ.1) THEN
60926C...If end of system reached with exactly two junctions, compute string
60927C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
60928C...length measure for the (q-qbar)(q-qbar) topology.
60929 NEND=I
60930C...Loop down through chain.
60931 ISID=0
60932 DO 480 I1=NBEG,NEND
60933C...Store string piece division locations in event record
60934 IF (K(I1,2).NE.21) THEN
60935 ISID = ISID+1
60936 IJCP(ISID) = I1
60937 ENDIF
60938 480 CONTINUE
60939C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
60940 ISW=0
60941 IF (PYR(0).LT.0.5D0) ISW=1
60942C...Randomly choose which qqbar string gets the jj gluons.
60943 IGS=1
60944 IF (PYR(0).GT.0.5D0) IGS=2
60945C...Only compute string lengths when no topology forced.
60946 IF (MSTJ(19).EQ.0) THEN
60947C...Repeat following for each junction
60948 DO 570 IJU=1,2
60949C...Initialize iterative procedure for finding JRF
60950 IJRFIT=0
60951 DO 490 IX=1,3
60952 TJUOLD(IX)=0D0
60953 490 CONTINUE
60954 TJUOLD(4)=1D0
60955C...Start iteration. Sum up momenta in string pieces
60956 500 DO 540 IJS=1,3
60957C...JD=-1 for first junction, +1 for second junction.
60958C...Find out where piece starts and ends and which direction to go.
60959 JD=2*IJU-3
60960 IF (IJS.LE.2) THEN
60961 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
60962 IB = IJCP((IJU-1)*7 - JD*IJS)
60963 ELSEIF (IJS.EQ.3) THEN
60964 JD =-JD
60965 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
60966 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
60967 ENDIF
60968C...Initialize junction pull 4-vector.
60969 DO 510 J=1,5
60970 PUL(IJS,J)=0D0
60971 510 CONTINUE
60972C...Initialize weight
60973 PWT = 0D0
60974 PWTOLD = 0D0
60975C...Sum up (weighted) momenta along each string piece
60976 DO 530 ISP=IA,IB,JD
60977C...If present parton not last in chain
60978 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
60979C...If last parton was a junction, store present weight
60980 IF (K(ISP-JD,2).EQ.88) THEN
60981 PWTOLD = PWT
60982C...If last parton was a quark, reset to stored weight.
60983 ELSEIF (K(ISP-JD,2).NE.21) THEN
60984 PWT = PWTOLD
60985 ENDIF
60986 ENDIF
60987C...Skip next parton if weight already large
60988 IF (PWT.GT.10D0) GOTO 530
60989C...Compute momentum in TJUOLD frame:
60990 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
60991 & )*P(ISP,3)
60992 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
60993 DO 520 J=1,3
60994 TMP=P(ISP,J)+TJUOLD(J)*BFC
60995 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
60996 520 CONTINUE
60997C...Boosted energy
60998 TMP=TJUOLD(4)*P(ISP,4)+TDP
60999 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
61000C...Update weight
61001 PWT=PWT+TMP/PARJ(48)
61002C...Put |p| rather than m in 5th slot
61003 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
61004 & +PUL(IJS,3)**2)
61005 530 CONTINUE
61006 540 CONTINUE
61007C...Compute boost
61008 IJRFIT=IJRFIT+1
61009 CALL PYJURF(PUL,T)
61010C...Combine new boost (T) with old boost (TJUOLD)
61011 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
61012 DO 550 IX=1,3
61013 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
61014 & ))
61015 550 CONTINUE
61016 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
61017 & **2)
61018C...If last boost small, accept JRF, else iterate.
61019C...Also prevent possibility of infinite loop.
61020 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
61021 & IJRFIT.LT.MSTJ(18))THEN
61022 GOTO 500
61023 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
61024 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
61025 ENDIF
61026C...Store final boost, with change of sign since TJJ motion vector.
61027 DO 560 IX=1,3
61028 TJJ(IJU,IX)=-TJUOLD(IX)
61029 560 CONTINUE
61030 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
61031 & +TJJ(IJU,3)**2)
61032 570 CONTINUE
61033C...String length measure for (q-qbar)(q-qbar) topology.
61034C...Note only momenta of nearest partons used (since rest of system
61035C...identical).
61036 IF (JJGLUE.EQ.0) THEN
61037 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
61038 & -1,IJCP(5-ISW)+1)
61039 ELSE
61040C...Put jj gluons on selected string (IGS selected randomly above).
61041 IF (IGS.EQ.1) THEN
61042 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61043 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
61044 ELSE
61045 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
61046 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61047 & ,IJCP(5-ISW)+1)
61048 ENDIF
61049 ENDIF
61050C...String length measure for q-q-j-j-q-q topology.
61051 T1G1=0D0
61052 T2G2=0D0
61053 T1T2=0D0
61054 T1P1=0D0
61055 T1P2=0D0
61056 T2P3=0D0
61057 T2P4=0D0
61058 ISGN=-1
61059C...Note only momenta of nearest partons used (since rest of system
61060C...identical).
61061 DO 580 IX=1,4
61062 IF (IX.EQ.4) ISGN=1
61063 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
61064 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
61065 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
61066 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
61067 IF (JJGLUE.EQ.0) THEN
61068C...Junction motion vector dot product gives length when inter-junction
61069C...gluons absent.
61070 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
61071 ELSE
61072C...Junction motion vector dot products with gluon momenta give length
61073C...when inter-junction gluons present.
61074 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
61075 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
61076 ENDIF
61077 580 CONTINUE
61078 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
61079 IF (JJGLUE.EQ.0) THEN
61080 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
61081 ELSE
61082 DELMJJ=DELMJJ*4D0*T1G1*T2G2
61083 ENDIF
61084 ENDIF
61085C...If delmjj > delmqq collapse string system to q-qbar q-qbar
61086C...(Always the case for MSTJ(19)=2 due to initialization above)
61087 IF (DELMJJ.GT.DELMQQ) THEN
61088C...Put new system at end of event record
61089 NCOP=N
61090 DO 650 IST=1,2
61091 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
61092 NCOP=NCOP+1
61093 DO 590 IX=1,5
61094 P(NCOP,IX)=P(ICOP,IX)
61095 K(NCOP,IX)=K(ICOP,IX)
61096 590 CONTINUE
61097 600 CONTINUE
61098 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
61099C...Insert inter-junction gluon string piece (reversed)
61100 NJJGL=0
61101 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
61102 NJJGL=NJJGL+1
61103 NCOP=NCOP+1
61104 DO 610 IX=1,5
61105 P(NCOP,IX)=P(ICOP,IX)
61106 K(NCOP,IX)=K(ICOP,IX)
61107 610 CONTINUE
61108 620 CONTINUE
61109 ENDIF
61110 IFC=-2*IST+3
61111 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
61112 NCOP=NCOP+1
61113 DO 630 IX=1,5
61114 P(NCOP,IX)=P(ICOP,IX)
61115 K(NCOP,IX)=K(ICOP,IX)
61116 630 CONTINUE
61117 640 CONTINUE
61118 K(NCOP,1)=1
61119 650 CONTINUE
61120C...Copy system back in right order
61121 DO 670 ICOP=NBEG,NEND-2
61122 DO 660 IX=1,5
61123 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
61124 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
61125 660 CONTINUE
61126 670 CONTINUE
61127C...Shift down rest of event record
61128 DO 690 ICOP=NEND+1,N
61129 DO 680 IX=1,5
61130 P(ICOP-2,IX)=P(ICOP,IX)
61131 K(ICOP-2,IX)=K(ICOP,IX)
61132 680 CONTINUE
61133 690 CONTINUE
61134C...Update length of event record.
61135 N=N-2
61136 ENDIF
61137 MJUN1=0
61138 NBEG=I+1
61139 ENDIF
61140 700 CONTINUE
61141 ENDIF
61142 ENDIF
61143
61144C...Done if no checks on small-mass systems.
61145 IF(MSTJ(14).LT.0) RETURN
61146 IF(MSTJ(14).EQ.0) GOTO 1140
61147
61148C...Find lowest-mass colour singlet jet system.
61149 NS=N
61150 710 NSIN=N-NS
61151 PDMIN=1D0+PARJ(32)
61152 IC=0
61153 DO 770 I=MAX(1,IP),N
61154 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
61155 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
61156 NSIN=NSIN+1
61157 IC=I
61158 DO 720 J=1,4
61159 DPS(J)=P(I,J)
61160 720 CONTINUE
61161 MSTJ(93)=1
61162 DPS(5)=PYMASS(K(I,2))
61163 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
61164 DO 730 J=1,4
61165 DPS(J)=DPS(J)+P(I,J)
61166 730 CONTINUE
61167 MSTJ(93)=1
61168 DPS(5)=DPS(5)+PYMASS(K(I,2))
61169 ELSEIF(K(I,1).EQ.2) THEN
61170 DO 740 J=1,4
61171 DPS(J)=DPS(J)+P(I,J)
61172 740 CONTINUE
61173 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61174 DO 750 J=1,4
61175 DPS(J)=DPS(J)+P(I,J)
61176 750 CONTINUE
61177 MSTJ(93)=1
61178 DPS(5)=DPS(5)+PYMASS(K(I,2))
61179 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
61180 & DPS(5)
61181 IF(PD.LT.PDMIN) THEN
61182 PDMIN=PD
61183 DO 760 J=1,5
61184 DPC(J)=DPS(J)
61185 760 CONTINUE
61186 IC1=IC
61187 IC2=I
61188 ENDIF
61189 IC=0
61190 ELSE
61191 NSIN=NSIN+1
61192 ENDIF
61193 770 CONTINUE
61194
61195C...Done if lowest-mass system above threshold for string frag.
61196 IF(PDMIN.GE.PARJ(32)) GOTO 1140
61197
61198C...Fill small-mass system as cluster.
61199 NSAV=N
61200 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
61201 K(N+1,1)=11
61202 K(N+1,2)=91
61203 K(N+1,3)=IC1
61204 P(N+1,1)=DPC(1)
61205 P(N+1,2)=DPC(2)
61206 P(N+1,3)=DPC(3)
61207 P(N+1,4)=DPC(4)
61208 P(N+1,5)=PECM
61209
61210C...Set up history, assuming cluster -> 2 hadrons.
61211 NBODY=2
61212 K(N+1,4)=N+2
61213 K(N+1,5)=N+3
61214 K(N+2,1)=1
61215 K(N+3,1)=1
61216 IF(MSTU(16).NE.2) THEN
61217 K(N+2,3)=N+1
61218 K(N+3,3)=N+1
61219 ELSE
61220 K(N+2,3)=IC1
61221 K(N+3,3)=IC2
61222 ENDIF
61223 K(N+2,4)=0
61224 K(N+3,4)=0
61225 K(N+2,5)=0
61226 K(N+3,5)=0
61227 V(N+1,5)=0D0
61228 V(N+2,5)=0D0
61229 V(N+3,5)=0D0
61230
61231C...Find total flavour content - complicated by presence of junctions.
61232 NQ=0
61233 NDIQ=0
61234 DO 780 I=IC1,IC2
61235 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
61236 NQ=NQ+1
61237 KFQ(NQ)=K(I,2)
61238 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
61239 ENDIF
61240 780 CONTINUE
61241
61242C...If several diquarks, split up one to give even number of flavours.
61243 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
61244 I1=3
61245 IF(IABS(KFQ(3)).LT.1000) I1=1
61246 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
61247 KFQ(I1)=KFQ(I1)/1000
61248 NQ=4
61249 NDIQ=NDIQ-1
61250 ENDIF
61251
61252C...If four quark ends, join two to diquark.
61253 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
61254 I1=1
61255 I2=2
61256 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
61257 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
61258 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61259 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61260 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61261 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61262 KFQ(I2)=KFQ(4)
61263 NQ=3
61264 NDIQ=1
61265 ENDIF
61266
61267C...If two quark ends, plus quark or diquark, join quarks to diquark.
61268 IF(NQ.EQ.3) THEN
61269 I1=1
61270 I2=2
61271 IF(IABS(KFQ(I1)).GT.1000) I1=3
61272 IF(IABS(KFQ(I2)).GT.1000) I2=3
61273 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61274 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61275 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61276 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61277 KFQ(I2)=KFQ(3)
61278 NQ=2
61279 NDIQ=NDIQ+1
61280 ENDIF
61281
61282C...Form two particles from flavours of lowest-mass system, if feasible.
61283 NTRY = 0
61284 790 NTRY = NTRY + 1
61285
61286C...Open string with two specified endpoint flavours.
61287 IF(NQ.EQ.2) THEN
61288 KC1=PYCOMP(KFQ(1))
61289 KC2=PYCOMP(KFQ(2))
61290 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
61291 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61292 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61293 IF(KQ1+KQ2.NE.0) GOTO 1140
61294C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
61295 800 K1=KFQ(1)
61296 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
61297 MSTU(125)=0
61298 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
61299 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
61300 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
61301
61302C...Open string with four specified flavours.
61303 ELSEIF(NQ.EQ.4) THEN
61304 KC1=PYCOMP(KFQ(1))
61305 KC2=PYCOMP(KFQ(2))
61306 KC3=PYCOMP(KFQ(3))
61307 KC4=PYCOMP(KFQ(4))
61308 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
61309 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61310 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61311 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
61312 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
61313 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
61314C...Combine flavours pairwise to form two hadrons.
61315 810 I1=1
61316 I2=2
61317 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61318 & IABS(KFQ(2)).GT.1000)) I2=3
61319 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61320 & IABS(KFQ(3)).GT.1000))) I2=4
61321 I3=3
61322 IF(I2.EQ.3) I3=2
61323 I4=10-I1-I2-I3
61324 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
61325 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
61326 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
61327
61328C...Closed string.
61329 ELSE
61330 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
61331C...No room for popcorn mesons in closed string -> 2 hadrons.
61332 MSTU(125)=0
61333 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
61334 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
61335 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
61336 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
61337 ENDIF
61338 P(N+2,5)=PYMASS(K(N+2,2))
61339 P(N+3,5)=PYMASS(K(N+3,2))
61340
61341C...If it does not work: try again (a number of times), give up (if no
61342C...place to shuffle momentum or too many flavours), or form one hadron.
61343 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
61344 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
61345 GOTO 790
61346 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
61347 GOTO 1140
61348 ELSE
61349 GOTO 890
61350 END IF
61351 END IF
61352
61353C...Perform two-particle decay of jet system.
61354C...First step: find reference axis in decaying system rest frame.
61355C...(Borrow slot N+2 for temporary direction.)
61356 DO 830 J=1,4
61357 P(N+2,J)=P(IC1,J)
61358 830 CONTINUE
61359 DO 850 I=IC1+1,IC2-1
61360 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61361 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61362 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
61363 DO 840 J=1,4
61364 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
61365 840 CONTINUE
61366 ENDIF
61367 850 CONTINUE
61368 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
61369 &-DPC(3)/DPC(4))
61370 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
61371 PHI1=PYANGL(P(N+2,1),P(N+2,2))
61372
61373C...Second step: generate isotropic/anisotropic decay.
61374 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
61375 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
61376 860 UE(3)=PYR(0)
61377 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
61378 PT2=(1D0-UE(3)**2)*PA**2
61379 IF(MSTJ(16).LE.0) THEN
61380 PREV=0.5D0
61381 ELSE
61382 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
61383 PR1=P(N+2,5)**2+PT2
61384 PR2=P(N+3,5)**2+PT2
61385 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
61386 PREVCF=PARJ(42)
61387 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61388 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
61389 ENDIF
61390 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
61391 PHI=PARU(2)*PYR(0)
61392 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
61393 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
61394 DO 870 J=1,3
61395 P(N+2,J)=PA*UE(J)
61396 P(N+3,J)=-PA*UE(J)
61397 870 CONTINUE
61398 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
61399 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
61400
61401C...Third step: move back to event frame and set production vertex.
61402 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
61403 &DPC(3)/DPC(4))
61404 DO 880 J=1,4
61405 V(N+1,J)=V(IC1,J)
61406 V(N+2,J)=V(IC1,J)
61407 V(N+3,J)=V(IC2,J)
61408 880 CONTINUE
61409 N=N+3
61410 GOTO 1120
61411
61412C...Else form one particle, if possible.
61413 890 NBODY=1
61414 K(N+1,5)=N+2
61415 DO 900 J=1,4
61416 V(N+1,J)=V(IC1,J)
61417 V(N+2,J)=V(IC1,J)
61418 900 CONTINUE
61419
61420C...Select hadron flavour from available quark flavours.
61421 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
61422 GOTO 1140
61423 ELSEIF(NQ.EQ.2) THEN
61424 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
61425 ELSE
61426 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
61427 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
61428 ENDIF
61429 IF(K(N+2,2).EQ.0) GOTO 910
61430 P(N+2,5)=PYMASS(K(N+2,2))
61431
61432C...Use old algorithm for E/p conservation? (EN)
61433 IF (MSTJ(16).LE.0) GOTO 1080
61434
61435C...Find the string piece closest to the cluster by a loop
61436C...over the undecayed partons not in present cluster. (EN)
61437 DGLOMI=1D30
61438 IBEG=0
61439 I0=0
61440 NJUNC=0
61441 DO 940 I1=MAX(1,IP),N-1
61442 IF(K(I1,1).EQ.1) NJUNC=0
61443 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
61444 IF(K(I1,1).EQ.41) GOTO 940
61445 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
61446 I0=0
61447 ELSEIF(K(I1,1).EQ.2) THEN
61448 IF(I0.EQ.0) I0=I1
61449 I2=I1
61450 920 I2=I2+1
61451 IF(K(I2,1).EQ.41) GOTO 940
61452 IF(K(I2,1).GT.10) GOTO 920
61453 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
61454 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
61455 & NJUNC.EQ.0) GOTO 940
61456 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
61457 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
61458 & K(I2,1).NE.1)) GOTO 940
61459
61460C...Define velocity vectors e1, e2, ecl and differences e3, e4.
61461 DO 930 J=1,3
61462 E1(J)=P(I1,J)/P(I1,4)
61463 E2(J)=P(I2,J)/P(I2,4)
61464 ECL(J)=P(N+1,J)/P(N+1,4)
61465 E3(J)=E2(J)-E1(J)
61466 E4(J)=ECL(J)-E1(J)
61467 930 CONTINUE
61468
61469C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
61470 E3S=E3(1)**2+E3(2)**2+E3(3)**2
61471 E4S=E4(1)**2+E4(2)**2+E4(3)**2
61472 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
61473 IF(E34.LE.0D0) THEN
61474 DDMIN=E4S
61475 ELSEIF(E34.LT.E3S) THEN
61476 DDMIN=E4S-E34**2/E3S
61477 ELSE
61478 DDMIN=E4S-2D0*E34+E3S
61479 ENDIF
61480
61481C...Is this the smallest so far?
61482 IF(DDMIN.LT.DGLOMI) THEN
61483 DGLOMI=DDMIN
61484 IBEG=I0
61485 IPCS=I1
61486 ENDIF
61487 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
61488 I0=0
61489 ENDIF
61490 940 CONTINUE
61491
61492C... Check if there are any strings to connect to the new gluon. (EN)
61493 IF (IBEG.EQ.0) GOTO 1080
61494
61495C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
61496 IF (P(N+1,5).GE.P(N+2,5)) THEN
61497
61498C...Construct 'gluon' that is needed to put hadron on the mass shell.
61499 FRAC=P(N+2,5)/P(N+1,5)
61500 DO 950 J=1,5
61501 P(N+2,J)=FRAC*P(N+1,J)
61502 PG(J)=(1D0-FRAC)*P(N+1,J)
61503 950 CONTINUE
61504
61505C... Copy string with new gluon put in.
61506 N=N+2
61507 I=IBEG-1
61508 960 I=I+1
61509 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
61510 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
61511 N=N+1
61512 DO 970 J=1,5
61513 K(N,J)=K(I,J)
61514 P(N,J)=P(I,J)
61515 V(N,J)=V(I,J)
61516 970 CONTINUE
61517 K(I,1)=K(I,1)+10
61518 K(I,4)=N
61519 K(I,5)=N
61520 K(N,3)=I
61521 IF(I.EQ.IPCS) THEN
61522 N=N+1
61523 DO 980 J=1,5
61524 K(N,J)=K(N-1,J)
61525 P(N,J)=PG(J)
61526 V(N,J)=V(N-1,J)
61527 980 CONTINUE
61528 K(N,2)=21
61529 K(N,3)=NSAV+1
61530 ENDIF
61531 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
61532 GOTO 1120
61533
61534C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
61535C...from string piece endpoints.
61536 ELSE
61537
61538C...Begin by copying string that should give energy to cluster.
61539 N=N+2
61540 I=IBEG-1
61541 990 I=I+1
61542 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
61543 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
61544 N=N+1
61545 DO 1000 J=1,5
61546 K(N,J)=K(I,J)
61547 P(N,J)=P(I,J)
61548 V(N,J)=V(I,J)
61549 1000 CONTINUE
61550 K(I,1)=K(I,1)+10
61551 K(I,4)=N
61552 K(I,5)=N
61553 K(N,3)=I
61554 IF(I.EQ.IPCS) I1=N
61555 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
61556 I2=I1+1
61557
61558C...Set initial Phad.
61559 DO 1010 J=1,4
61560 P(NSAV+2,J)=P(NSAV+1,J)
61561 1010 CONTINUE
61562
61563C...Calculate Pg, a part of which will be added to Phad later. (EN)
61564 1020 IF(MSTJ(16).EQ.1) THEN
61565 ALPHA=1D0
61566 BETA=1D0
61567 ELSE
61568 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
61569 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
61570 ENDIF
61571 DO 1030 J=1,4
61572 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
61573 1030 CONTINUE
61574 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
61575
61576C..Solve 2nd order equation, use the best (smallest) solution. (EN)
61577 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
61578 & P(NSAV+2,3)**2
61579 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
61580 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
61581 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
61582
61583C...If all gluon energy eaten, zero it and take a step back.
61584 ITER=0
61585 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
61586 ITER=1
61587 DO 1040 J=1,4
61588 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
61589 P(I1,J)=0D0
61590 1040 CONTINUE
61591 P(I1,5)=0D0
61592 K(I1,1)=K(I1,1)+10
61593 I1=I1-1
61594 IF(K(I1,1).EQ.41) ITER=-1
61595 ENDIF
61596 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
61597 ITER=1
61598 DO 1050 J=1,4
61599 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
61600 P(I2,J)=0D0
61601 1050 CONTINUE
61602 P(I2,5)=0D0
61603 K(I2,1)=K(I2,1)+10
61604 I2=I2+1
61605 IF(K(I2,1).EQ.41) ITER=-1
61606 ENDIF
61607 IF(ITER.EQ.1) GOTO 1020
61608
61609C...If also all endpoint energy eaten, revert to old procedure.
61610 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
61611 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
61612 DO 1060 I=NSAV+3,N
61613 IM=K(I,3)
61614 K(IM,1)=K(IM,1)-10
61615 K(IM,4)=0
61616 K(IM,5)=0
61617 1060 CONTINUE
61618 N=NSAV
61619 GOTO 1080
61620 ENDIF
61621
61622C... Construct the collapsed hadron and modified string partons.
61623 DO 1070 J=1,4
61624 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
61625 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
61626 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
61627 1070 CONTINUE
61628 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
61629 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
61630
61631C...Finished with string collapse in new scheme.
61632 GOTO 1120
61633 ENDIF
61634
61635C... Use old algorithm; by choice or when in trouble.
61636 1080 CONTINUE
61637C...Find parton/particle which combines to largest extra mass.
61638 IR=0
61639 HA=0D0
61640 HSM=0D0
61641 DO 1100 MCOMB=1,3
61642 IF(IR.NE.0) GOTO 1100
61643 DO 1090 I=MAX(1,IP),N
61644 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
61645 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
61646 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
61647 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
61648 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
61649 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
61650 & GOTO 1090
61651 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
61652 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
61653 IF(HSR.GT.HSM) THEN
61654 IR=I
61655 HA=HCR
61656 HSM=HSR
61657 ENDIF
61658 1090 CONTINUE
61659 1100 CONTINUE
61660
61661C...Shuffle energy and momentum to put new particle on mass shell.
61662 IF(IR.NE.0) THEN
61663 HB=PECM**2+HA
61664 HC=P(N+2,5)**2+HA
61665 HD=P(IR,5)**2+HA
61666 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
61667 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
61668 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
61669 DO 1110 J=1,4
61670 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
61671 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
61672 1110 CONTINUE
61673 N=N+2
61674 ELSE
61675 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
61676 RETURN
61677 ENDIF
61678
61679C...Mark collapsed system and store daughter pointers. Iterate.
61680 1120 DO 1130 I=IC1,IC2
61681 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61682 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61683 K(I,1)=K(I,1)+10
61684 IF(MSTU(16).NE.2) THEN
61685 K(I,4)=NSAV+1
61686 K(I,5)=NSAV+1
61687 ELSE
61688 K(I,4)=NSAV+2
61689 K(I,5)=NSAV+1+NBODY
61690 ENDIF
61691 ENDIF
61692 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
61693 1130 CONTINUE
61694 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
61695
61696C...Check flavours and invariant masses in parton systems.
61697 1140 NP=0
61698 KFN=0
61699 KQS=0
61700 NJU=0
61701 DO 1150 J=1,5
61702 DPS(J)=0D0
61703 1150 CONTINUE
61704 DO 1180 I=MAX(1,IP),N
61705 IF(K(I,1).EQ.41) NJU=NJU+1
61706 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
61707 KC=PYCOMP(K(I,2))
61708 IF(KC.EQ.0) GOTO 1180
61709 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61710 IF(KQ.EQ.0) GOTO 1180
61711 NP=NP+1
61712 IF(KQ.NE.2) THEN
61713 KFN=KFN+1
61714 KQS=KQS+KQ
61715 MSTJ(93)=1
61716 DPS(5)=DPS(5)+PYMASS(K(I,2))
61717 ENDIF
61718 DO 1160 J=1,4
61719 DPS(J)=DPS(J)+P(I,J)
61720 1160 CONTINUE
61721 IF(K(I,1).EQ.1) THEN
61722 NFERR=0
61723 IF(NJU.EQ.0.AND.NP.NE.1) THEN
61724 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
61725 ELSEIF(NJU.EQ.1) THEN
61726 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
61727 ELSEIF(NJU.EQ.2) THEN
61728 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
61729 ELSEIF(NJU.GE.3) THEN
61730 NFERR=1
61731 ENDIF
61732 IF(NFERR.EQ.1) THEN
61733 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
61734 MINT(51)=1
61735 RETURN
61736 ENDIF
61737 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
61738 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
61739 & '(PYPREP:) too small mass in jet system')
61740 NP=0
61741 KFN=0
61742 KQS=0
61743 NJU=0
61744 DO 1170 J=1,5
61745 DPS(J)=0D0
61746 1170 CONTINUE
61747 ENDIF
61748 1180 CONTINUE
61749
61750 RETURN
61751 END
61752
61753C*********************************************************************
61754
61755C...PYSTRF
61756C...Handles the fragmentation of an arbitrary colour singlet
61757C...jet system according to the Lund string fragmentation model.
61758
61759 SUBROUTINE PYSTRF(IP)
61760
61761C...Double precision and integer declarations.
61762 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61763 IMPLICIT INTEGER(I-N)
61764 INTEGER PYK,PYCHGE,PYCOMP
61765C...Commonblocks.
61766 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61767 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61768 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61769 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61770C...Local arrays. All MOPS variables ends with MO
61771 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
61772 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
61773 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
61774 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
61775 &PBST(3,5),TJUOLD(5)
61776
61777C...Function: four-product of two vectors.
61778 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)
61779 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
61780 &DP(I,3)*DP(J,3)
61781
61782C...Reset counters.
61783 MSTJ(91)=0
61784 NSAV=N
61785 MSTU90=MSTU(90)
61786 NP=0
61787 KQSUM=0
61788 DO 100 J=1,5
61789 DPS(J)=0D0
61790 100 CONTINUE
61791 MJU(1)=0
61792 MJU(2)=0
61793 NTRYFN=0
61794 IJUORI(1)=0
61795 IJUORI(2)=0
61796
61797C...Identify parton system.
61798 I=IP-1
61799 110 I=I+1
61800 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61801 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
61802 IF(MSTU(21).GE.1) RETURN
61803 ENDIF
61804 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
61805 KC=PYCOMP(K(I,2))
61806 IF(KC.EQ.0) GOTO 110
61807 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61808 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
61809 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
61810 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61811 IF(MSTU(21).GE.1) RETURN
61812 ENDIF
61813
61814C...Take copy of partons to be considered. Check flavour sum.
61815 NP=NP+1
61816 DO 120 J=1,5
61817 K(N+NP,J)=K(I,J)
61818 P(N+NP,J)=P(I,J)
61819 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
61820 120 CONTINUE
61821 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
61822 K(N+NP,3)=I
61823 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61824 IF(K(I,1).EQ.41) THEN
61825 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
61826 MJU(1)=N+NP
61827 IJUORI(1)=I
61828 ELSE
61829 MJU(2)=N+NP
61830 IJUORI(2)=I
61831 ENDIF
61832 ENDIF
61833 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
61834 IF(MOD(KQSUM,3).NE.0) THEN
61835 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
61836 IF(MSTU(21).GE.1) RETURN
61837 ENDIF
61838 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
61839
61840C...Boost copied system to CM frame (for better numerical precision).
61841 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
61842 MBST=0
61843 MSTU(33)=1
61844 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
61845 & -DPS(3)/DPS(4))
61846 ELSE
61847 MBST=1
61848 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
61849 DO 130 I=N+1,N+NP
61850 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61851 IF(P(I,3).GT.0D0) THEN
61852 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
61853 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61854 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61855 ELSE
61856 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
61857 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61858 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61859 ENDIF
61860 130 CONTINUE
61861 ENDIF
61862
61863C...Search for very nearby partons that may be recombined.
61864 NTRYR=0
61865 NTRYWR=0
61866 PARU12=PARU(12)
61867 PARU13=PARU(13)
61868 MJU(3)=MJU(1)
61869 MJU(4)=MJU(2)
61870 NR=NP
61871 NRMIN=2
61872 IF(MJU(1).GT.0) NRMIN=NRMIN+2
61873 IF(MJU(2).GT.0) NRMIN=NRMIN+2
61874 140 IF(NR.GT.NRMIN) THEN
61875 PDRMIN=2D0*PARU12
61876 DO 150 I=N+1,N+NR
61877 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
61878 I1=I+1
61879 IF(I.EQ.N+NR) I1=N+1
61880 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
61881 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
61882 & GOTO 150
61883 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
61884 & GOTO 150
61885 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
61886 & P(I1,2)**2+P(I1,3)**2))
61887 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
61888 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
61889 IF(PDR.LT.PDRMIN) THEN
61890 IR=I
61891 PDRMIN=PDR
61892 ENDIF
61893 150 CONTINUE
61894
61895C...Recombine very nearby partons to avoid machine precision problems.
61896 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
61897 DO 160 J=1,4
61898 P(N+1,J)=P(N+1,J)+P(N+NR,J)
61899 160 CONTINUE
61900 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
61901 & P(N+1,3)**2))
61902 NR=NR-1
61903 GOTO 140
61904 ELSEIF(PDRMIN.LT.PARU12) THEN
61905 DO 170 J=1,4
61906 P(IR,J)=P(IR,J)+P(IR+1,J)
61907 170 CONTINUE
61908 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
61909 & P(IR,3)**2))
61910 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
61911 DO 190 I=IR+1,N+NR-1
61912 K(I,1)=K(I+1,1)
61913 K(I,2)=K(I+1,2)
61914 DO 180 J=1,5
61915 P(I,J)=P(I+1,J)
61916 180 CONTINUE
61917 190 CONTINUE
61918 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
61919 NR=NR-1
61920 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
61921 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
61922 GOTO 140
61923 ENDIF
61924 ENDIF
61925 NTRYR=NTRYR+1
61926
61927C...Reset particle counter. Skip ahead if no junctions are present;
61928C...this is usually the case!
61929 NRS=MAX(5*NR+11,NP)
61930 NTRY=0
61931 200 NTRY=NTRY+1
61932 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61933 PARU12=4D0*PARU12
61934 PARU13=2D0*PARU13
61935 GOTO 140
61936 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
61937 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61938 IF(MSTU(21).GE.1) RETURN
61939 ENDIF
61940 I=N+NRS
61941 MSTU(90)=MSTU90
61942 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
61943 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
61944 & ' junction strings not handled by MSTJ(12)>3 options')
61945 DO 640 JT=1,2
61946 NJS(JT)=0
61947 IF(MJU(JT).EQ.0) GOTO 640
61948 JS=3-2*JT
61949
61950C++SKANDS
61951C...Find and sum up momentum on three sides of junction.
61952C...Begin with previous boost = zero.
61953 IJRFIT=0
61954 DO 210 IX=1,3
61955 TJUOLD(IX)=0D0
61956 210 CONTINUE
61957 TJUOLD(4)=1D0
61958 220 IU=0
61959C...Beginning and end of string system in event record.
61960 I1BEG=N+1+(JT-1)*(NR-1)
61961 I1END=N+NR+(JT-1)*(1-NR)
61962C...Look for junction string piece end points
61963 DO 230 I1=I1BEG,I1END,JS
61964 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
61965C...Store junction string piece end points.
61966C 1-junction systems 2-junction systems
61967C IU : 1 2 3 4 1 2 3 4 5 6
61968C 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
61969 IU=IU+1
61970 IJU(IU)=I1
61971 ENDIF
61972C...Sum over momenta, from junction outwards.
61973 230 CONTINUE
61974 DO 280 IU=1,3
61975 PWT=0D0
61976C...Initialize junction drag and string piece 4-vectors.
61977 DO 240 J=1,5
61978 PBST(IU,J)=0D0
61979 PJU(IU,J)=0D0
61980 240 CONTINUE
61981C...First two branches. Inwards out means opposite direction to JS.
61982C...(JS is 1 for JT=1, -1 for JT=2)
61983 IF (IU.LT.3) THEN
61984 I1A=IJU(IU+1)-JS
61985 I1B=IJU(IU)
61986 IDIR=-JS
61987C...Last branch (gq or gjgqgq). Direction now reversed.
61988 ELSE
61989 I1A=IJU(IU)+JS
61990 I1B=I1END
61991 IDIR=JS
61992 ENDIF
61993 DO 270 I1=I1A,I1B,IDIR
61994C...Sum up momentum directions with exponential suppression
61995C...for use in finding junction rest frame below.
61996 IF (K(I1,2).EQ.88) THEN
61997C...gjgqgq type system encountered. Use current PWT as start
61998C...for both strings.
61999 PWTOLD=PWT
62000 ELSE
62001 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
62002C...Sum up string piece (boosted) 4-momenta.
62003 DO 250 J=1,4
62004 PJU(IU,J)=PJU(IU,J)+P(I1,J)
62005 250 CONTINUE
62006C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
62007C...boost is zero, see above). Skip parton if suppression factor large.
62008 IF (PWT.GT.10D0) GOTO 270
62009C...Compute momentum in current frame:
62010 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
62011 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
62012 DO 260 J=1,3
62013 PTMP=P(I1,J)+TJUOLD(J)*BFC
62014 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
62015 260 CONTINUE
62016C...Boosted energy
62017 PTMP=TJUOLD(4)*P(I1,4)+TDP
62018 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
62019 PWT=PWT+PTMP/PARJ(48)
62020 ENDIF
62021 270 CONTINUE
62022C...Put |p| rather than m in 5th slot.
62023 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
62024 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
62025 280 CONTINUE
62026
62027C...Calculate boost from present frame to next JRF candidate.
62028 IJRFIT=IJRFIT+1
62029 CALL PYJURF(PBST,TJU)
62030
62031C...After some iterations do not take full step in new direction.
62032 IF(IJRFIT.GT.5) THEN
62033 REDUCE=0.8D0**(IJRFIT-5)
62034 TJU(1)=REDUCE*TJU(1)
62035 TJU(2)=REDUCE*TJU(2)
62036 TJU(3)=REDUCE*TJU(3)
62037 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62038 ENDIF
62039
62040C...Combine new boost (TJU) with old boost (TJUOLD)
62041 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
62042 DO 290 IX=1,3
62043 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
62044 290 CONTINUE
62045 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
62046
62047C...If last boost small, accept JRF, else iterate.
62048C...Also prevent possibility of infinite loop.
62049 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
62050 & IJRFIT.LT.MSTJ(18)) THEN
62051 GOTO 220
62052 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
62053 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
62054 ENDIF
62055
62056C...Now store total boost in TJU and change perception.
62057C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
62058C...TJU = junction motion vector in string CM, so the sign changes.
62059 DO 300 J=1,3
62060 TJU(J)=-TJUOLD(J)
62061 300 CONTINUE
62062 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62063
62064C--SKANDS
62065
62066C...Calculate string piece energies in junction rest frame.
62067 DO 310 IU=1,3
62068 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
62069 & TJU(3)*PJU(IU,3)
62070 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
62071 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
62072 310 CONTINUE
62073
62074C...Start preparing for fragmentation of two strings from junction.
62075 ISTA=I
62076 NTRYER=0
62077 320 NTRYER=NTRYER+1
62078 I=ISTA
62079 DO 620 IU=1,2
62080 NS=IABS(IJU(IU+1)-IJU(IU))
62081
62082C...Junction strings: find longitudinal string directions.
62083 DO 350 IS=1,NS
62084 IS1=IJU(IU)+JS*(IS-1)
62085 IS2=IJU(IU)+JS*IS
62086 DO 330 J=1,5
62087 DP(1,J)=0.5D0*P(IS1,J)
62088 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
62089 DP(2,J)=0.5D0*P(IS2,J)
62090 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
62091 & (PJU(IU,5)/PBST(IU,5))
62092 330 CONTINUE
62093 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
62094 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
62095 DP(3,5)=DFOUR(1,1)
62096 DP(4,5)=DFOUR(2,2)
62097 DHKC=DFOUR(1,2)
62098 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
62099 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62100 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62101 DP(3,5)=0D0
62102 DP(4,5)=0D0
62103 DHKC=DFOUR(1,2)
62104 ENDIF
62105 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62106 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62107 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62108 IN1=N+NR+4*IS-3
62109 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62110 DO 340 J=1,4
62111 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62112 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62113 340 CONTINUE
62114 350 CONTINUE
62115
62116C...Junction strings: initialize flavour, momentum and starting pos.
62117 ISAV=I
62118 MSTU91=MSTU(90)
62119 360 NTRY=NTRY+1
62120 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62121 PARU12=4D0*PARU12
62122 PARU13=2D0*PARU13
62123 GOTO 140
62124 ELSEIF(NTRY.GT.100) THEN
62125 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62126 IF(MSTU(21).GE.1) RETURN
62127 ENDIF
62128 I=ISAV
62129 MSTU(90)=MSTU91
62130 IRANKJ=0
62131 IE(1)=K(N+1+(JT/2)*(NP-1),3)
62132 IF (MOD(JT+IU,2).NE.0) THEN
62133 IE(1)=K(IJU(IU),3)
62134 IF (NP-NR.NE.0) THEN
62135C...If gluons have disappeared. Original IJU must be used.
62136 IT=IP
62137 NE=1
62138 370 IT=IT+1
62139 IF (K(IT,2).NE.21) THEN
62140 NE=NE+1
62141 ENDIF
62142 IF (NE.EQ.IU+4*(JT-1)) THEN
62143 IE(1)=IT
62144 ELSEIF (IT.LE.IP+NP) THEN
62145 GOTO 370
62146 ELSE
62147 CALL PYERRM(14,'(PYSTRF:) '//
62148 & 'Original IJU could not be reconstructed!')
62149 ENDIF
62150 ENDIF
62151 ENDIF
62152 IN(4)=N+NR+1
62153 IN(5)=IN(4)+1
62154 IN(6)=N+NR+4*NS+1
62155 DO 390 JQ=1,2
62156 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
62157 P(IN1,1)=2-JQ
62158 P(IN1,2)=JQ-1
62159 P(IN1,3)=1D0
62160 380 CONTINUE
62161 390 CONTINUE
62162 KFL(1)=K(IJU(IU),2)
62163 PX(1)=0D0
62164 PY(1)=0D0
62165 GAM(1)=0D0
62166 DO 400 J=1,5
62167 PJU(IU+3,J)=0D0
62168 400 CONTINUE
62169
62170C...Junction strings: find initial transverse directions.
62171 DO 410 J=1,4
62172 DP(1,J)=P(IN(4),J)
62173 DP(2,J)=P(IN(4)+1,J)
62174 DP(3,J)=0D0
62175 DP(4,J)=0D0
62176 410 CONTINUE
62177 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62178 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62179 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62180 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62181 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62182 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62183 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62184 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62185 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62186 DHC12=DFOUR(1,2)
62187 DHCX1=DFOUR(3,1)/DHC12
62188 DHCX2=DFOUR(3,2)/DHC12
62189 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62190 DHCY1=DFOUR(4,1)/DHC12
62191 DHCY2=DFOUR(4,2)/DHC12
62192 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62193 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62194 DO 420 J=1,4
62195 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62196 P(IN(6),J)=DP(3,J)
62197 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62198 & DHCYX*DP(3,J))
62199 420 CONTINUE
62200
62201C...Junction strings: produce new particle, origin.
62202 430 I=I+1
62203 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62204 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62205 IF(MSTU(21).GE.1) RETURN
62206 ENDIF
62207 IRANKJ=IRANKJ+1
62208 K(I,1)=1
62209 K(I,3)=IE(1)
62210 K(I,4)=0
62211 K(I,5)=0
62212
62213C...Junction strings: generate flavour, hadron, pT, z and Gamma.
62214 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
62215 IF(K(I,2).EQ.0) GOTO 360
62216 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
62217 & IABS(KFL(3)).GT.10) THEN
62218 IF(PYR(0).GT.PARJ(19)) GOTO 440
62219 ENDIF
62220 P(I,5)=PYMASS(K(I,2))
62221 CALL PYPTDI(KFL(1),PX(3),PY(3))
62222 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
62223 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
62224 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
62225 & MSTU(90).LT.8) THEN
62226 MSTU(90)=MSTU(90)+1
62227 MSTU(90+MSTU(90))=I
62228 PARU(90+MSTU(90))=Z
62229 ENDIF
62230 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
62231 DO 450 J=1,3
62232 IN(J)=IN(3+J)
62233 450 CONTINUE
62234
62235C...Junction strings: stepping within 'low' string region.
62236 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62237 & P(IN(1),5)**2.GE.PR(1)) THEN
62238 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
62239 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
62240 DO 460 J=1,4
62241 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
62242 460 CONTINUE
62243 GOTO 560
62244C...Has used up energy of junction string, i.e. no more hadrons in it.
62245 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
62246 DO 470 J=1,5
62247 P(I,J)=0D0
62248 470 CONTINUE
62249 GOTO 600
62250C...Stepping from 'low' string region
62251 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62252 P(IN(2)+2,4)=P(IN(2)+2,3)
62253 P(IN(2)+2,1)=1D0
62254 IN(2)=IN(2)+4
62255 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62256 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62257 P(IN(1)+2,4)=P(IN(1)+2,3)
62258 P(IN(1)+2,1)=0D0
62259 IN(1)=IN(1)+4
62260 ENDIF
62261 ENDIF
62262
62263C...Junction strings: find new transverse directions.
62264 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
62265 & IN(1).GT.IN(2)) GOTO 360
62266 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
62267 DO 490 J=1,4
62268 DP(1,J)=P(IN(1),J)
62269 DP(2,J)=P(IN(2),J)
62270 DP(3,J)=0D0
62271 DP(4,J)=0D0
62272 490 CONTINUE
62273 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62274 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62275 DHC12=DFOUR(1,2)
62276 IF(DHC12.LE.1D-2) THEN
62277 P(IN(1)+2,4)=P(IN(1)+2,3)
62278 P(IN(1)+2,1)=0D0
62279 IN(1)=IN(1)+4
62280 GOTO 480
62281 ENDIF
62282 IN(3)=N+NR+4*NS+5
62283 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62284 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62285 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62286 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62287 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62288 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62289 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62290 DHCX1=DFOUR(3,1)/DHC12
62291 DHCX2=DFOUR(3,2)/DHC12
62292 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62293 DHCY1=DFOUR(4,1)/DHC12
62294 DHCY2=DFOUR(4,2)/DHC12
62295 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62296 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62297 DO 500 J=1,4
62298 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62299 P(IN(3),J)=DP(3,J)
62300 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62301 & DHCYX*DP(3,J))
62302 500 CONTINUE
62303C...Express pT with respect to new axes, if sensible.
62304 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
62305 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
62306 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62307 PX(3)=PXP
62308 PY(3)=PYP
62309 ENDIF
62310 ENDIF
62311
62312C...Junction strings: sum up known four-momentum, coefficients for m2.
62313 DO 530 J=1,4
62314 DHG(J)=0D0
62315 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
62316 & PY(3)*P(IN(3)+1,J)
62317 DO 510 IN1=IN(4),IN(1)-4,4
62318 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62319 510 CONTINUE
62320 DO 520 IN2=IN(5),IN(2)-4,4
62321 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62322 520 CONTINUE
62323 530 CONTINUE
62324 DHM(1)=FOUR(I,I)
62325 DHM(2)=2D0*FOUR(I,IN(1))
62326 DHM(3)=2D0*FOUR(I,IN(2))
62327 DHM(4)=2D0*FOUR(IN(1),IN(2))
62328
62329C...Junction strings: find coefficients for Gamma expression.
62330 DO 550 IN2=IN(1)+1,IN(2),4
62331 DO 540 IN1=IN(1),IN2-1,4
62332 DHC=2D0*FOUR(IN1,IN2)
62333 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
62334 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
62335 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
62336 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62337 540 CONTINUE
62338 550 CONTINUE
62339
62340C...Junction strings: solve (m2, Gamma) equation system for energies.
62341 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
62342 IF(ABS(DHS1).LT.1D-4) GOTO 360
62343 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
62344 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
62345 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
62346 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62347 & ABS(DHS1)-DHS2/DHS1)
62348 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
62349 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
62350 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
62351
62352C...Junction strings: step to new region if necessary.
62353 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
62354 P(IN(2)+2,4)=P(IN(2)+2,3)
62355 P(IN(2)+2,1)=1D0
62356 IN(2)=IN(2)+4
62357 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62358 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62359 P(IN(1)+2,4)=P(IN(1)+2,3)
62360 P(IN(1)+2,1)=0D0
62361 IN(1)=IN(1)+4
62362 ENDIF
62363 GOTO 480
62364 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
62365 P(IN(1)+2,4)=P(IN(1)+2,3)
62366 P(IN(1)+2,1)=0D0
62367 IN(1)=IN(1)+4
62368 GOTO 480
62369 ENDIF
62370
62371C...Junction strings: particle four-momentum, remainder, loop back.
62372 560 DO 570 J=1,4
62373 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
62374 & P(IN(2)+2,4)*P(IN(2),J)
62375 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
62376 570 CONTINUE
62377 IF(P(I,4).LT.P(I,5)) GOTO 360
62378 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62379 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62380 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
62381 KFL(1)=-KFL(3)
62382 PX(1)=-PX(3)
62383 PY(1)=-PY(3)
62384 GAM(1)=GAM(3)
62385 IF(IN(3).NE.IN(6)) THEN
62386 DO 580 J=1,4
62387 P(IN(6),J)=P(IN(3),J)
62388 P(IN(6)+1,J)=P(IN(3)+1,J)
62389 580 CONTINUE
62390 ENDIF
62391 DO 590 JQ=1,2
62392 IN(3+JQ)=IN(JQ)
62393 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62394 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
62395 590 CONTINUE
62396 GOTO 430
62397 ENDIF
62398
62399C...Junction strings: save quantities left after each string.
62400 IF(IABS(KFL(1)).GT.10) GOTO 360
62401 600 I=I-1
62402 KFJH(IU)=KFL(1)
62403 DO 610 J=1,4
62404 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
62405 610 CONTINUE
62406
62407C...Junction strings: loopback if much unused energy in both strings.
62408 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62409 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62410 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
62411 620 CONTINUE
62412 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
62413 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
62414 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
62415 & .AND.NTRYER.LT.10) GOTO 320
62416
62417C...Junction strings: put together to new effective string endpoint.
62418 NJS(JT)=I-ISTA
62419 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
62420 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
62421 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
62422 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
62423 DO 630 J=1,4
62424 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
62425 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
62426 630 CONTINUE
62427 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
62428 & PJS(JT,3)**2))
62429 PJS(JT+2,5)=0D0
62430 640 CONTINUE
62431
62432C...Open versus closed strings. Choose breakup region for latter.
62433 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
62434 NS=MJU(2)-MJU(1)
62435 NB=MJU(1)-N
62436 ELSEIF(MJU(1).NE.0) THEN
62437 NS=N+NR-MJU(1)
62438 NB=MJU(1)-N
62439 ELSEIF(MJU(2).NE.0) THEN
62440 NS=MJU(2)-N
62441 NB=1
62442 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
62443 NS=NR-1
62444 NB=1
62445 ELSE
62446 NS=NR+1
62447 W2SUM=0D0
62448 DO 660 IS=1,NR
62449 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
62450 W2SUM=W2SUM+P(N+NR+IS,1)
62451 660 CONTINUE
62452 W2RAN=PYR(0)*W2SUM
62453 NB=0
62454 670 NB=NB+1
62455 W2SUM=W2SUM-P(N+NR+NB,1)
62456 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
62457 ENDIF
62458
62459C...Find longitudinal string directions (i.e. lightlike four-vectors).
62460 DO 700 IS=1,NS
62461 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
62462 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
62463 DO 680 J=1,5
62464 DP(1,J)=P(IS1,J)
62465 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
62466 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
62467 DP(2,J)=P(IS2,J)
62468 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
62469 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
62470 680 CONTINUE
62471 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
62472 & DP(1,2)**2-DP(1,3)**2))
62473 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
62474 & DP(2,2)**2-DP(2,3)**2))
62475 DP(3,5)=DFOUR(1,1)
62476 DP(4,5)=DFOUR(2,2)
62477 DHKC=DFOUR(1,2)
62478 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
62479 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62480 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62481 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62482 IN1=N+NR+4*IS-3
62483 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62484 DO 690 J=1,4
62485 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62486 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62487 690 CONTINUE
62488 700 CONTINUE
62489
62490C...Begin initialization: sum up energy, set starting position.
62491 ISAV=I
62492 MSTU91=MSTU(90)
62493 710 NTRY=NTRY+1
62494 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62495 PARU12=4D0*PARU12
62496 PARU13=2D0*PARU13
62497 GOTO 140
62498 ELSEIF(NTRY.GT.100) THEN
62499 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62500 IF(MSTU(21).GE.1) RETURN
62501 ENDIF
62502 I=ISAV
62503 MSTU(90)=MSTU91
62504 DO 730 J=1,4
62505 P(N+NRS,J)=0D0
62506 DO 720 IS=1,NR
62507 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
62508 720 CONTINUE
62509 730 CONTINUE
62510 DO 750 JT=1,2
62511 IRANK(JT)=0
62512 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
62513 IF(NS.GT.NR) IRANK(JT)=1
62514 IBARRK(JT)=0
62515 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
62516 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
62517 IN(3*JT+2)=IN(3*JT+1)+1
62518 IN(3*JT+3)=N+NR+4*NS+2*JT-1
62519 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
62520 P(IN1,1)=2-JT
62521 P(IN1,2)=JT-1
62522 P(IN1,3)=1D0
62523 740 CONTINUE
62524 750 CONTINUE
62525
62526C.. MOPS variables and switches
62527 NRVMO=0
62528 XBMO=1D0
62529 MSTU(121)=0
62530 MSTU(122)=0
62531
62532C...Initialize flavour and pT variables for open string.
62533 IF(NS.LT.NR) THEN
62534 PX(1)=0D0
62535 PY(1)=0D0
62536 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
62537 PX(2)=-PX(1)
62538 PY(2)=-PY(1)
62539 DO 760 JT=1,2
62540 KFL(JT)=K(IE(JT),2)
62541 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
62542 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
62543 MSTJ(93)=1
62544 PMQ(JT)=PYMASS(KFL(JT))
62545 GAM(JT)=0D0
62546 760 CONTINUE
62547
62548C...Closed string: random initial breakup flavour, pT and vertex.
62549 ELSE
62550 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62551 IBMO=0
62552 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
62553C.. Closed string: first vertex diq attempt => enforced second
62554C.. vertex diq
62555 IF(IABS(KFL(1)).GT.10)THEN
62556 IBMO=1
62557 MSTU(121)=0
62558 GOTO 770
62559 ENDIF
62560 IF(IBMO.EQ.1) MSTU(121)=-1
62561 KFL(2)=-KFL(1)
62562 CALL PYPTDI(KFL(1),PX(1),PY(1))
62563 PX(2)=-PX(1)
62564 PY(2)=-PY(1)
62565 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
62566 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
62567 ZR=PR3/(Z*P(N+NR+1,5)**2)
62568 IF(ZR.GE.1D0) GOTO 780
62569 DO 790 JT=1,2
62570 MSTJ(93)=1
62571 PMQ(JT)=PYMASS(KFL(JT))
62572 GAM(JT)=PR3*(1D0-Z)/Z
62573 IN1=N+NR+3+4*(JT/2)*(NS-1)
62574 P(IN1,JT)=1D0-Z
62575 P(IN1,3-JT)=JT-1
62576 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
62577 P(IN1+1,JT)=ZR
62578 P(IN1+1,3-JT)=2-JT
62579 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
62580 790 CONTINUE
62581 ENDIF
62582C.. MOPS variables
62583 DO 800 JT=1,2
62584 XTMO(JT)=1D0
62585 PM2QMO(JT)=PMQ(JT)**2
62586 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
62587 800 CONTINUE
62588
62589C...Find initial transverse directions (i.e. spacelike four-vectors).
62590 DO 840 JT=1,2
62591 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
62592 IN1=IN(3*JT+1)
62593 IN3=IN(3*JT+3)
62594 DO 810 J=1,4
62595 DP(1,J)=P(IN1,J)
62596 DP(2,J)=P(IN1+1,J)
62597 DP(3,J)=0D0
62598 DP(4,J)=0D0
62599 810 CONTINUE
62600 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62601 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62602 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62603 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62604 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62605 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62606 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62607 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62608 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62609 DHC12=DFOUR(1,2)
62610 DHCX1=DFOUR(3,1)/DHC12
62611 DHCX2=DFOUR(3,2)/DHC12
62612 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62613 DHCY1=DFOUR(4,1)/DHC12
62614 DHCY2=DFOUR(4,2)/DHC12
62615 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62616 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62617 DO 820 J=1,4
62618 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62619 P(IN3,J)=DP(3,J)
62620 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62621 & DHCYX*DP(3,J))
62622 820 CONTINUE
62623 ELSE
62624 DO 830 J=1,4
62625 P(IN3+2,J)=P(IN3,J)
62626 P(IN3+3,J)=P(IN3+1,J)
62627 830 CONTINUE
62628 ENDIF
62629 840 CONTINUE
62630
62631C...Remove energy used up in junction string fragmentation.
62632 IF(MJU(1)+MJU(2).GT.0) THEN
62633 DO 860 JT=1,2
62634 IF(NJS(JT).EQ.0) GOTO 860
62635 DO 850 J=1,4
62636 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
62637 850 CONTINUE
62638 860 CONTINUE
62639 PARJST=PARJ(33)
62640 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62641 WMIN=PARJST+PMQ(1)+PMQ(2)
62642 WREM2=FOUR(N+NRS,N+NRS)
62643 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
62644 NTRYWR=NTRYWR+1
62645 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
62646 GOTO 140
62647 ENDIF
62648 ENDIF
62649
62650C...Produce new particle: side, origin.
62651 870 I=I+1
62652 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62653 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62654 IF(MSTU(21).GE.1) RETURN
62655 ENDIF
62656C.. New side priority for popcorn systems
62657 IF(MSTU(121).LE.0)THEN
62658 JT=1.5D0+PYR(0)
62659 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
62660 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
62661 ENDIF
62662 JR=3-JT
62663 JS=3-2*JT
62664 IRANK(JT)=IRANK(JT)+1
62665 K(I,1)=1
62666 K(I,4)=0
62667 K(I,5)=0
62668
62669C...Generate flavour, hadron and pT.
62670 880 K(I,3)=IE(JT)
62671 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
62672 IF(K(I,2).EQ.0) GOTO 710
62673 MU90MO=MSTU(90)
62674 IF(MSTU(121).EQ.-1) GOTO 910
62675 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
62676 &IABS(KFL(3)).GT.10) THEN
62677 IF(PYR(0).GT.PARJ(19)) GOTO 880
62678 ENDIF
62679 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62680 &K(I,3)=IJUORI(JT)
62681 P(I,5)=PYMASS(K(I,2))
62682 CALL PYPTDI(KFL(JT),PX(3),PY(3))
62683 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
62684
62685C...Final hadrons for small invariant mass.
62686 MSTJ(93)=1
62687 PMQ(3)=PYMASS(KFL(3))
62688 PARJST=PARJ(33)
62689 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62690 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
62691 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
62692 &WMIN-0.5D0*PARJ(36)*PMQ(3)
62693 WREM2=FOUR(N+NRS,N+NRS)
62694 IF(WREM2.LT.0.10D0) GOTO 710
62695 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
62696 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
62697
62698C...Choose z, which gives Gamma. Shift z for heavy flavours.
62699 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
62700 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
62701 &MSTU(90).LT.8) THEN
62702 MSTU(90)=MSTU(90)+1
62703 MSTU(90+MSTU(90))=I
62704 PARU(90+MSTU(90))=Z
62705 ENDIF
62706 KFL1A=IABS(KFL(1))
62707 KFL2A=IABS(KFL(2))
62708 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62709 &MOD(KFL2A/1000,10)).GE.4) THEN
62710 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62711 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
62712 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
62713 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62714 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
62715 ENDIF
62716 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
62717
62718C.. MOPS baryon model modification
62719 XTMO3=(1D0-Z)*XTMO(JT)
62720 IF(IABS(KFL(3)).LE.10) NRVMO=0
62721 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
62722 GTSTMO=1D0
62723 PTSTMO=1D0
62724 RTSTMO=PYR(0)
62725 IF(IABS(KFL(JT)).LE.10)THEN
62726 XBMO=MIN(XTMO3,1D0-(2D-10))
62727 GBMO=GAM(3)
62728 PMMO=0D0
62729 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
62730 GTSTMO=1D0-PARF(192)**PGMO
62731 ELSE
62732 IF(IRANK(JT).EQ.1) THEN
62733 GBMO=GAM(JT)
62734 PMMO=0D0
62735 XBMO=1D0
62736 ENDIF
62737 IF(XBMO.LT.1D0-(1D-10))THEN
62738 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
62739 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
62740 PGMO=PGNMO
62741 ENDIF
62742 IF(MSTJ(12).GE.5)THEN
62743 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
62744 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
62745 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
62746 PMMO=PMNMO
62747 ENDIF
62748 ENDIF
62749
62750C.. MOPS Accepting popcorn system hadron.
62751 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
62752 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
62753 NRVMO=I-N-NR
62754 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
62755 CALL PYERRM(11,
62756 & '(PYSTRF:) no more memory left in PYJETS')
62757 IF(MSTU(21).GE.1) RETURN
62758 ENDIF
62759 IMO=I
62760 KFLMO=KFL(JT)
62761 PMQMO=PMQ(JT)
62762 PXMO=PX(JT)
62763 PYMO=PY(JT)
62764 GAMMO=GAM(JT)
62765 IRMO=IRANK(JT)
62766 XMO=XTMO(JT)
62767 DO 900 J=1,9
62768 IF(J.LE.5) THEN
62769 DO 890 LINE=1,I-N-NR
62770 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
62771 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
62772 890 CONTINUE
62773 ENDIF
62774 INMO(J)=IN(J)
62775 900 CONTINUE
62776 ENDIF
62777 ELSE
62778C..Reject popcorn system, flag=-1 if enforcing new one
62779 MSTU(121)=-1
62780 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
62781 ENDIF
62782 ENDIF
62783
62784
62785C..Lift restoring string outside MOPS block
62786 910 IF(MSTU(121).LT.0) THEN
62787 IF(MSTU(121).EQ.-2) MSTU(121)=0
62788 MSTU(90)=MU90MO
62789 NRVMO=0
62790 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
62791 I=IMO
62792 KFL(JT)=KFLMO
62793 PMQ(JT)=PMQMO
62794 PX(JT)=PXMO
62795 PY(JT)=PYMO
62796 GAM(JT)=GAMMO
62797 IRANK(JT)=IRMO
62798 XTMO(JT)=XMO
62799 DO 930 J=1,9
62800 IF(J.LE.5) THEN
62801 DO 920 LINE=1,I-N-NR
62802 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
62803 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
62804 920 CONTINUE
62805 ENDIF
62806 IN(J)=INMO(J)
62807 930 CONTINUE
62808 GOTO 880
62809 ENDIF
62810 XTMO(JT)=XTMO3
62811C.. MOPS end of modification
62812
62813 DO 940 J=1,3
62814 IN(J)=IN(3*JT+J)
62815 940 CONTINUE
62816
62817C...Stepping within or from 'low' string region easy.
62818 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62819 &P(IN(1),5)**2.GE.PR(JT)) THEN
62820 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
62821 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
62822 DO 950 J=1,4
62823 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
62824 950 CONTINUE
62825 GOTO 1040
62826 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62827 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62828 P(IN(JR)+2,JT)=1D0
62829 IN(JR)=IN(JR)+4*JS
62830 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62831 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62832 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62833 P(IN(JT)+2,JT)=0D0
62834 IN(JT)=IN(JT)+4*JS
62835 ENDIF
62836 ENDIF
62837
62838C...Find new transverse directions (i.e. spacelike string vectors).
62839 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
62840 &IN(1).GT.IN(2)) GOTO 710
62841 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
62842 DO 970 J=1,4
62843 DP(1,J)=P(IN(1),J)
62844 DP(2,J)=P(IN(2),J)
62845 DP(3,J)=0D0
62846 DP(4,J)=0D0
62847 970 CONTINUE
62848 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62849 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62850 DHC12=DFOUR(1,2)
62851 IF(DHC12.LE.1D-2) THEN
62852 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62853 P(IN(JT)+2,JT)=0D0
62854 IN(JT)=IN(JT)+4*JS
62855 GOTO 960
62856 ENDIF
62857 IN(3)=N+NR+4*NS+5
62858 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62859 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62860 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62861 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62862 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62863 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62864 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62865 DHCX1=DFOUR(3,1)/DHC12
62866 DHCX2=DFOUR(3,2)/DHC12
62867 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62868 DHCY1=DFOUR(4,1)/DHC12
62869 DHCY2=DFOUR(4,2)/DHC12
62870 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62871 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62872 DO 980 J=1,4
62873 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62874 P(IN(3),J)=DP(3,J)
62875 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62876 & DHCYX*DP(3,J))
62877 980 CONTINUE
62878C...Express pT with respect to new axes, if sensible.
62879 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
62880 & FOUR(IN(3*JT+3)+1,IN(3)))
62881 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
62882 & FOUR(IN(3*JT+3)+1,IN(3)+1))
62883 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62884 PX(3)=PXP
62885 PY(3)=PYP
62886 ENDIF
62887 ENDIF
62888
62889C...Sum up known four-momentum. Gives coefficients for m2 expression.
62890 DO 1010 J=1,4
62891 DHG(J)=0D0
62892 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
62893 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
62894 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
62895 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62896 990 CONTINUE
62897 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
62898 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62899 1000 CONTINUE
62900 1010 CONTINUE
62901 DHM(1)=FOUR(I,I)
62902 DHM(2)=2D0*FOUR(I,IN(1))
62903 DHM(3)=2D0*FOUR(I,IN(2))
62904 DHM(4)=2D0*FOUR(IN(1),IN(2))
62905
62906C...Find coefficients for Gamma expression.
62907 DO 1030 IN2=IN(1)+1,IN(2),4
62908 DO 1020 IN1=IN(1),IN2-1,4
62909 DHC=2D0*FOUR(IN1,IN2)
62910 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
62911 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
62912 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
62913 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62914 1020 CONTINUE
62915 1030 CONTINUE
62916
62917C...Solve (m2, Gamma) equation system for energies taken.
62918 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
62919 IF(ABS(DHS1).LT.1D-4) GOTO 710
62920 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
62921 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
62922 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
62923 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62924 &ABS(DHS1)-DHS2/DHS1)
62925 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
62926 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
62927 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
62928
62929C...Step to new region if necessary.
62930 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
62931 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62932 P(IN(JR)+2,JT)=1D0
62933 IN(JR)=IN(JR)+4*JS
62934 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62935 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62936 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62937 P(IN(JT)+2,JT)=0D0
62938 IN(JT)=IN(JT)+4*JS
62939 ENDIF
62940 GOTO 960
62941 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
62942 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62943 P(IN(JT)+2,JT)=0D0
62944 IN(JT)=IN(JT)+4*JS
62945 GOTO 960
62946 ENDIF
62947
62948C...Four-momentum of particle. Remaining quantities. Loop back.
62949 1040 DO 1050 J=1,4
62950 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
62951 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
62952 1050 CONTINUE
62953 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
62954 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
62955 &GOTO 200
62956 IF(P(I,4).LT.P(I,5)) GOTO 710
62957 KFL(JT)=-KFL(3)
62958 PMQ(JT)=PMQ(3)
62959 PX(JT)=-PX(3)
62960 PY(JT)=-PY(3)
62961 GAM(JT)=GAM(3)
62962 IF(IN(3).NE.IN(3*JT+3)) THEN
62963 DO 1060 J=1,4
62964 P(IN(3*JT+3),J)=P(IN(3),J)
62965 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
62966 1060 CONTINUE
62967 ENDIF
62968 DO 1070 JQ=1,2
62969 IN(3*JT+JQ)=IN(JQ)
62970 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62971 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
62972 1070 CONTINUE
62973 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62974 &IBARRK(JT)=0
62975 GOTO 870
62976
62977C...Final hadron: side, flavour, hadron, mass.
62978 1080 I=I+1
62979 K(I,1)=1
62980 K(I,3)=IE(JR)
62981 K(I,4)=0
62982 K(I,5)=0
62983 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
62984 IF(K(I,2).EQ.0) GOTO 710
62985 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
62986 &IBARRK(JT)=0
62987 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62988 &K(I,3)=IJUORI(JT)
62989 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62990 &K(I,3)=IJUORI(JR)
62991 P(I,5)=PYMASS(K(I,2))
62992 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62993
62994C...Final two hadrons: find common setup of four-vectors.
62995 JQ=1
62996 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
62997 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
62998 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
62999 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
63000 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
63001 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
63002 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
63003 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
63004 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
63005 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
63006 ENDIF
63007
63008C...Solve kinematics for final two hadrons, if possible.
63009 WREM2=2D0*DHR1*DHR2*DHC12
63010 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
63011 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
63012 IF(FD.GE.1D0) GOTO 710
63013 FA=WREM2+PR(JT)-PR(JR)
63014 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
63015 PREVCF=PARJ(42)
63016 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63017 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
63018 FB=SIGN(FB,JS*(PYR(0)-PREV))
63019 KFL1A=IABS(KFL(1))
63020 KFL2A=IABS(KFL(2))
63021 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
63022 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
63023 &4D0*WREM2*PR(JT))),DBLE(JS))
63024 DO 1090 J=1,4
63025 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
63026 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
63027 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
63028 P(I,J)=P(N+NRS,J)-P(I-1,J)
63029 1090 CONTINUE
63030 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
63031 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
63032 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
63033 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
63034 NTRYFN=NTRYFN+1
63035 IF(NTRYFN.LT.100) GOTO 140
63036 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
63037 ENDIF
63038
63039C...Mark jets as fragmented and give daughter pointers.
63040 N=I-NRS+1
63041 DO 1100 I=NSAV+1,NSAV+NP
63042 IM=K(I,3)
63043 K(IM,1)=K(IM,1)+10
63044 IF(MSTU(16).NE.2) THEN
63045 K(IM,4)=NSAV+1
63046 K(IM,5)=NSAV+1
63047 ELSE
63048 K(IM,4)=NSAV+2
63049 K(IM,5)=N
63050 ENDIF
63051 1100 CONTINUE
63052
63053C...Document string system. Move up particles.
63054 NSAV=NSAV+1
63055 K(NSAV,1)=11
63056 K(NSAV,2)=92
63057 K(NSAV,3)=IP
63058 K(NSAV,4)=NSAV+1
63059 K(NSAV,5)=N
63060 DO 1110 J=1,4
63061 P(NSAV,J)=DPS(J)
63062 V(NSAV,J)=V(IP,J)
63063 1110 CONTINUE
63064 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63065 V(NSAV,5)=0D0
63066 DO 1130 I=NSAV+1,N
63067 DO 1120 J=1,5
63068 K(I,J)=K(I+NRS-1,J)
63069 P(I,J)=P(I+NRS-1,J)
63070 V(I,J)=0D0
63071 1120 CONTINUE
63072 1130 CONTINUE
63073 MSTU91=MSTU(90)
63074 DO 1140 IZ=MSTU90+1,MSTU91
63075 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
63076 PARU9T(IZ)=PARU(90+IZ)
63077 1140 CONTINUE
63078 MSTU(90)=MSTU90
63079
63080C...Order particles in rank along the chain. Update mother pointer.
63081 DO 1160 I=NSAV+1,N
63082 DO 1150 J=1,5
63083 K(I-NSAV+N,J)=K(I,J)
63084 P(I-NSAV+N,J)=P(I,J)
63085 1150 CONTINUE
63086 1160 CONTINUE
63087 I1=NSAV
63088 DO 1190 I=N+1,2*N-NSAV
63089 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
63090 I1=I1+1
63091 DO 1170 J=1,5
63092 K(I1,J)=K(I,J)
63093 P(I1,J)=P(I,J)
63094 1170 CONTINUE
63095 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63096 DO 1180 IZ=MSTU90+1,MSTU91
63097 IF(MSTU9T(IZ).EQ.I) THEN
63098 MSTU(90)=MSTU(90)+1
63099 MSTU(90+MSTU(90))=I1
63100 PARU(90+MSTU(90))=PARU9T(IZ)
63101 ENDIF
63102 1180 CONTINUE
63103 1190 CONTINUE
63104 DO 1220 I=2*N-NSAV,N+1,-1
63105 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
63106 I1=I1+1
63107 DO 1200 J=1,5
63108 K(I1,J)=K(I,J)
63109 P(I1,J)=P(I,J)
63110 1200 CONTINUE
63111 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63112 DO 1210 IZ=MSTU90+1,MSTU91
63113 IF(MSTU9T(IZ).EQ.I) THEN
63114 MSTU(90)=MSTU(90)+1
63115 MSTU(90+MSTU(90))=I1
63116 PARU(90+MSTU(90))=PARU9T(IZ)
63117 ENDIF
63118 1210 CONTINUE
63119 1220 CONTINUE
63120
63121C...Boost back particle system. Set production vertices.
63122 IF(MBST.EQ.0) THEN
63123 MSTU(33)=1
63124 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
63125 & DPS(3)/DPS(4))
63126 ELSE
63127 DO 1230 I=NSAV+1,N
63128 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
63129 IF(P(I,3).GT.0D0) THEN
63130 HHPEZ=(P(I,4)+P(I,3))*HHBZ
63131 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
63132 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63133 ELSE
63134 HHPEZ=(P(I,4)-P(I,3))/HHBZ
63135 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
63136 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63137 ENDIF
63138 1230 CONTINUE
63139 ENDIF
63140 DO 1250 I=NSAV+1,N
63141 DO 1240 J=1,4
63142 V(I,J)=V(IP,J)
63143 1240 CONTINUE
63144 1250 CONTINUE
63145
63146 RETURN
63147 END
63148
63149C*********************************************************************
63150
63151C...PYJURF
63152C...From three given input vectors in PJU the boost VJU from
63153C...the "lab frame" to the junction rest frame is constructed.
63154
63155 SUBROUTINE PYJURF(PJU,VJU)
63156
63157C...Double precision and integer declarations.
63158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63159 IMPLICIT INTEGER(I-N)
63160
63161C...Input, output and local arrays.
63162 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
63163 DATA TWOPI/6.283186D0/
63164
63165C...Calculate masses and other invariants.
63166 DO 100 J=1,4
63167 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63168 100 CONTINUE
63169 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
63170 PSUM(5)=SQRT(PSUM2)
63171 DO 120 I=1,3
63172 DO 110 J=1,3
63173 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
63174 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
63175 110 CONTINUE
63176 120 CONTINUE
63177
63178C...Pick I to be most massive parton and J to be the one closest to I.
63179 ITRY=0
63180 I=1
63181 IF(A(2,2).GT.A(1,1)) I=2
63182 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
63183 130 ITRY=ITRY+1
63184 J=1+MOD(I,3)
63185 K=1+MOD(J,3)
63186 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
63187 K=1+MOD(I,3)
63188 J=1+MOD(K,3)
63189 ENDIF
63190 PMI2=A(I,I)
63191 PMJ2=A(J,J)
63192 PMK2=A(K,K)
63193 AIJ=A(I,J)
63194 AIK=A(I,K)
63195 AJK=A(J,K)
63196
63197C...Trivial find new parton energies if all three partons are massless.
63198 IF(PMI2.LT.1D-4) THEN
63199 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
63200 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
63201 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
63202
63203C...Else find momentum range for parton I and values at extremes.
63204 ELSE
63205 PAIMIN=0D0
63206 PEIMIN=SQRT(PMI2)
63207 PEJMIN=AIJ/PEIMIN
63208 PEKMIN=AIK/PEIMIN
63209 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
63210 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
63211 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
63212 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
63213 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
63214 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
63215 HI=PEIMAX**2-0.25D0*PAIMAX**2
63216 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
63217 & 0.5D0*PAIMAX*AIJ)/HI
63218 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
63219 & 0.5D0*PAIMAX*AIK)/HI
63220 PEJMAX=SQRT(PAJMAX**2+PMJ2)
63221 PEKMAX=SQRT(PAKMAX**2+PMK2)
63222 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
63223
63224C...If unexpected values at upper endpoint then pick another parton.
63225 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
63226 I1=1+MOD(I,3)
63227 IF(A(I1,I1).GE.1D-4) THEN
63228 I=I1
63229 GOTO 130
63230 ENDIF
63231 ITRY=ITRY+1
63232 I1=1+MOD(I,3)
63233 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
63234 I=I1
63235 GOTO 130
63236 ENDIF
63237 ENDIF
63238
63239C..Start binary + linear search to find solution inside range.
63240 ITER=0
63241 ITMIN=0
63242 ITMAX=0
63243 PAI=0.5D0*(PAIMIN+PAIMAX)
63244 140 ITER=ITER+1
63245
63246C...Derive momentum of other two partons and distance to root.
63247 PEI=SQRT(PAI**2+PMI2)
63248 HI=PEI**2-0.25D0*PAI**2
63249 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
63250 PEJ=SQRT(PAJ**2+PMJ2)
63251 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
63252 PEK=SQRT(PAK**2+PMK2)
63253 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
63254
63255C...Pick next I momentum to explore, hopefully closer to root.
63256 IF(FNOW.GT.0D0) THEN
63257 PAIMIN=PAI
63258 FMIN=FNOW
63259 ITMIN=ITMIN+1
63260 ELSE
63261 PAIMAX=PAI
63262 FMAX=FNOW
63263 ITMAX=ITMAX+1
63264 ENDIF
63265 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
63266 & THEN
63267 PAI=0.5D0*(PAIMIN+PAIMAX)
63268 GOTO 140
63269 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
63270 & ABS(FNOW).GT.1D-12*PSUM2) THEN
63271 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
63272 GOTO 140
63273 ENDIF
63274 ENDIF
63275
63276C...Now know energies in junction rest frame.
63277 PENEW(I)=PEI
63278 PENEW(J)=PEJ
63279 PENEW(K)=PEK
63280
63281C...Boost (copy of) partons to their rest frame.
63282 VXCM=-PSUM(1)/PSUM(5)
63283 VYCM=-PSUM(2)/PSUM(5)
63284 VZCM=-PSUM(3)/PSUM(5)
63285 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
63286 DO 150 I=1,3
63287 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
63288 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
63289 PCM(I,1)=PJU(I,1)+FAC2*VXCM
63290 PCM(I,2)=PJU(I,2)+FAC2*VYCM
63291 PCM(I,3)=PJU(I,3)+FAC2*VZCM
63292 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
63293 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63294 150 CONTINUE
63295
63296C...Construct difference vectors and boost to junction rest frame.
63297 DO 160 J=1,3
63298 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
63299 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
63300 160 CONTINUE
63301 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
63302 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
63303 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
63304 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
63305 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
63306 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
63307 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
63308 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
63309 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
63310 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
63311 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
63312
63313C...Add two boosts, giving final result.
63314 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
63315 VJU(1)=VXJU+FCM*VXCM
63316 VJU(2)=VYJU+FCM*VYCM
63317 VJU(3)=VZJU+FCM*VZCM
63318 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
63319 VJU(5)=1D0
63320
63321C...In case of error in reconstruction: revert to CM frame of system.
63322 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63323 &(PCM(1,5)*PCM(2,5))
63324 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63325 &(PCM(1,5)*PCM(3,5))
63326 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63327 &(PCM(2,5)*PCM(3,5))
63328 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63329 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63330 DO 170 I=1,3
63331 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
63332 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
63333 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
63334 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
63335 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
63336 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
63337 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63338 170 CONTINUE
63339 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63340 &(PCM(1,5)*PCM(2,5))
63341 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63342 &(PCM(1,5)*PCM(3,5))
63343 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63344 &(PCM(2,5)*PCM(3,5))
63345 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63346 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63347 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
63348 VJU(1)=VXCM
63349 VJU(2)=VYCM
63350 VJU(3)=VZCM
63351 VJU(4)=GAMCM
63352 ENDIF
63353
63354 RETURN
63355 END
63356
63357C*********************************************************************
63358
63359C...PYINDF
63360C...Handles the fragmentation of a jet system (or a single
63361C...jet) according to independent fragmentation models.
63362
63363 SUBROUTINE PYINDF(IP)
63364
63365C...Double precision and integer declarations.
63366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63367 IMPLICIT INTEGER(I-N)
63368 INTEGER PYK,PYCHGE,PYCOMP
63369C...Commonblocks.
63370 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63373 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
63374C...Local arrays.
63375 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
63376 &KFLO(2),PXO(2),PYO(2),WO(2)
63377
63378C.. MOPS error message
63379 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
63380 &' are not treated as expected in independent fragmentation')
63381
63382C...Reset counters. Identify parton system and take copy. Check flavour.
63383 NSAV=N
63384 MSTU90=MSTU(90)
63385 NJET=0
63386 KQSUM=0
63387 DO 100 J=1,5
63388 DPS(J)=0D0
63389 100 CONTINUE
63390 I=IP-1
63391 110 I=I+1
63392 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
63393 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
63394 IF(MSTU(21).GE.1) RETURN
63395 ENDIF
63396 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
63397 KC=PYCOMP(K(I,2))
63398 IF(KC.EQ.0) GOTO 110
63399 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
63400 IF(KQ.EQ.0) GOTO 110
63401 NJET=NJET+1
63402 IF(KQ.NE.2) KQSUM=KQSUM+KQ
63403 DO 120 J=1,5
63404 K(NSAV+NJET,J)=K(I,J)
63405 P(NSAV+NJET,J)=P(I,J)
63406 DPS(J)=DPS(J)+P(I,J)
63407 120 CONTINUE
63408 K(NSAV+NJET,3)=I
63409 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
63410 &K(I+1,1).EQ.2)) GOTO 110
63411 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
63412 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
63413 IF(MSTU(21).GE.1) RETURN
63414 ENDIF
63415
63416C...Boost copied system to CM frame. Find CM energy and sum flavours.
63417 IF(NJET.NE.1) THEN
63418 MSTU(33)=1
63419 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
63420 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
63421 ENDIF
63422 PECM=0D0
63423 DO 130 J=1,3
63424 NFI(J)=0
63425 130 CONTINUE
63426 DO 140 I=NSAV+1,NSAV+NJET
63427 PECM=PECM+P(I,4)
63428 KFA=IABS(K(I,2))
63429 IF(KFA.LE.3) THEN
63430 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
63431 ELSEIF(KFA.GT.1000) THEN
63432 KFLA=MOD(KFA/1000,10)
63433 KFLB=MOD(KFA/100,10)
63434 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
63435 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
63436 ENDIF
63437 140 CONTINUE
63438
63439C...Loop over attempts made. Reset counters.
63440 NTRY=0
63441 150 NTRY=NTRY+1
63442 IF(NTRY.GT.200) THEN
63443 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
63444 IF(MSTU(21).GE.1) RETURN
63445 ENDIF
63446 N=NSAV+NJET
63447 MSTU(90)=MSTU90
63448 DO 160 J=1,3
63449 NFL(J)=NFI(J)
63450 IFET(J)=0
63451 KFLF(J)=0
63452 160 CONTINUE
63453
63454C...Loop over jets to be fragmented.
63455 DO 230 IP1=NSAV+1,NSAV+NJET
63456 MSTJ(91)=0
63457 NSAV1=N
63458 MSTU91=MSTU(90)
63459
63460C...Initial flavour and momentum values. Jet along +z axis.
63461 KFLH=IABS(K(IP1,2))
63462 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
63463 KFLO(2)=0
63464 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
63465
63466C...Initial values for quark or diquark jet.
63467 170 IF(IABS(K(IP1,2)).NE.21) THEN
63468 NSTR=1
63469 KFLO(1)=K(IP1,2)
63470 CALL PYPTDI(0,PXO(1),PYO(1))
63471 WO(1)=WF
63472
63473C...Initial values for gluon treated like random quark jet.
63474 ELSEIF(MSTJ(2).LE.2) THEN
63475 NSTR=1
63476 IF(MSTJ(2).EQ.2) MSTJ(91)=1
63477 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63478 CALL PYPTDI(0,PXO(1),PYO(1))
63479 WO(1)=WF
63480
63481C...Initial values for gluon treated like quark-antiquark jet pair,
63482C...sharing energy according to Altarelli-Parisi splitting function.
63483 ELSE
63484 NSTR=2
63485 IF(MSTJ(2).EQ.4) MSTJ(91)=1
63486 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63487 KFLO(2)=-KFLO(1)
63488 CALL PYPTDI(0,PXO(1),PYO(1))
63489 PXO(2)=-PXO(1)
63490 PYO(2)=-PYO(1)
63491 WO(1)=WF*PYR(0)**(1D0/3D0)
63492 WO(2)=WF-WO(1)
63493 ENDIF
63494
63495C...Initial values for rank, flavour, pT and W+.
63496 DO 220 ISTR=1,NSTR
63497 180 I=N
63498 MSTU(90)=MSTU91
63499 IRANK=0
63500 KFL1=KFLO(ISTR)
63501 PX1=PXO(ISTR)
63502 PY1=PYO(ISTR)
63503 W=WO(ISTR)
63504
63505C...New hadron. Generate flavour and hadron species.
63506 190 I=I+1
63507 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
63508 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
63509 IF(MSTU(21).GE.1) RETURN
63510 ENDIF
63511 IRANK=IRANK+1
63512 K(I,1)=1
63513 K(I,3)=IP1
63514 K(I,4)=0
63515 K(I,5)=0
63516 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
63517 IF(K(I,2).EQ.0) GOTO 180
63518 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
63519 IF(PYR(0).GT.PARJ(19)) GOTO 200
63520 ENDIF
63521
63522C...Find hadron mass. Generate four-momentum.
63523 P(I,5)=PYMASS(K(I,2))
63524 CALL PYPTDI(KFL1,PX2,PY2)
63525 P(I,1)=PX1+PX2
63526 P(I,2)=PY1+PY2
63527 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
63528 CALL PYZDIS(KFL1,KFL2,PR,Z)
63529 MZSAV=0
63530 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
63531 MZSAV=1
63532 MSTU(90)=MSTU(90)+1
63533 MSTU(90+MSTU(90))=I
63534 PARU(90+MSTU(90))=Z
63535 ENDIF
63536 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
63537 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
63538 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
63539 & P(I,3).LE.0.001D0) THEN
63540 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
63541 P(I,3)=0.0001D0
63542 P(I,4)=SQRT(PR)
63543 Z=P(I,4)/W
63544 ENDIF
63545
63546C...Remaining flavour and momentum.
63547 KFL1=-KFL2
63548 PX1=-PX2
63549 PY1=-PY2
63550 W=(1D0-Z)*W
63551 DO 210 J=1,5
63552 V(I,J)=0D0
63553 210 CONTINUE
63554
63555C...Check if pL acceptable. Go back for new hadron if enough energy.
63556 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
63557 I=I-1
63558 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
63559 ENDIF
63560 IF(W.GT.PARJ(31)) GOTO 190
63561 N=I
63562 220 CONTINUE
63563 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
63564 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
63565
63566C...Rotate jet to new direction.
63567 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
63568 PHI=PYANGL(P(IP1,1),P(IP1,2))
63569 MSTU(33)=1
63570 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
63571 K(K(IP1,3),4)=NSAV1+1
63572 K(K(IP1,3),5)=N
63573
63574C...End of jet generation loop. Skip conservation in some cases.
63575 230 CONTINUE
63576 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
63577 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
63578
63579C...Subtract off produced hadron flavours, finished if zero.
63580 DO 240 I=NSAV+NJET+1,N
63581 KFA=IABS(K(I,2))
63582 KFLA=MOD(KFA/1000,10)
63583 KFLB=MOD(KFA/100,10)
63584 KFLC=MOD(KFA/10,10)
63585 IF(KFLA.EQ.0) THEN
63586 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
63587 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
63588 ELSE
63589 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
63590 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
63591 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
63592 ENDIF
63593 240 CONTINUE
63594 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63595 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63596 IF(NREQ.EQ.0) GOTO 320
63597
63598C...Take away flavour of low-momentum particles until enough freedom.
63599 NREM=0
63600 250 IREM=0
63601 P2MIN=PECM**2
63602 DO 260 I=NSAV+NJET+1,N
63603 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
63604 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
63605 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
63606 260 CONTINUE
63607 IF(IREM.EQ.0) GOTO 150
63608 K(IREM,1)=7
63609 KFA=IABS(K(IREM,2))
63610 KFLA=MOD(KFA/1000,10)
63611 KFLB=MOD(KFA/100,10)
63612 KFLC=MOD(KFA/10,10)
63613 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
63614 IF(K(IREM,1).EQ.8) GOTO 250
63615 IF(KFLA.EQ.0) THEN
63616 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
63617 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
63618 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
63619 ELSE
63620 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
63621 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
63622 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
63623 ENDIF
63624 NREM=NREM+1
63625 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63626 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63627 IF(NREQ.GT.NREM) GOTO 250
63628 DO 270 I=NSAV+NJET+1,N
63629 IF(K(I,1).EQ.8) K(I,1)=1
63630 270 CONTINUE
63631
63632C...Find combination of existing and new flavours for hadron.
63633 280 NFET=2
63634 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
63635 IF(NREQ.LT.NREM) NFET=1
63636 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
63637 DO 290 J=1,NFET
63638 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
63639 KFLF(J)=ISIGN(1,NFL(1))
63640 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
63641 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
63642 290 CONTINUE
63643 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
63644 &GOTO 280
63645 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
63646 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
63647 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
63648 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
63649 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
63650 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
63651 IF(NFET.LE.2) KFLF(3)=0
63652 IF(KFLF(3).NE.0) THEN
63653 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
63654 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
63655 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
63656 & KFLFC=KFLFC+ISIGN(2,KFLFC)
63657 ELSE
63658 KFLFC=KFLF(1)
63659 ENDIF
63660 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
63661 IF(KF.EQ.0) GOTO 280
63662 DO 300 J=1,MAX(2,NFET)
63663 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
63664 300 CONTINUE
63665
63666C...Store hadron at random among free positions.
63667 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
63668 DO 310 I=NSAV+NJET+1,N
63669 IF(K(I,1).EQ.7) NPOS=NPOS-1
63670 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
63671 K(I,1)=1
63672 K(I,2)=KF
63673 P(I,5)=PYMASS(K(I,2))
63674 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63675 310 CONTINUE
63676 NREM=NREM-1
63677 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63678 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63679 IF(NREM.GT.0) GOTO 280
63680
63681C...Compensate for missing momentum in global scheme (3 options).
63682 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
63683 DO 340 J=1,3
63684 PSI(J)=0D0
63685 DO 330 I=NSAV+NJET+1,N
63686 PSI(J)=PSI(J)+P(I,J)
63687 330 CONTINUE
63688 340 CONTINUE
63689 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
63690 PWS=0D0
63691 DO 350 I=NSAV+NJET+1,N
63692 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
63693 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63694 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63695 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
63696 350 CONTINUE
63697 DO 370 I=NSAV+NJET+1,N
63698 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
63699 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63700 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63701 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
63702 DO 360 J=1,3
63703 P(I,J)=P(I,J)-PSI(J)*PW/PWS
63704 360 CONTINUE
63705 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63706 370 CONTINUE
63707
63708C...Compensate for missing momentum withing each jet separately.
63709 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
63710 DO 390 I=N+1,N+NJET
63711 K(I,1)=0
63712 DO 380 J=1,5
63713 P(I,J)=0D0
63714 380 CONTINUE
63715 390 CONTINUE
63716 DO 410 I=NSAV+NJET+1,N
63717 IR1=K(I,3)
63718 IR2=N+IR1-NSAV
63719 K(IR2,1)=K(IR2,1)+1
63720 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63721 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63722 DO 400 J=1,3
63723 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
63724 400 CONTINUE
63725 P(IR2,4)=P(IR2,4)+P(I,4)
63726 P(IR2,5)=P(IR2,5)+PLS
63727 410 CONTINUE
63728 PSS=0D0
63729 DO 420 I=N+1,N+NJET
63730 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
63731 420 CONTINUE
63732 DO 440 I=NSAV+NJET+1,N
63733 IR1=K(I,3)
63734 IR2=N+IR1-NSAV
63735 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63736 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63737 DO 430 J=1,3
63738 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
63739 & PLS*P(IR1,J)
63740 430 CONTINUE
63741 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63742 440 CONTINUE
63743 ENDIF
63744
63745C...Scale momenta for energy conservation.
63746 IF(MOD(MSTJ(3),5).NE.0) THEN
63747 PMS=0D0
63748 PES=0D0
63749 PQS=0D0
63750 DO 450 I=NSAV+NJET+1,N
63751 PMS=PMS+P(I,5)
63752 PES=PES+P(I,4)
63753 PQS=PQS+P(I,5)**2/P(I,4)
63754 450 CONTINUE
63755 IF(PMS.GE.PECM) GOTO 150
63756 NECO=0
63757 460 NECO=NECO+1
63758 PFAC=(PECM-PQS)/(PES-PQS)
63759 PES=0D0
63760 PQS=0D0
63761 DO 480 I=NSAV+NJET+1,N
63762 DO 470 J=1,3
63763 P(I,J)=PFAC*P(I,J)
63764 470 CONTINUE
63765 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63766 PES=PES+P(I,4)
63767 PQS=PQS+P(I,5)**2/P(I,4)
63768 480 CONTINUE
63769 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
63770 ENDIF
63771
63772C...Origin of produced particles and parton daughter pointers.
63773 490 DO 500 I=NSAV+NJET+1,N
63774 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
63775 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
63776 500 CONTINUE
63777 DO 510 I=NSAV+1,NSAV+NJET
63778 I1=K(I,3)
63779 K(I1,1)=K(I1,1)+10
63780 IF(MSTU(16).NE.2) THEN
63781 K(I1,4)=NSAV+1
63782 K(I1,5)=NSAV+1
63783 ELSE
63784 K(I1,4)=K(I1,4)-NJET+1
63785 K(I1,5)=K(I1,5)-NJET+1
63786 IF(K(I1,5).LT.K(I1,4)) THEN
63787 K(I1,4)=0
63788 K(I1,5)=0
63789 ENDIF
63790 ENDIF
63791 510 CONTINUE
63792
63793C...Document independent fragmentation system. Remove copy of jets.
63794 NSAV=NSAV+1
63795 K(NSAV,1)=11
63796 K(NSAV,2)=93
63797 K(NSAV,3)=IP
63798 K(NSAV,4)=NSAV+1
63799 K(NSAV,5)=N-NJET+1
63800 DO 520 J=1,4
63801 P(NSAV,J)=DPS(J)
63802 V(NSAV,J)=V(IP,J)
63803 520 CONTINUE
63804 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63805 V(NSAV,5)=0D0
63806 DO 540 I=NSAV+NJET,N
63807 DO 530 J=1,5
63808 K(I-NJET+1,J)=K(I,J)
63809 P(I-NJET+1,J)=P(I,J)
63810 V(I-NJET+1,J)=V(I,J)
63811 530 CONTINUE
63812 540 CONTINUE
63813 N=N-NJET+1
63814 DO 550 IZ=MSTU90+1,MSTU(90)
63815 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
63816 550 CONTINUE
63817
63818C...Boost back particle system. Set production vertices.
63819 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
63820 &DPS(2)/DPS(4),DPS(3)/DPS(4))
63821 DO 570 I=NSAV+1,N
63822 DO 560 J=1,4
63823 V(I,J)=V(IP,J)
63824 560 CONTINUE
63825 570 CONTINUE
63826
63827 RETURN
63828 END
63829
63830C*********************************************************************
63831
63832C...PYDECY
63833C...Handles the decay of unstable particles.
63834
63835 SUBROUTINE PYDECY(IP)
63836
63837C...Double precision and integer declarations.
63838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63839 IMPLICIT INTEGER(I-N)
63840 INTEGER PYK,PYCHGE,PYCOMP
63841C...Commonblocks.
63842 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63843 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63844 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63845 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
63846 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
63847C...Local arrays.
63848 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
63849 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
63850 CHARACTER CIDC*4
63851 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
63852
63853C...Functions: momentum in two-particle decays and four-product.
63854 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
63855 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)
63856
63857C...Initial values.
63858 NTRY=0
63859 NSAV=N
63860 KFA=IABS(K(IP,2))
63861 KFS=ISIGN(1,K(IP,2))
63862 KC=PYCOMP(KFA)
63863 MSTJ(92)=0
63864
63865C...Choose lifetime and determine decay vertex.
63866 IF(K(IP,1).EQ.5) THEN
63867 V(IP,5)=0D0
63868 ELSEIF(K(IP,1).NE.4) THEN
63869 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
63870 ENDIF
63871 DO 100 J=1,4
63872 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
63873 100 CONTINUE
63874
63875C...Determine whether decay allowed or not.
63876 MOUT=0
63877 IF(MSTJ(22).EQ.2) THEN
63878 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
63879 ELSEIF(MSTJ(22).EQ.3) THEN
63880 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
63881 ELSEIF(MSTJ(22).EQ.4) THEN
63882 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
63883 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
63884 ENDIF
63885 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
63886 K(IP,1)=4
63887 RETURN
63888 ENDIF
63889
63890C...Interface to external tau decay library (for tau polarization).
63891 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
63892
63893C...Starting values for pointers and momenta.
63894 ITAU=IP
63895 DO 110 J=1,4
63896 PTAU(J)=P(ITAU,J)
63897 PCMTAU(J)=P(ITAU,J)
63898 110 CONTINUE
63899
63900C...Iterate to find position and code of mother of tau.
63901 IMTAU=ITAU
63902 120 IMTAU=K(IMTAU,3)
63903
63904 IF(IMTAU.EQ.0) THEN
63905C...If no known origin then impossible to do anything further.
63906 KFORIG=0
63907 IORIG=0
63908
63909 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
63910C...If tau -> tau + gamma then add gamma energy and loop.
63911 IF(K(K(IMTAU,4),2).EQ.22) THEN
63912 DO 130 J=1,4
63913 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
63914 130 CONTINUE
63915 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
63916 DO 140 J=1,4
63917 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
63918 140 CONTINUE
63919 ENDIF
63920 GOTO 120
63921
63922 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
63923C...If coming from weak decay of hadron then W is not stored in record,
63924C...but can be reconstructed by adding neutrino momentum.
63925 KFORIG=-ISIGN(24,K(ITAU,2))
63926 IORIG=0
63927 DO 160 II=K(IMTAU,4),K(IMTAU,5)
63928 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
63929 DO 150 J=1,4
63930 PCMTAU(J)=PCMTAU(J)+P(II,J)
63931 150 CONTINUE
63932 ENDIF
63933 160 CONTINUE
63934
63935 ELSE
63936C...If coming from resonance decay then find latest copy of this
63937C...resonance (may not completely agree).
63938 KFORIG=K(IMTAU,2)
63939 IORIG=IMTAU
63940 DO 170 II=IMTAU+1,IP-1
63941 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
63942 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
63943 170 CONTINUE
63944 DO 180 J=1,4
63945 PCMTAU(J)=P(IORIG,J)
63946 180 CONTINUE
63947 ENDIF
63948
63949C...Boost tau to rest frame of production process (where known)
63950C...and rotate it to sit along +z axis.
63951 DO 190 J=1,3
63952 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
63953 190 CONTINUE
63954 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
63955 & -DBETAU(2),-DBETAU(3))
63956 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
63957 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
63958 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
63959 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
63960
63961C...Call tau decay routine (if meaningful) and fill extra info.
63962 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63963 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
63964 DO 200 II=NSAV+1,NSAV+NDECAY
63965 K(II,1)=1
63966 K(II,3)=IP
63967 K(II,4)=0
63968 K(II,5)=0
63969 200 CONTINUE
63970 N=NSAV+NDECAY
63971 ENDIF
63972
63973C...Boost back decay tau and decay products.
63974 DO 210 J=1,4
63975 P(ITAU,J)=PTAU(J)
63976 210 CONTINUE
63977 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63978 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
63979 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
63980 & DBETAU(2),DBETAU(3))
63981
63982C...Skip past ordinary tau decay treatment.
63983 MMAT=0
63984 MBST=0
63985 ND=0
63986 GOTO 630
63987 ENDIF
63988 ENDIF
63989
63990C...B-Bbar mixing: flip sign of meson appropriately.
63991 MMIX=0
63992 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
63993 XBBMIX=PARJ(76)
63994 IF(KFA.EQ.531) XBBMIX=PARJ(77)
63995 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
63996 IF(MMIX.EQ.1) KFS=-KFS
63997 ENDIF
63998
63999C...Check existence of decay channels. Particle/antiparticle rules.
64000 KCA=KC
64001 IF(MDCY(KC,2).GT.0) THEN
64002 MDMDCY=MDME(MDCY(KC,2),2)
64003 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
64004 ENDIF
64005 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
64006 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
64007 RETURN
64008 ENDIF
64009 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
64010 IF(KCHG(KC,3).EQ.0) THEN
64011 KFSP=1
64012 KFSN=0
64013 IF(PYR(0).GT.0.5D0) KFS=-KFS
64014 ELSEIF(KFS.GT.0) THEN
64015 KFSP=1
64016 KFSN=0
64017 ELSE
64018 KFSP=0
64019 KFSN=1
64020 ENDIF
64021
64022C...Sum branching ratios of allowed decay channels.
64023 220 NOPE=0
64024 BRSU=0D0
64025 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
64026 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64027 & KFSN*MDME(IDL,1).NE.3) GOTO 230
64028 IF(MDME(IDL,2).GT.100) GOTO 230
64029 NOPE=NOPE+1
64030 BRSU=BRSU+BRAT(IDL)
64031 230 CONTINUE
64032 IF(NOPE.EQ.0) THEN
64033 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
64034 RETURN
64035 ENDIF
64036
64037C...Select decay channel among allowed ones.
64038 240 RBR=BRSU*PYR(0)
64039 IDL=MDCY(KCA,2)-1
64040 250 IDL=IDL+1
64041 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64042 &KFSN*MDME(IDL,1).NE.3) THEN
64043 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64044 ELSEIF(MDME(IDL,2).GT.100) THEN
64045 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64046 ELSE
64047 IDC=IDL
64048 RBR=RBR-BRAT(IDL)
64049 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
64050 ENDIF
64051
64052C...Start readout of decay channel: matrix element, reset counters.
64053 MMAT=MDME(IDC,2)
64054 260 NTRY=NTRY+1
64055 IF(MOD(NTRY,200).EQ.0) THEN
64056 WRITE(CIDC,'(I4)') IDC
64057C...Do not print warning for some well-known special cases.
64058 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
64059 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
64060 & CIDC)
64061 GOTO 240
64062 ENDIF
64063 IF(NTRY.GT.1000) THEN
64064 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64065 IF(MSTU(21).GE.1) RETURN
64066 ENDIF
64067 I=N
64068 NP=0
64069 NQ=0
64070 MBST=0
64071 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
64072 DO 270 J=1,4
64073 PV(1,J)=0D0
64074 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
64075 270 CONTINUE
64076 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
64077 PV(1,5)=P(IP,5)
64078 PS=0D0
64079 PSQ=0D0
64080 MREM=0
64081 MHADDY=0
64082 IF(KFA.GT.80) MHADDY=1
64083C.. Random flavour and popcorn system memory.
64084 IRNDMO=0
64085 JTMO=0
64086 MSTU(121)=0
64087 MSTU(125)=10
64088
64089C...Read out decay products. Convert to standard flavour code.
64090 JTMAX=5
64091 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
64092 DO 280 JT=1,JTMAX
64093 IF(JT.LE.5) KP=KFDP(IDC,JT)
64094 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
64095 IF(KP.EQ.0) GOTO 280
64096 KPA=IABS(KP)
64097 KCP=PYCOMP(KPA)
64098 IF(KPA.GT.80) MHADDY=1
64099 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
64100 KFP=KP
64101 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
64102 KFP=KFS*KP
64103 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
64104 KFP=-KFS*MOD(KFA/10,10)
64105 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
64106 KFP=KFS*(100*MOD(KFA/10,100)+3)
64107 ELSEIF(KPA.EQ.81) THEN
64108 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
64109 ELSEIF(KP.EQ.82) THEN
64110 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
64111 IF(KFP.EQ.0) GOTO 260
64112 KFP=-KFP
64113 IRNDMO=1
64114 MSTJ(93)=1
64115 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
64116 ELSEIF(KP.EQ.-82) THEN
64117 KFP=MSTU(124)
64118 ENDIF
64119 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
64120
64121C...Add decay product to event record or to quark flavour list.
64122 KFPA=IABS(KFP)
64123 KQP=KCHG(KCP,2)
64124 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
64125 NQ=NQ+1
64126 KFLO(NQ)=KFP
64127C...set rndmflav popcorn system pointer
64128 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
64129 MSTJ(93)=2
64130 PSQ=PSQ+PYMASS(KFLO(NQ))
64131 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
64132 & MOD(NQ,2).EQ.1) THEN
64133 NQ=NQ-1
64134 PS=PS-P(I,5)
64135 K(I,1)=1
64136 KFI=K(I,2)
64137 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
64138 IF(K(I,2).EQ.0) GOTO 260
64139 MSTJ(93)=1
64140 P(I,5)=PYMASS(K(I,2))
64141 PS=PS+P(I,5)
64142 ELSE
64143 I=I+1
64144 NP=NP+1
64145 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
64146 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
64147 K(I,1)=1+MOD(NQ,2)
64148 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
64149 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
64150 K(I,2)=KFP
64151 K(I,3)=IP
64152 K(I,4)=0
64153 K(I,5)=0
64154 P(I,5)=PYMASS(KFP)
64155 PS=PS+P(I,5)
64156 ENDIF
64157 280 CONTINUE
64158
64159C...Check masses for resonance decays.
64160 IF(MHADDY.EQ.0) THEN
64161 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
64162 ENDIF
64163
64164C...Choose decay multiplicity in phase space model.
64165 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
64166 PSP=PS
64167 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
64168 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
64169 300 NTRY=NTRY+1
64170C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
64171 IF(IRNDMO.EQ.0) THEN
64172 MSTU(121)=0
64173 JTMO=0
64174 ELSEIF(IRNDMO.EQ.1) THEN
64175 IRNDMO=2
64176 ELSE
64177 GOTO 260
64178 ENDIF
64179 IF(NTRY.GT.1000) THEN
64180 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64181 IF(MSTU(21).GE.1) RETURN
64182 ENDIF
64183 IF(MMAT.LE.20) THEN
64184 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
64185 & SIN(PARU(2)*PYR(0))
64186 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
64187 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
64188 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
64189 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
64190 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
64191 ELSE
64192 ND=MMAT-20
64193 ENDIF
64194C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
64195 MSTU(125)=ND-NQ/2
64196 IF(MSTU(121).GT.MSTU(125)) GOTO 300
64197
64198C...Form hadrons from flavour content.
64199 DO 310 JT=1,NQ
64200 KFL1(JT)=KFLO(JT)
64201 310 CONTINUE
64202 IF(ND.EQ.NP+NQ/2) GOTO 330
64203 DO 320 I=N+NP+1,N+ND-NQ/2
64204C.. Stick to started popcorn system, else pick side at random
64205 JT=JTMO
64206 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
64207 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
64208 IF(K(I,2).EQ.0) GOTO 300
64209 MSTU(125)=MSTU(125)-1
64210 JTMO=0
64211 IF(MSTU(121).GT.0) JTMO=JT
64212 KFL1(JT)=-KFL2
64213 320 CONTINUE
64214 330 JT=2
64215 JT2=3
64216 JT3=4
64217 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
64218 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
64219 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
64220 IF(JT.EQ.3) JT2=2
64221 IF(JT.EQ.4) JT3=2
64222 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
64223 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
64224 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
64225 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
64226
64227C...Check that sum of decay product masses not too large.
64228 PS=PSP
64229 DO 340 I=N+NP+1,N+ND
64230 K(I,1)=1
64231 K(I,3)=IP
64232 K(I,4)=0
64233 K(I,5)=0
64234 P(I,5)=PYMASS(K(I,2))
64235 PS=PS+P(I,5)
64236 340 CONTINUE
64237 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
64238
64239C...Rescale energy to subtract off spectator quark mass.
64240 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
64241 & .AND.NP.GE.3) THEN
64242 PS=PS-P(N+NP,5)
64243 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
64244 DO 350 J=1,5
64245 P(N+NP,J)=PQT*PV(1,J)
64246 PV(1,J)=(1D0-PQT)*PV(1,J)
64247 350 CONTINUE
64248 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64249 ND=NP-1
64250 MREM=1
64251
64252C...Fully specified final state: check mass broadening effects.
64253 ELSE
64254 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
64255 ND=NP
64256 ENDIF
64257
64258C...Determine position of grandmother, number of sisters.
64259 NM=0
64260 KFAS=0
64261 MSGN=0
64262 IF(MMAT.EQ.3) THEN
64263 IM=K(IP,3)
64264 IF(IM.LT.0.OR.IM.GE.IP) IM=0
64265 IF(IM.NE.0) KFAM=IABS(K(IM,2))
64266 IF(IM.NE.0) THEN
64267 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
64268 IF(K(IL,3).EQ.IM) NM=NM+1
64269 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
64270 360 CONTINUE
64271 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
64272 & MOD(KFAM/1000,10).NE.0) NM=0
64273 IF(NM.EQ.2) THEN
64274 KFAS=IABS(K(ISIS,2))
64275 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
64276 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
64277 ENDIF
64278 ENDIF
64279 ENDIF
64280
64281C...Kinematics of one-particle decays.
64282 IF(ND.EQ.1) THEN
64283 DO 370 J=1,4
64284 P(N+1,J)=P(IP,J)
64285 370 CONTINUE
64286 GOTO 630
64287 ENDIF
64288
64289C...Calculate maximum weight ND-particle decay.
64290 PV(ND,5)=P(N+ND,5)
64291 IF(ND.GE.3) THEN
64292 WTMAX=1D0/WTCOR(ND-2)
64293 PMAX=PV(1,5)-PS+P(N+ND,5)
64294 PMIN=0D0
64295 DO 380 IL=ND-1,1,-1
64296 PMAX=PMAX+P(N+IL,5)
64297 PMIN=PMIN+P(N+IL+1,5)
64298 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
64299 380 CONTINUE
64300 ENDIF
64301
64302C...Find virtual gamma mass in Dalitz decay.
64303 390 IF(ND.EQ.2) THEN
64304 ELSEIF(MMAT.EQ.2) THEN
64305 PMES=4D0*PMAS(11,1)**2
64306 PMRHO2=PMAS(131,1)**2
64307 PGRHO2=PMAS(131,2)**2
64308 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
64309 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
64310 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
64311 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
64312 IF(WT.LT.PYR(0)) GOTO 400
64313 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
64314
64315C...M-generator gives weight. If rejected, try again.
64316 ELSE
64317 410 RORD(1)=1D0
64318 DO 440 IL1=2,ND-1
64319 RSAV=PYR(0)
64320 DO 420 IL2=IL1-1,1,-1
64321 IF(RSAV.LE.RORD(IL2)) GOTO 430
64322 RORD(IL2+1)=RORD(IL2)
64323 420 CONTINUE
64324 430 RORD(IL2+1)=RSAV
64325 440 CONTINUE
64326 RORD(ND)=0D0
64327 WT=1D0
64328 DO 450 IL=ND-1,1,-1
64329 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
64330 & (PV(1,5)-PS)
64331 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64332 450 CONTINUE
64333 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
64334 ENDIF
64335
64336C...Perform two-particle decays in respective CM frame.
64337 460 DO 480 IL=1,ND-1
64338 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64339 UE(3)=2D0*PYR(0)-1D0
64340 PHI=PARU(2)*PYR(0)
64341 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
64342 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
64343 DO 470 J=1,3
64344 P(N+IL,J)=PA*UE(J)
64345 PV(IL+1,J)=-PA*UE(J)
64346 470 CONTINUE
64347 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
64348 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
64349 480 CONTINUE
64350
64351C...Lorentz transform decay products to lab frame.
64352 DO 490 J=1,4
64353 P(N+ND,J)=PV(ND,J)
64354 490 CONTINUE
64355 DO 530 IL=ND-1,1,-1
64356 DO 500 J=1,3
64357 BE(J)=PV(IL,J)/PV(IL,4)
64358 500 CONTINUE
64359 GA=PV(IL,4)/PV(IL,5)
64360 DO 520 I=N+IL,N+ND
64361 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64362 DO 510 J=1,3
64363 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64364 510 CONTINUE
64365 P(I,4)=GA*(P(I,4)+BEP)
64366 520 CONTINUE
64367 530 CONTINUE
64368
64369C...Check that no infinite loop in matrix element weight.
64370 NTRY=NTRY+1
64371 IF(NTRY.GT.800) GOTO 560
64372
64373C...Matrix elements for omega and phi decays.
64374 IF(MMAT.EQ.1) THEN
64375 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
64376 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
64377 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
64378 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
64379
64380C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
64381 ELSEIF(MMAT.EQ.2) THEN
64382 FOUR12=FOUR(N+1,N+2)
64383 FOUR13=FOUR(N+1,N+3)
64384 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
64385 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
64386 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
64387
64388C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
64389C...V vector), of form cos**2(theta02) in V1 rest frame, and for
64390C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
64391 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
64392 FOUR10=FOUR(IP,IM)
64393 FOUR12=FOUR(IP,N+1)
64394 FOUR02=FOUR(IM,N+1)
64395 PMS1=P(IP,5)**2
64396 PMS0=P(IM,5)**2
64397 PMS2=P(N+1,5)**2
64398 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
64399 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
64400 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
64401 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
64402 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
64403 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
64404
64405C...Matrix element for "onium" -> g + g + g or gamma + g + g.
64406 ELSEIF(MMAT.EQ.4) THEN
64407 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64408 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
64409 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
64410 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
64411 & ((1D0-HX3)/(HX1*HX2))**2
64412 IF(WT.LT.2D0*PYR(0)) GOTO 390
64413 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
64414 & GOTO 390
64415
64416C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
64417 ELSEIF(MMAT.EQ.41) THEN
64418 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64419 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
64420 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
64421 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
64422
64423C...Matrix elements for weak decays (only semileptonic for c and b)
64424 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64425 & .AND.ND.EQ.3) THEN
64426 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
64427 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
64428 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64429 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
64430 DO 550 J=1,4
64431 P(N+NP+1,J)=0D0
64432 DO 540 IS=N+3,N+NP
64433 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
64434 540 CONTINUE
64435 550 CONTINUE
64436 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
64437 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
64438 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64439 ENDIF
64440
64441C...Scale back energy and reattach spectator.
64442 560 IF(MREM.EQ.1) THEN
64443 DO 570 J=1,5
64444 PV(1,J)=PV(1,J)/(1D0-PQT)
64445 570 CONTINUE
64446 ND=ND+1
64447 MREM=0
64448 ENDIF
64449
64450C...Low invariant mass for system with spectator quark gives particle,
64451C...not two jets. Readjust momenta accordingly.
64452 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
64453 MSTJ(93)=1
64454 PM2=PYMASS(K(N+2,2))
64455 MSTJ(93)=1
64456 PM3=PYMASS(K(N+3,2))
64457 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
64458 & (PARJ(32)+PM2+PM3)**2) GOTO 630
64459 K(N+2,1)=1
64460 KFTEMP=K(N+2,2)
64461 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
64462 IF(K(N+2,2).EQ.0) GOTO 260
64463 P(N+2,5)=PYMASS(K(N+2,2))
64464 PS=P(N+1,5)+P(N+2,5)
64465 PV(2,5)=P(N+2,5)
64466 MMAT=0
64467 ND=2
64468 GOTO 460
64469 ELSEIF(MMAT.EQ.44) THEN
64470 MSTJ(93)=1
64471 PM3=PYMASS(K(N+3,2))
64472 MSTJ(93)=1
64473 PM4=PYMASS(K(N+4,2))
64474 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
64475 & (PARJ(32)+PM3+PM4)**2) GOTO 600
64476 K(N+3,1)=1
64477 KFTEMP=K(N+3,2)
64478 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
64479 IF(K(N+3,2).EQ.0) GOTO 260
64480 P(N+3,5)=PYMASS(K(N+3,2))
64481 DO 580 J=1,3
64482 P(N+3,J)=P(N+3,J)+P(N+4,J)
64483 580 CONTINUE
64484 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)
64485 HA=P(N+1,4)**2-P(N+2,4)**2
64486 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
64487 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
64488 & (P(N+1,3)-P(N+2,3))**2
64489 HD=(PV(1,4)-P(N+3,4))**2
64490 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
64491 HF=HD*HC-HB**2
64492 HG=HD*HC-HA*HB
64493 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
64494 DO 590 J=1,3
64495 PCOR=HH*(P(N+1,J)-P(N+2,J))
64496 P(N+1,J)=P(N+1,J)+PCOR
64497 P(N+2,J)=P(N+2,J)-PCOR
64498 590 CONTINUE
64499 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)
64500 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)
64501 ND=ND-1
64502 ENDIF
64503
64504C...Check invariant mass of W jets. May give one particle or start over.
64505 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64506 &.AND.IABS(K(N+1,2)).LT.10) THEN
64507 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
64508 MSTJ(93)=1
64509 PM1=PYMASS(K(N+1,2))
64510 MSTJ(93)=1
64511 PM2=PYMASS(K(N+2,2))
64512 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
64513 KFLDUM=INT(1.5D0+PYR(0))
64514 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
64515 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
64516 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
64517 PSM=PYMASS(KF1)+PYMASS(KF2)
64518 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
64519 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
64520 IF(MMAT.EQ.48) GOTO 390
64521 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
64522 K(N+1,1)=1
64523 KFTEMP=K(N+1,2)
64524 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
64525 IF(K(N+1,2).EQ.0) GOTO 260
64526 P(N+1,5)=PYMASS(K(N+1,2))
64527 K(N+2,2)=K(N+3,2)
64528 P(N+2,5)=P(N+3,5)
64529 PS=P(N+1,5)+P(N+2,5)
64530 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64531 PV(2,5)=P(N+3,5)
64532 MMAT=0
64533 ND=2
64534 GOTO 460
64535 ENDIF
64536
64537C...Phase space decay of partons from W decay.
64538 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
64539 KFLO(1)=K(N+1,2)
64540 KFLO(2)=K(N+2,2)
64541 K(N+1,1)=K(N+3,1)
64542 K(N+1,2)=K(N+3,2)
64543 DO 620 J=1,5
64544 PV(1,J)=P(N+1,J)+P(N+2,J)
64545 P(N+1,J)=P(N+3,J)
64546 620 CONTINUE
64547 PV(1,5)=PMR
64548 N=N+1
64549 NP=0
64550 NQ=2
64551 PS=0D0
64552 MSTJ(93)=2
64553 PSQ=PYMASS(KFLO(1))
64554 MSTJ(93)=2
64555 PSQ=PSQ+PYMASS(KFLO(2))
64556 MMAT=11
64557 GOTO 290
64558 ENDIF
64559
64560C...Boost back for rapidly moving particle.
64561 630 N=N+ND
64562 IF(MBST.EQ.1) THEN
64563 DO 640 J=1,3
64564 BE(J)=P(IP,J)/P(IP,4)
64565 640 CONTINUE
64566 GA=P(IP,4)/P(IP,5)
64567 DO 660 I=NSAV+1,N
64568 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64569 DO 650 J=1,3
64570 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64571 650 CONTINUE
64572 P(I,4)=GA*(P(I,4)+BEP)
64573 660 CONTINUE
64574 ENDIF
64575
64576C...Fill in position of decay vertex.
64577 DO 680 I=NSAV+1,N
64578 DO 670 J=1,4
64579 V(I,J)=VDCY(J)
64580 670 CONTINUE
64581 V(I,5)=0D0
64582 680 CONTINUE
64583
64584C...Set up for parton shower evolution from jets.
64585 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
64586 K(NSAV+1,1)=3
64587 K(NSAV+2,1)=3
64588 K(NSAV+3,1)=3
64589 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64590 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64591 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64592 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64593 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64594 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64595 MSTJ(92)=-(NSAV+1)
64596 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
64597 K(NSAV+2,1)=3
64598 K(NSAV+3,1)=3
64599 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64600 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
64601 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
64602 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64603 MSTJ(92)=NSAV+2
64604 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64605 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
64606 K(NSAV+1,1)=3
64607 K(NSAV+2,1)=3
64608 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64609 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
64610 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
64611 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64612 MSTJ(92)=NSAV+1
64613 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64614 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
64615 MSTJ(92)=NSAV+1
64616 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
64617 & THEN
64618 K(NSAV+1,1)=3
64619 K(NSAV+2,1)=3
64620 K(NSAV+3,1)=3
64621 KCP=PYCOMP(K(NSAV+1,2))
64622 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
64623 JCON=4
64624 IF(KQP.LT.0) JCON=5
64625 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
64626 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
64627 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
64628 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
64629 MSTJ(92)=NSAV+1
64630 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
64631 K(NSAV+1,1)=3
64632 K(NSAV+3,1)=3
64633 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
64634 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64635 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64636 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
64637 MSTJ(92)=NSAV+1
64638 ENDIF
64639
64640C...Mark decayed particle; special option for B-Bbar mixing.
64641 IF(K(IP,1).EQ.5) K(IP,1)=15
64642 IF(K(IP,1).LE.10) K(IP,1)=11
64643 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
64644 K(IP,4)=NSAV+1
64645 K(IP,5)=N
64646
64647 RETURN
64648 END
64649
64650
64651C*********************************************************************
64652
64653C...PYDCYK
64654C...Handles flavour production in the decay of unstable particles
64655C...and small string clusters.
64656
64657 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
64658
64659C...Double precision and integer declarations.
64660 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64661 IMPLICIT INTEGER(I-N)
64662 INTEGER PYK,PYCHGE,PYCOMP
64663C...Commonblocks.
64664 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64665 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64666 SAVE /PYDAT1/,/PYDAT2/
64667
64668
64669C.. Call PYKFDI directly if no popcorn option is on
64670 IF(MSTJ(12).LT.2) THEN
64671 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64672 MSTU(124)=KFL3
64673 RETURN
64674 ENDIF
64675
64676 KFL3=0
64677 KF=0
64678 IF(KFL1.EQ.0) RETURN
64679 KF1A=IABS(KFL1)
64680 KF2A=IABS(KFL2)
64681
64682 NSTO=130
64683 NMAX=MIN(MSTU(125),10)
64684
64685C.. Identify rank 0 cluster qq
64686 IRANK=1
64687 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
64688
64689 IF(KF2A.GT.0)THEN
64690C.. Join jets: Fails if store not empty
64691 IF(MSTU(121).GT.0) THEN
64692 MSTU(121)=0
64693 RETURN
64694 ENDIF
64695 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64696 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
64697C.. Pick popcorn meson from store, return same qq, decrease store
64698 KF=MSTU(NSTO+MSTU(121))
64699 KFL3=-KFL1
64700 MSTU(121)=MSTU(121)-1
64701 ELSE
64702C.. Generate new flavour. Then done if no diquark is generated
64703 100 CALL PYKFDI(KFL1,0,KFL3,KF)
64704 IF(MSTU(121).EQ.-1) GOTO 100
64705 MSTU(124)=KFL3
64706 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
64707
64708C.. Simple case if no dynamical popcorn suppressions are considered
64709 IF(MSTJ(12).LT.4) THEN
64710 IF(MSTU(121).EQ.0) RETURN
64711 NMES=1
64712 KFPREV=-KFL3
64713 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64714C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
64715 IF(IABS(KFL3).LE.10)THEN
64716 KFL3=-KFPREV
64717 RETURN
64718 ENDIF
64719 GOTO 120
64720 ENDIF
64721
64722C test output qq against fake Gamma, then return if no popcorn.
64723 GB=2D0
64724 IF(IRANK.NE.0)THEN
64725 CALL PYZDIS(1,2103,5D0,Z)
64726 GB=5D0*(1D0-Z)/Z
64727 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
64728 MSTU(121)=0
64729 GOTO 100
64730 ENDIF
64731 ENDIF
64732 IF(MSTU(121).EQ.0) RETURN
64733
64734C..Set store size memory. Pick fake dynamical variables of qq.
64735 NMES=MSTU(121)
64736 CALL PYPTDI(1,PX3,PY3)
64737 X=1D0
64738 POPM=0D0
64739 G=GB
64740 POPG=GB
64741
64742C.. Pick next popcorn meson, test with fake dynamical variables
64743 110 KFPREV=-KFL3
64744 PX1=-PX3
64745 PY1=-PY3
64746 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64747 IF(MSTU(121).EQ.-1) GOTO 100
64748 CALL PYPTDI(KFL3,PX3,PY3)
64749 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
64750 CALL PYZDIS(KFPREV,KFL3,PM,Z)
64751 G=(1D0-Z)*(G+PM/Z)
64752 X=(1D0-Z)*X
64753
64754 PTST=1D0
64755 GTST=1D0
64756 RTST=PYR(0)
64757 IF(MSTJ(12).GT.4)THEN
64758 POPMN=SQRT((1D0-X)*(G/X-GB))
64759 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64760 PTST=EXP((POPM-POPMN)*PARF(193))
64761 POPM=POPMN
64762 ENDIF
64763 IF(IRANK.NE.0)THEN
64764 POPGN=X*GB
64765 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
64766 POPG=POPGN
64767 ENDIF
64768 IF(RTST.GT.PTST*GTST)THEN
64769 MSTU(121)=0
64770 IF(RTST.GT.PTST) MSTU(121)=-1
64771 GOTO 100
64772 ENDIF
64773
64774C.. Store meson
64775 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
64776 IF(MSTU(121).GT.0) GOTO 110
64777
64778C.. Test accepted system size. If OK set global popcorn size variable.
64779 IF(NMES.GT.NMAX)THEN
64780 KF=0
64781 KFL3=0
64782 RETURN
64783 ENDIF
64784 MSTU(121)=NMES
64785 ENDIF
64786
64787 RETURN
64788 END
64789
64790C********************************************************************
64791
64792C...PYKFDI
64793C...Generates a new flavour pair and combines off a hadron
64794
64795 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
64796
64797C...Double precision and integer declarations.
64798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64799 IMPLICIT INTEGER(I-N)
64800 INTEGER PYK,PYCHGE,PYCOMP
64801C...Commonblocks.
64802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64803 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64804 SAVE /PYDAT1/,/PYDAT2/
64805C...Local arrays.
64806 DIMENSION PD(7)
64807
64808 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
64809
64810C...Default flavour values. Input consistency checks.
64811 KF1A=IABS(KFL1)
64812 KF2A=IABS(KFL2)
64813 KFL3=0
64814 KF=0
64815 IF(KF1A.EQ.0) RETURN
64816 IF(KF2A.NE.0)THEN
64817 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
64818 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
64819 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
64820 ENDIF
64821
64822C...Check if tabulated flavour probabilities are to be used.
64823 IF(MSTJ(15).EQ.1) THEN
64824 IF(MSTJ(12).GE.5) CALL PYERRM(29,
64825 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
64826 & ' together with MSTJ(12)>=5 modification')
64827 KTAB1=-1
64828 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
64829 KFL1A=MOD(KF1A/1000,10)
64830 KFL1B=MOD(KF1A/100,10)
64831 KFL1S=MOD(KF1A,10)
64832 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
64833 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
64834 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
64835 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
64836 KTAB2=0
64837 IF(KF2A.NE.0) THEN
64838 KTAB2=-1
64839 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
64840 KFL2A=MOD(KF2A/1000,10)
64841 KFL2B=MOD(KF2A/100,10)
64842 KFL2S=MOD(KF2A,10)
64843 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
64844 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
64845 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
64846 ENDIF
64847 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
64848 ENDIF
64849
64850C.. Recognize rank 0 diquark case
64851 100 IRANK=1
64852 KFDIQ=MAX(KF1A,KF2A)
64853 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
64854
64855C.. Join two flavours to meson or baryon. Test for popcorn.
64856 IF(KF2A.GT.0)THEN
64857 MBARY=0
64858 IF(KFDIQ.GT.10) THEN
64859 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
64860 & CALL PYNMES(KFDIQ)
64861 IF(MSTU(121).NE.0) THEN
64862 MSTU(121)=0
64863 RETURN
64864 ENDIF
64865 MBARY=2
64866 ENDIF
64867 KFQOLD=KF1A
64868 KFQVER=KF2A
64869 GOTO 130
64870 ENDIF
64871
64872C.. Separate incoming flavours, curtain flavour consistency check
64873 KFIN=KFL1
64874 KFQOLD=KF1A
64875 KFQPOP=KF1A/10000
64876 IF(KF1A.GT.10)THEN
64877 KFIN=-KFL1
64878 KFL1A=MOD(KF1A/1000,10)
64879 KFL1B=MOD(KF1A/100,10)
64880 IF(IRANK.EQ.0)THEN
64881 QAWT=1D0
64882 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
64883 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
64884 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
64885 ENDIF
64886 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
64887 MSTU(121)=0
64888 RETURN
64889 ENDIF
64890 KFQOLD=KFL1A+KFL1B-KFQPOP
64891 ENDIF
64892
64893C...Meson/baryon choice. Set number of mesons if starting a popcorn
64894C...system.
64895 110 MBARY=0
64896 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
64897 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
64898 MBARY=1
64899 CALL PYNMES(0)
64900 ENDIF
64901 ELSEIF(KF1A.GT.10)THEN
64902 MBARY=2
64903 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
64904 IF(MSTU(121).GT.0) MBARY=-1
64905 ENDIF
64906
64907C..x->H+q: Choose single vertex quark. Jump to form hadron.
64908 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
64909 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
64910 KFL3=ISIGN(KFQVER,-KFIN)
64911 GOTO 130
64912 ENDIF
64913
64914C..x->H+qq: (IDW=proper PARF position for diquark weights)
64915 IDW=160
64916 IF(MBARY.EQ.1)THEN
64917 IF(MSTU(121).EQ.0) IDW=150
64918 SQWT=PARF(IDW+1)
64919 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
64920 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
64921C.. Shift to s-curtain parameters if needed
64922 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
64923 PARF(194)=PARF(138)*PARF(139)
64924 PARF(193)=PARJ(8)+PARJ(9)
64925 ENDIF
64926 ENDIF
64927
64928C.. x->H+qq: Get vertex quark
64929 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64930 IDW=MSTU(122)
64931 MSTU(121)=MSTU(121)-1
64932 IF(IDW.EQ.170) THEN
64933 IF(MSTU(121).EQ.0)THEN
64934 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
64935 ELSE
64936 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
64937 ENDIF
64938 ELSE
64939 IF(MSTU(121).EQ.0)THEN
64940 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
64941 ELSE
64942 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
64943 ENDIF
64944 ENDIF
64945 IPOS=200+30*IPOS+1
64946
64947 IMES=-1
64948 RMES=PYR(0)*PARF(194)
64949 120 IMES=IMES+1
64950 RMES=RMES-PARF(IPOS+IMES)
64951 IF(IMES.EQ.30) THEN
64952 MSTU(121)=-1
64953 KF=-111
64954 RETURN
64955 ENDIF
64956 IF(RMES.GT.0D0) GOTO 120
64957 KMUL=IMES/5
64958 KFJ=2*KMUL+1
64959 IF(KMUL.EQ.2) KFJ=10003
64960 IF(KMUL.EQ.3) KFJ=10001
64961 IF(KMUL.EQ.4) KFJ=20003
64962 IF(KMUL.EQ.5) KFJ=5
64963 IDIAG=0
64964 KFQVER=MOD(IMES,5)+1
64965 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
64966 IF(KFQVER.GT.3)THEN
64967 IDIAG=KFQVER-3
64968 KFQVER=KFQOLD
64969 ENDIF
64970 ELSE
64971 IF(MBARY.EQ.-1) IDW=170
64972 SQWT=PARF(IDW+2)
64973 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
64974 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
64975 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
64976 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
64977 KFQVER=KFQPOP
64978 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
64979 ENDIF
64980 ENDIF
64981
64982C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
64983 KFLDS=3
64984 IF(KFQPOP.NE.KFQVER)THEN
64985 SWT=PARF(IDW+7)
64986 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
64987 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
64988 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
64989 ENDIF
64990 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
64991 & +10000*KFQPOP
64992 KFL3=ISIGN(KFDIQ,KFIN)
64993
64994C..x->M+y: flavour for meson.
64995 130 IF(MBARY.LE.0)THEN
64996 KFLA=MAX(KFQOLD,KFQVER)
64997 KFLB=MIN(KFQOLD,KFQVER)
64998 KFS=ISIGN(1,KFL1)
64999 IF(KFLA.NE.KFQOLD) KFS=-KFS
65000C... Form meson, with spin and flavour mixing for diagonal states.
65001 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
65002 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
65003 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
65004 RETURN
65005 ENDIF
65006 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
65007 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
65008 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
65009 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
65010 IF(PYR(0).LT.PARJ(14)) KMUL=2
65011 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
65012 RMUL=PYR(0)
65013 IF(RMUL.LT.PARJ(15)) KMUL=3
65014 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
65015 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
65016 ENDIF
65017 KFLS=3
65018 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
65019 IF(KMUL.EQ.5) KFLS=5
65020 IF(KFLA.NE.KFLB)THEN
65021 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
65022 ELSE
65023 RMIX=PYR(0)
65024 IMIX=2*KFLA+10*KMUL
65025 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
65026 & INT(RMIX+PARF(IMIX)))+KFLS
65027 IF(KFLA.GE.4) KF=110*KFLA+KFLS
65028 ENDIF
65029 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
65030 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
65031
65032C..Optional extra suppression of eta and eta'.
65033C..Allow shift to qq->B+q in old version (set IRANK to 0)
65034 IF(KF.EQ.221.OR.KF.EQ.331)THEN
65035 IF(PYR(0).GT.PARJ(25+KF/300))THEN
65036 IF(KF2A.GT.0) GOTO 130
65037 IF(MSTJ(12).LT.4) IRANK=0
65038 GOTO 110
65039 ENDIF
65040 ENDIF
65041 MSTU(121)=0
65042
65043C.. x->B+y: Flavour for baryon
65044 ELSE
65045 KFLA=KFQVER
65046 IF(KF1A.LE.10) KFLA=KFQOLD
65047 KFLB=MOD(KFDIQ/1000,10)
65048 KFLC=MOD(KFDIQ/100,10)
65049 KFLDS=MOD(KFDIQ,10)
65050 KFLD=MAX(KFLA,KFLB,KFLC)
65051 KFLF=MIN(KFLA,KFLB,KFLC)
65052 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65053
65054C... SU(6) factors for formation of baryon.
65055 KBARY=3
65056 KDMAX=5
65057 KFLG=KFLB
65058 IF(KFLB.NE.KFLC)THEN
65059 KBARY=2*KFLDS-1
65060 KDMAX=1+KFLDS/2
65061 IF(KFLB.GT.2) KDMAX=KDMAX+2
65062 ENDIF
65063 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
65064 KBARY=KBARY+1
65065 KFLG=KFLA
65066 ENDIF
65067
65068 SU6MAX=PARF(140+KDMAX)
65069 SU6DEC=PARJ(18)
65070 SU6S =PARF(146)
65071 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
65072 SU6MAX=1D0
65073 SU6DEC=1D0
65074 SU6S =1D0
65075 ENDIF
65076 SU6OCT=PARF(60+KBARY)
65077 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
65078 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
65079 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
65080 ELSE
65081 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
65082 ENDIF
65083 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
65084
65085C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
65086 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
65087 MSTU(121)=0
65088 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
65089 GOTO 110
65090 ENDIF
65091
65092C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
65093 KSIG=1
65094 KFLS=2
65095 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
65096 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
65097 KSIG=KFLDS/3
65098 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
65099 ENDIF
65100 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
65101 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
65102 ENDIF
65103 RETURN
65104
65105C...Use tabulated probabilities to select new flavour and hadron.
65106 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
65107 KT3L=1
65108 KT3U=6
65109 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
65110 KT3L=1
65111 KT3U=6
65112 ELSEIF(KTAB2.EQ.0) THEN
65113 KT3L=1
65114 KT3U=22
65115 ELSE
65116 KT3L=KTAB2
65117 KT3U=KTAB2
65118 ENDIF
65119 RFL=0D0
65120 DO 160 KTS=0,2
65121 DO 150 KT3=KT3L,KT3U
65122 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
65123 150 CONTINUE
65124 160 CONTINUE
65125 RFL=PYR(0)*RFL
65126 DO 180 KTS=0,2
65127 KTABS=KTS
65128 DO 170 KT3=KT3L,KT3U
65129 KTAB3=KT3
65130 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
65131 IF(RFL.LE.0D0) GOTO 190
65132 170 CONTINUE
65133 180 CONTINUE
65134 190 CONTINUE
65135
65136C...Reconstruct flavour of produced quark/diquark.
65137 IF(KTAB3.LE.6) THEN
65138 KFL3A=KTAB3
65139 KFL3B=0
65140 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
65141 ELSE
65142 KFL3A=1
65143 IF(KTAB3.GE.8) KFL3A=2
65144 IF(KTAB3.GE.11) KFL3A=3
65145 IF(KTAB3.GE.16) KFL3A=4
65146 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
65147 KFL3=1000*KFL3A+100*KFL3B+1
65148 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
65149 & KFL3+2
65150 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
65151 ENDIF
65152
65153C...Reconstruct meson code.
65154 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
65155 &KFL3B.NE.0)) THEN
65156 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65157 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
65158 KF=110+2*KTABS+1
65159 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
65160 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65161 & 25*KTABS)) KF=330+2*KTABS+1
65162 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
65163 KFLA=MAX(KTAB1,KTAB3)
65164 KFLB=MIN(KTAB1,KTAB3)
65165 KFS=ISIGN(1,KFL1)
65166 IF(KFLA.NE.KF1A) KFS=-KFS
65167 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65168 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
65169 KFS=ISIGN(1,KFL1)
65170 IF(KFL1A.EQ.KFL3A) THEN
65171 KFLA=MAX(KFL1B,KFL3B)
65172 KFLB=MIN(KFL1B,KFL3B)
65173 IF(KFLA.NE.KFL1B) KFS=-KFS
65174 ELSEIF(KFL1A.EQ.KFL3B) THEN
65175 KFLA=KFL3A
65176 KFLB=KFL1B
65177 KFS=-KFS
65178 ELSEIF(KFL1B.EQ.KFL3A) THEN
65179 KFLA=KFL1A
65180 KFLB=KFL3B
65181 ELSEIF(KFL1B.EQ.KFL3B) THEN
65182 KFLA=MAX(KFL1A,KFL3A)
65183 KFLB=MIN(KFL1A,KFL3A)
65184 IF(KFLA.NE.KFL1A) KFS=-KFS
65185 ELSE
65186 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
65187 GOTO 100
65188 ENDIF
65189 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65190
65191C...Reconstruct baryon code.
65192 ELSE
65193 IF(KTAB1.GE.7) THEN
65194 KFLA=KFL3A
65195 KFLB=KFL1A
65196 KFLC=KFL1B
65197 ELSE
65198 KFLA=KFL1A
65199 KFLB=KFL3A
65200 KFLC=KFL3B
65201 ENDIF
65202 KFLD=MAX(KFLA,KFLB,KFLC)
65203 KFLF=MIN(KFLA,KFLB,KFLC)
65204 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65205 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
65206 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
65207 ENDIF
65208
65209C...Check that constructed flavour code is an allowed one.
65210 IF(KFL2.NE.0) KFL3=0
65211 KC=PYCOMP(KF)
65212 IF(KC.EQ.0) THEN
65213 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
65214 & 'failed')
65215 GOTO 100
65216 ENDIF
65217
65218 RETURN
65219 END
65220
65221C*********************************************************************
65222
65223C...PYNMES
65224C...Generates number of popcorn mesons and stores some relevant
65225C...parameters.
65226
65227 SUBROUTINE PYNMES(KFDIQ)
65228
65229C...Double precision and integer declarations.
65230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65231 IMPLICIT INTEGER(I-N)
65232 INTEGER PYK,PYCHGE,PYCOMP
65233C...Commonblocks.
65234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65236 SAVE /PYDAT1/,/PYDAT2/
65237
65238 MSTU(121)=0
65239 IF(MSTJ(12).LT.2) RETURN
65240
65241C..Old version: Get 1 or 0 popcorn mesons
65242 IF(MSTJ(12).LT.5)THEN
65243 POPWT=PARF(131)
65244 IF(KFDIQ.NE.0) THEN
65245 KFDIQA=IABS(KFDIQ)
65246 KFA=MOD(KFDIQA/1000,10)
65247 KFB=MOD(KFDIQA/100,10)
65248 KFS=MOD(KFDIQA,10)
65249 POPWT=PARF(132)
65250 IF(KFA.EQ.3) POPWT=PARF(133)
65251 IF(KFB.EQ.3) POPWT=PARF(134)
65252 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
65253 ENDIF
65254 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
65255 RETURN
65256 ENDIF
65257
65258C..New version: Store popcorn- or rank 0 diquark parameters
65259 MSTU(122)=170
65260 PARF(193)=PARJ(8)
65261 PARF(194)=PARF(139)
65262 IF(KFDIQ.NE.0) THEN
65263 MSTU(122)=180
65264 PARF(193)=PARJ(10)
65265 PARF(194)=PARF(140)
65266 ENDIF
65267 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
65268 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
65269 & '(PYNMES:) Neglecting too large popcorn possibility')
65270 RETURN
65271 ENDIF
65272
65273C..New version: Get number of popcorn mesons
65274 100 RTST=PYR(0)
65275 MSTU(121)=-1
65276 110 MSTU(121)=MSTU(121)+1
65277 RTST=RTST/PARF(194)
65278 IF(RTST.LT.1D0) GOTO 110
65279 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
65280 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
65281 RETURN
65282 END
65283
65284C***************************************************************
65285
65286C...PYKFIN
65287C...Precalculates a set of diquark and popcorn weights.
65288
65289 SUBROUTINE PYKFIN
65290
65291C...Double precision and integer declarations.
65292 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65293 IMPLICIT INTEGER(I-N)
65294 INTEGER PYK,PYCHGE,PYCOMP
65295C...Commonblocks.
65296 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65297 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65298 SAVE /PYDAT1/,/PYDAT2/
65299
65300 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
65301
65302
65303 MSTU(123)=1
65304C..Diquark indices for dimensional variables
65305 IUD1=1
65306 IUU1=2
65307 IUS0=3
65308 ISU0=4
65309 IUS1=5
65310 ISU1=6
65311 ISS1=7
65312
65313C.. *** SU(6) factors **
65314C..Modify with decuplet- (and Sigma/Lambda-) suppression.
65315 PARF(146)=1D0
65316 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
65317 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
65318 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
65319 DO 100 I=1,6
65320 SU6(I)=PARF(60+I)
65321 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
65322 100 CONTINUE
65323 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
65324 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
65325 DO 110 I=1,6
65326 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
65327 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
65328 110 CONTINUE
65329
65330C..SU(6)max q q' s,c,b
65331 SU6MUD =MAX(SU6(1) , SU6(8) )
65332 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
65333 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
65334 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
65335 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
65336 SU6M(IUS0)=SU6M(ISU0)
65337 SU6M(ISS1)=SU6M(IUU1)
65338 SU6M(IUS1)=SU6M(ISU1)
65339
65340C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
65341 PARF(141)=SU6MUD
65342 PARF(142)=SU6M(IUD1)
65343 PARF(143)=SU6M(ISU0)
65344 PARF(144)=SU6M(ISU1)
65345 PARF(145)=SU6M(ISS1)
65346
65347C..diquark SU(6) survival =
65348C..sum over quark (quark tunnel weight)*(SU(6)).
65349 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
65350 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
65351 DMB(IUS0)=DMB(ISU0)
65352 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
65353 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
65354 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
65355 DMB(IUS1)=DMB(ISU1)
65356 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
65357
65358C.. *** Tunneling factors for Diquark production***
65359C.. T: half a curtain pair = sqrt(curtain pair factor)
65360 IF(MSTJ(12).GE.5) THEN
65361 PMUD0=PYMASS(2101)
65362 PMUD1=PYMASS(2103)-PMUD0
65363 PMUS0=PYMASS(3201)-PMUD0
65364 PMUS1=PYMASS(3203)-PMUS0-PMUD0
65365 PMSS1=PYMASS(3303)-PMUS0-PMUD0
65366 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
65367 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
65368 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
65369 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
65370 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
65371 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
65372 QBB(IUD1)=QBB(IUU1)
65373 ELSE
65374 PAR2M=SQRT(PARJ(2))
65375 PAR3M=SQRT(PARJ(3))
65376 PAR4M=SQRT(PARJ(4))
65377 QBB(ISU0)=PAR2M*PAR3M
65378 QBB(IUS0)=PAR3M
65379 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
65380 QBB(IUU1)=PAR4M
65381 QBB(ISU1)=PAR4M*QBB(ISU0)
65382 QBB(IUS1)=PAR4M*QBB(IUS0)
65383 QBB(IUD1)=PAR4M
65384 ENDIF
65385
65386C.. tau: spin*(vertex factor)*(T = half-curtain factor)
65387 QBM(ISU0)=QBB(ISU0)
65388 QBM(IUS0)=PARJ(2)*QBB(IUS0)
65389 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
65390 QBM(IUU1)=6D0*QBB(IUU1)
65391 QBM(ISU1)=3D0*QBB(ISU1)
65392 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
65393 QBM(IUD1)=3D0*QBB(IUD1)
65394
65395C.. Combine T and tau to diquark weight for q-> B+B+..
65396 DO 120 I=1,7
65397 QBB(I)=QBB(I)*QBM(I)
65398 120 CONTINUE
65399
65400 IF(MSTJ(12).GE.5)THEN
65401C..New version: tau for rank 0 diquark.
65402 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
65403 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
65404 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
65405 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
65406 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
65407 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
65408 DMB(7+IUD1)=DMB(7+IUU1)/2D0
65409
65410C..New version: curtain flavour ratios.
65411C.. s/u for q->B+M+...
65412C.. s/u for rank 0 diquark: su -> ...M+B+...
65413C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65414 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65415 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65416 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
65417 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
65418 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
65419 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
65420 ELSE
65421C..Old version: reset unused rank 0 diquark weights and
65422C.. unused diquark SU(6) survival weights
65423 DO 130 I=1,7
65424 IF(MSTJ(12).LT.3) DMB(I)=1D0
65425 DMB(7+I)=1D0
65426 130 CONTINUE
65427
65428C..Old version: Shuffle PARJ(7) into tau
65429 QBM(IUS0)=QBM(IUS0)*PARJ(7)
65430 QBM(ISS1)=QBM(ISS1)*PARJ(7)
65431 QBM(IUS1)=QBM(IUS1)*PARJ(7)
65432
65433C..Old version: curtain flavour ratios.
65434C.. s/u for q->B+M+...
65435C.. s/u for rank 0 diquark: su -> ...M+B+...
65436C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65437 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65438 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65439 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
65440 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
65441 ENDIF
65442
65443C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
65444C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
65445 DO 140 I=1,7
65446 DMB(7+I)=DMB(7+I)*DMB(I)
65447 DMB(I)=DMB(I)*QBM(I)
65448 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
65449 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
65450 140 CONTINUE
65451
65452C.. *** Popcorn factors ***
65453
65454 IF(MSTJ(12).LT.5)THEN
65455C.. Old version: Resulting popcorn weights.
65456 PARF(138)=PARJ(6)
65457 WS=PARF(135)*PARF(138)
65458 WQ=WU*PARJ(5)/3D0
65459 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
65460 PARF(133)=WQ*
65461 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
65462 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
65463 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
65464 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
65465 & (1D0+QBB(IUD1)+QBB(IUU1)+
65466 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
65467 ELSE
65468C..New version: Store weights for popcorn mesons,
65469C..get prel. popcorn weights.
65470 DO 150 IPOS=201,1400
65471 PARF(IPOS)=0D0
65472 150 CONTINUE
65473 DO 160 I=138,140
65474 PARF(I)=0D0
65475 160 CONTINUE
65476 IPOS=200
65477 PARF(193)=PARJ(8)
65478 DO 240 MR=0,7,7
65479 IF(MR.EQ.7) PARF(193)=PARJ(10)
65480 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
65481 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65482 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65483 DO 230 NMES=0,1
65484 IF(NMES.EQ.1) SQWT=PARJ(2)
65485 DO 220 KFQPOP=1,4
65486 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
65487 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
65488 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
65489 QQWT=0.5D0
65490 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
65491 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
65492 ENDIF
65493 DO 210 KFQOLD =1,5
65494 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
65495 IF(NMES.EQ.1) THEN
65496 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
65497 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
65498 ENDIF
65499 WTTOT=0D0
65500 WTFAIL=0D0
65501 DO 190 KMUL=0,5
65502 PJWT=PARJ(12+KMUL)
65503 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
65504 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
65505 IF(PJWT.LE.0D0) GOTO 190
65506 IF(PJWT.GT.1D0) PJWT=1D0
65507 IMES=5*KMUL
65508 IMIX=2*KFQOLD+10*KMUL
65509 KFJ=2*KMUL+1
65510 IF(KMUL.EQ.2) KFJ=10003
65511 IF(KMUL.EQ.3) KFJ=10001
65512 IF(KMUL.EQ.4) KFJ=20003
65513 IF(KMUL.EQ.5) KFJ=5
65514 DO 180 KFQVER =1,3
65515 KFLA=MAX(KFQOLD,KFQVER)
65516 KFLB=MIN(KFQOLD,KFQVER)
65517 SWT=PARJ(11+KFLA/3+KFLA/4)
65518 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
65519 SWT=SWT*PJWT
65520 QWT=SQWT/(2D0+SQWT)
65521 IF(KFQVER.LT.3)THEN
65522 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
65523 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
65524 ENDIF
65525 IF(KFQVER.NE.KFQOLD)THEN
65526 IMES=IMES+1
65527 KFM=100*KFLA+10*KFLB+KFJ
65528 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65529 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
65530 WTTOT=WTTOT+PARF(IPOS+IMES)
65531 ELSE
65532 DO 170 ID=3,5
65533 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
65534 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
65535 IF(ID.EQ.5) DWT=PARF(IMIX)
65536 KFM=110*(ID-2)+KFJ
65537 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65538 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
65539 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
65540 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
65541 PARF(IPOS+5*KMUL+ID)=
65542 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
65543 ENDIF
65544 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
65545 170 CONTINUE
65546 ENDIF
65547 180 CONTINUE
65548 190 CONTINUE
65549 DO 200 IMES=1,30
65550 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
65551 200 CONTINUE
65552 IF(MR.EQ.7) PARF(140)=
65553 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
65554 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
65555 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
65556 IPOS=IPOS+30
65557 210 CONTINUE
65558 220 CONTINUE
65559 230 CONTINUE
65560 240 CONTINUE
65561 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
65562 MSTU(121)=0
65563
65564 ENDIF
65565
65566C..Recombine diquark weights to flavour and spin ratios
65567 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
65568 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
65569 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
65570 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
65571 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
65572 PARF(155)=QBB(ISU1)/QBB(ISU0)
65573 PARF(156)=QBB(IUS1)/QBB(IUS0)
65574 PARF(157)=QBB(IUD1)
65575
65576 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
65577 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
65578 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
65579 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
65580 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
65581 PARF(165)=QBM(ISU1)/QBM(ISU0)
65582 PARF(166)=QBM(IUS1)/QBM(IUS0)
65583 PARF(167)=QBM(IUD1)
65584
65585 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
65586 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
65587 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
65588 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
65589 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
65590 PARF(175)=DMB(ISU1)/DMB(ISU0)
65591 PARF(176)=DMB(IUS1)/DMB(IUS0)
65592 PARF(177)=DMB(IUD1)
65593
65594 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
65595 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
65596 PARF(187)=DMB(7+IUD1)
65597
65598 RETURN
65599 END
65600
65601
65602C*********************************************************************
65603
65604C...PYPTDI
65605C...Generates transverse momentum according to a Gaussian.
65606
65607 SUBROUTINE PYPTDI(KFL,PX,PY)
65608
65609C...Double precision and integer declarations.
65610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65611 IMPLICIT INTEGER(I-N)
65612 INTEGER PYK,PYCHGE,PYCOMP
65613C...Commonblocks.
65614 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65615 SAVE /PYDAT1/
65616
65617C...Generate p_T and azimuthal angle, gives p_x and p_y.
65618 KFLA=IABS(KFL)
65619 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
65620 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
65621 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
65622 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
65623 PHI=PARU(2)*PYR(0)
65624 PX=PT*COS(PHI)
65625 PY=PT*SIN(PHI)
65626
65627 RETURN
65628 END
65629
65630C*********************************************************************
65631
65632C...PYZDIS
65633C...Generates the longitudinal splitting variable z.
65634
65635 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
65636
65637C...Double precision and integer declarations.
65638 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65639 IMPLICIT INTEGER(I-N)
65640 INTEGER PYK,PYCHGE,PYCOMP
65641C...Commonblocks.
65642 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65643 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65644 SAVE /PYDAT1/,/PYDAT2/
65645
65646C...Check if heavy flavour fragmentation.
65647 KFLA=IABS(KFL1)
65648 KFLB=IABS(KFL2)
65649 KFLH=KFLA
65650 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
65651
65652C...Lund symmetric scaling function: determine parameters of shape.
65653 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
65654 &MSTJ(11).GE.4) THEN
65655 FA=PARJ(41)
65656 IF(MSTJ(91).EQ.1) FA=PARJ(43)
65657 IF(KFLB.GE.10) FA=FA+PARJ(45)
65658 FBB=PARJ(42)
65659 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
65660 FB=FBB*PR
65661 FC=1D0
65662 IF(KFLA.GE.10) FC=FC-PARJ(45)
65663 IF(KFLB.GE.10) FC=FC+PARJ(45)
65664 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
65665 FRED=PARJ(46)
65666 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
65667 FC=FC+FRED*FBB*PARF(100+KFLH)**2
65668 ENDIF
65669 MC=1
65670 IF(ABS(FC-1D0).GT.0.01D0) MC=2
65671
65672C...Determine position of maximum. Special cases for a = 0 or a = c.
65673 IF(FA.LT.0.02D0) THEN
65674 MA=1
65675 ZMAX=1D0
65676 IF(FC.GT.FB) ZMAX=FB/FC
65677 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
65678 MA=2
65679 ZMAX=FB/(FB+FC)
65680 ELSE
65681 MA=3
65682 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
65683 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
65684 ENDIF
65685
65686C...Subdivide z range if distribution very peaked near endpoint.
65687 MMAX=2
65688 IF(ZMAX.LT.0.1D0) THEN
65689 MMAX=1
65690 ZDIV=2.75D0*ZMAX
65691 IF(MC.EQ.1) THEN
65692 FINT=1D0-LOG(ZDIV)
65693 ELSE
65694 ZDIVC=ZDIV**(1D0-FC)
65695 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
65696 ENDIF
65697 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
65698 MMAX=3
65699 FSCB=SQRT(4D0+(FC/FB)**2)
65700 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
65701 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
65702 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
65703 FINT=1D0+FB*(1D0-ZDIV)
65704 ENDIF
65705
65706C...Choice of z, preweighted for peaks at low or high z.
65707 100 Z=PYR(0)
65708 FPRE=1D0
65709 IF(MMAX.EQ.1) THEN
65710 IF(FINT*PYR(0).LE.1D0) THEN
65711 Z=ZDIV*Z
65712 ELSEIF(MC.EQ.1) THEN
65713 Z=ZDIV**Z
65714 FPRE=ZDIV/Z
65715 ELSE
65716 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
65717 FPRE=(ZDIV/Z)**FC
65718 ENDIF
65719 ELSEIF(MMAX.EQ.3) THEN
65720 IF(FINT*PYR(0).LE.1D0) THEN
65721 Z=ZDIV+LOG(Z)/FB
65722 FPRE=EXP(FB*(Z-ZDIV))
65723 ELSE
65724 Z=ZDIV+Z*(1D0-ZDIV)
65725 ENDIF
65726 ENDIF
65727
65728C...Weighting according to correct formula.
65729 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
65730 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
65731 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
65732 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
65733 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
65734
65735C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
65736 ELSE
65737 FC=PARJ(50+MAX(1,KFLH))
65738 IF(MSTJ(91).EQ.1) FC=PARJ(59)
65739 110 Z=PYR(0)
65740 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
65741 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
65742 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
65743 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
65744 & GOTO 110
65745 ELSE
65746 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
65747 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
65748 ENDIF
65749 ENDIF
65750
65751 RETURN
65752 END
65753
65754C*********************************************************************
65755
65756C...PYSHOW
65757C...Generates timelike parton showers from given partons.
65758
65759 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
65760
65761C...Double precision and integer declarations.
65762 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65763 IMPLICIT INTEGER(I-N)
65764 INTEGER PYK,PYCHGE,PYCOMP
65765C...Parameter statement to help give large particle numbers.
65766 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65767 &KEXCIT=4000000,KDIMEN=5000000)
65768 PARAMETER (MAXNUR=1000)
65769C...Commonblocks.
65770 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65771 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65775 COMMON/PYINT1/MINT(400),VINT(400)
65776 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
65777C...Local arrays.
65778 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
65779 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
65780 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
65781 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
65782 &IREF(1000)
65783
65784C...Check that QMAX not too low.
65785 IF(MSTJ(41).LE.0) THEN
65786 RETURN
65787 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
65788 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
65789 ELSE
65790 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
65791 & RETURN
65792 ENDIF
65793
65794C...Store positions of shower initiating partons.
65795 MPSPD=0
65796 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
65797 NPA=1
65798 IPA(1)=IP1
65799 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
65800 & MSTU(32))) THEN
65801 NPA=2
65802 IPA(1)=IP1
65803 IPA(2)=IP2
65804 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
65805 & .AND.IP2.GE.-80) THEN
65806 NPA=IABS(IP2)
65807 DO 100 I=1,NPA
65808 IPA(I)=IP1+I-1
65809 100 CONTINUE
65810 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
65811 &IP2.EQ.-100) THEN
65812 MPSPD=1
65813 NPA=2
65814 IPA(1)=IP1+6
65815 IPA(2)=IP1+7
65816 ELSE
65817 CALL PYERRM(12,
65818 & '(PYSHOW:) failed to reconstruct showering system')
65819 IF(MSTU(21).GE.1) RETURN
65820 ENDIF
65821
65822C...Send off to PYPTFS for pT-ordered evolution if requested,
65823C...if at least 2 partons, and without predefined shower branchings.
65824 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
65825 &MPSPD.EQ.0) THEN
65826 NPART=NPA
65827 DO 110 II=1,NPART
65828 IPART(II)=IPA(II)
65829 PTPART(II)=0.5D0*QMAX
65830 110 CONTINUE
65831 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
65832 RETURN
65833 ENDIF
65834
65835C...Initialization of cutoff masses etc.
65836 DO 120 IFL=0,40
65837 ISCOL(IFL)=0
65838 ISCHG(IFL)=0
65839 KSH(IFL)=0
65840 120 CONTINUE
65841 ISCOL(21)=1
65842 KSH(21)=1
65843 PMTH(1,21)=PYMASS(21)
65844 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
65845 PMTH(3,21)=2D0*PMTH(2,21)
65846 PMTH(4,21)=PMTH(3,21)
65847 PMTH(5,21)=PMTH(3,21)
65848 PMTH(1,22)=PYMASS(22)
65849 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
65850 PMTH(3,22)=2D0*PMTH(2,22)
65851 PMTH(4,22)=PMTH(3,22)
65852 PMTH(5,22)=PMTH(3,22)
65853 PMQTH1=PARJ(82)
65854 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
65855 PMQT1E=MIN(PMQTH1,PARJ(90))
65856 PMQTH2=PMTH(2,21)
65857 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
65858 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
65859 DO 130 IFL=1,5
65860 ISCOL(IFL)=1
65861 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
65862 KSH(IFL)=1
65863 PMTH(1,IFL)=PYMASS(IFL)
65864 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
65865 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
65866 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65867 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65868 130 CONTINUE
65869 DO 140 IFL=11,15,2
65870 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
65871 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
65872 PMTH(1,IFL)=PYMASS(IFL)
65873 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
65874 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
65875 PMTH(4,IFL)=PMTH(3,IFL)
65876 PMTH(5,IFL)=PMTH(3,IFL)
65877 140 CONTINUE
65878 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
65879 ALAMS=PARJ(81)**2
65880 ALFM=LOG(PT2MIN/ALAMS)
65881
65882C...Check on phase space available for emission.
65883 IREJ=0
65884 DO 150 J=1,5
65885 PS(J)=0D0
65886 150 CONTINUE
65887 PM=0D0
65888 KFLA(2)=0
65889 DO 170 I=1,NPA
65890 KFLA(I)=IABS(K(IPA(I),2))
65891 PMA(I)=P(IPA(I),5)
65892C...Special cutoff masses for initial partons (may be a heavy quark,
65893C...squark, ..., and need not be on the mass shell).
65894 IR=30+I
65895 IF(NPA.LE.1) IREF(I)=IR
65896 IF(NPA.GE.2) IREF(I+1)=IR
65897 ISCOL(IR)=0
65898 ISCHG(IR)=0
65899 KSH(IR)=0
65900 IF(KFLA(I).LE.8) THEN
65901 ISCOL(IR)=1
65902 IF(MSTJ(41).GE.2) ISCHG(IR)=1
65903 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
65904 & KFLA(I).EQ.17) THEN
65905 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
65906 ELSEIF(KFLA(I).EQ.21) THEN
65907 ISCOL(IR)=1
65908 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
65909 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
65910 ISCOL(IR)=1
65911 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
65912 ISCOL(IR)=1
65913C...QUARKONIA+++
65914C...same for QQ~[3S18]
65915 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
65916 & KFLA(I).EQ.9900553)) THEN
65917 ISCOL(IR)=1
65918C...QUARKONIA---
65919 ENDIF
65920 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
65921 PMTH(1,IR)=PMA(I)
65922 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
65923 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
65924 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
65925 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65926 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65927 ELSEIF(ISCOL(IR).EQ.1) THEN
65928 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
65929 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
65930 PMTH(4,IR)=PMTH(3,IR)
65931 PMTH(5,IR)=PMTH(3,IR)
65932 ELSEIF(ISCHG(IR).EQ.1) THEN
65933 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
65934 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
65935 PMTH(4,IR)=PMTH(3,IR)
65936 PMTH(5,IR)=PMTH(3,IR)
65937 ENDIF
65938 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
65939 PM=PM+PMA(I)
65940 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
65941 DO 160 J=1,4
65942 PS(J)=PS(J)+P(IPA(I),J)
65943 160 CONTINUE
65944 170 CONTINUE
65945 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
65946 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
65947 IF(NPA.EQ.1) PS(5)=PS(4)
65948 IF(PS(5).LE.PM+PMQT1E) RETURN
65949
65950C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
65951 KFSRCE=0
65952 IF(IP2.LE.0) THEN
65953 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
65954 KFSRCE=IABS(K(K(IP1,3),2))
65955 ELSE
65956 IPAR1=MAX(1,K(IP1,3))
65957 IPAR2=MAX(1,K(IP2,3))
65958 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
65959 & KFSRCE=IABS(K(K(IPAR1,3),2))
65960 ENDIF
65961 ITYPES=0
65962 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
65963 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
65964 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
65965 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
65966 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
65967 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
65968 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
65969 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
65970
65971C...Identify two primary showerers.
65972 ITYPE1=0
65973 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
65974 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
65975 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
65976 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
65977 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
65978 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
65979 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
65980 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
65981 ITYPE2=0
65982 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
65983 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
65984 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
65985 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
65986 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
65987 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
65988 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
65989 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
65990
65991C...Order of showerers. Presence of gluino.
65992 ITYPMN=MIN(ITYPE1,ITYPE2)
65993 ITYPMX=MAX(ITYPE1,ITYPE2)
65994 IORD=1
65995 IF(ITYPE1.GT.ITYPE2) IORD=2
65996 IGLUI=0
65997 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
65998
65999C...Check if 3-jet matrix elements to be used.
66000 M3JC=0
66001 ALPHA=0.5D0
66002 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
66003 IF(MSTJ(38).NE.0) THEN
66004 M3JC=MSTJ(38)
66005 ALPHA=PARJ(80)
66006 MSTJ(38)=0
66007 ELSEIF(MSTJ(47).GE.6) THEN
66008 M3JC=MSTJ(47)
66009 ELSE
66010 ICLASS=1
66011 ICOMBI=4
66012
66013C...Vector/axial vector -> q + qbar; q -> q + V.
66014 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
66015 & ITYPES.EQ.3)) THEN
66016 ICLASS=2
66017 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
66018 ICOMBI=1
66019 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
66020 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
66021C...gamma*/Z0: assume e+e- initial state if unknown.
66022 EI=-1D0
66023 IF(KFSRCE.EQ.23) THEN
66024 IANNFL=K(K(IP1,3),3)
66025 IF(IANNFL.NE.0) THEN
66026 KANNFL=IABS(K(IANNFL,2))
66027 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
66028 ENDIF
66029 ENDIF
66030 AI=SIGN(1D0,EI+0.1D0)
66031 VI=AI-4D0*EI*PARU(102)
66032 EF=KCHG(KFLA(1),1)/3D0
66033 AF=SIGN(1D0,EF+0.1D0)
66034 VF=AF-4D0*EF*PARU(102)
66035 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66036 SH=PS(5)**2
66037 SQMZ=PMAS(23,1)**2
66038 SQWZ=PS(5)*PMAS(23,2)
66039 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66040 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66041 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66042 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66043 ICOMBI=3
66044 ALPHA=VECT/(VECT+AXIV)
66045 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66046 ICOMBI=4
66047 ENDIF
66048C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66049 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66050 ICLASS=2
66051 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66052 & ITYPES.EQ.1)) THEN
66053 ICLASS=3
66054
66055C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66056 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66057 ICLASS=4
66058 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66059 ICOMBI=1
66060 ELSEIF(KFSRCE.EQ.36) THEN
66061 ICOMBI=2
66062 ENDIF
66063 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66064 & ITYPES.EQ.1)) THEN
66065 ICLASS=5
66066
66067C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66068 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66069 & ITYPES.EQ.3)) THEN
66070 ICLASS=6
66071 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66072 & ITYPES.EQ.2)) THEN
66073 ICLASS=7
66074 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66075 ICLASS=8
66076 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66077 & ITYPES.EQ.2)) THEN
66078 ICLASS=9
66079
66080C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66081 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66082 & ITYPES.EQ.5)) THEN
66083 ICLASS=10
66084 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66085 & ITYPES.EQ.2)) THEN
66086 ICLASS=11
66087 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66088 & ITYPES.EQ.1)) THEN
66089 ICLASS=12
66090
66091C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66092 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66093 ICLASS=13
66094 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66095 & ITYPES.EQ.2)) THEN
66096 ICLASS=14
66097 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66098 & ITYPES.EQ.1)) THEN
66099 ICLASS=15
66100
66101C...g -> ~g + ~g (eikonal approximation).
66102 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66103 ICLASS=16
66104 ENDIF
66105 M3JC=5*ICLASS+ICOMBI
66106 ENDIF
66107 ENDIF
66108
66109C...Find if interference with initial state partons.
66110 MIIS=0
66111 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
66112 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
66113 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
66114 &MIIS=MSTJ(50)-3
66115 IF(MIIS.NE.0) THEN
66116 DO 190 I=1,2
66117 KCII(I)=0
66118 KCA=PYCOMP(KFLA(I))
66119 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
66120 NIIS(I)=0
66121 IF(KCII(I).NE.0) THEN
66122 DO 180 J=1,2
66123 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
66124 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
66125 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
66126 NIIS(I)=NIIS(I)+1
66127 IIIS(I,NIIS(I))=ICSI
66128 ENDIF
66129 180 CONTINUE
66130 ENDIF
66131 190 CONTINUE
66132 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
66133 ENDIF
66134
66135C...Boost interfering initial partons to rest frame
66136C...and reconstruct their polar and azimuthal angles.
66137 IF(MIIS.NE.0) THEN
66138 DO 210 I=1,2
66139 DO 200 J=1,5
66140 K(N+I,J)=K(IPA(I),J)
66141 P(N+I,J)=P(IPA(I),J)
66142 V(N+I,J)=0D0
66143 200 CONTINUE
66144 210 CONTINUE
66145 DO 230 I=3,2+NIIS(1)
66146 DO 220 J=1,5
66147 K(N+I,J)=K(IIIS(1,I-2),J)
66148 P(N+I,J)=P(IIIS(1,I-2),J)
66149 V(N+I,J)=0D0
66150 220 CONTINUE
66151 230 CONTINUE
66152 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66153 DO 240 J=1,5
66154 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
66155 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
66156 V(N+I,J)=0D0
66157 240 CONTINUE
66158 250 CONTINUE
66159 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
66160 & -PS(2)/PS(4),-PS(3)/PS(4))
66161 PHI=PYANGL(P(N+1,1),P(N+1,2))
66162 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
66163 THE=PYANGL(P(N+1,3),P(N+1,1))
66164 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
66165 DO 260 I=3,2+NIIS(1)
66166 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
66167 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
66168 260 CONTINUE
66169 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66170 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
66171 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
66172 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
66173 270 CONTINUE
66174 ENDIF
66175
66176C...Boost 3 or more partons to their rest frame.
66177 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
66178 &-PS(2)/PS(4),-PS(3)/PS(4))
66179
66180C...Define imagined single initiator of shower for parton system.
66181 NS=N
66182 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
66183 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66184 IF(MSTU(21).GE.1) RETURN
66185 ENDIF
66186 280 N=NS
66187 IF(NPA.GE.2) THEN
66188 K(N+1,1)=11
66189 K(N+1,2)=21
66190 K(N+1,3)=0
66191 K(N+1,4)=0
66192 K(N+1,5)=0
66193 P(N+1,1)=0D0
66194 P(N+1,2)=0D0
66195 P(N+1,3)=0D0
66196 P(N+1,4)=PS(5)
66197 P(N+1,5)=PS(5)
66198 V(N+1,5)=PS(5)**2
66199 N=N+1
66200 IREF(1)=21
66201 ENDIF
66202
66203C...Loop over partons that may branch.
66204 NEP=NPA
66205 IM=NS
66206 IF(NPA.EQ.1) IM=NS-1
66207 290 IM=IM+1
66208 IF(N.GT.NS) THEN
66209 IF(IM.GT.N) GOTO 600
66210 KFLM=IABS(K(IM,2))
66211 IR=IREF(IM-NS)
66212 IF(KSH(IR).EQ.0) GOTO 290
66213 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
66214 IGM=K(IM,3)
66215 ELSE
66216 IGM=-1
66217 ENDIF
66218 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
66219 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66220 IF(MSTU(21).GE.1) RETURN
66221 ENDIF
66222
66223C...Position of aunt (sister to branching parton).
66224C...Origin and flavour of daughters.
66225 IAU=0
66226 IF(IGM.GT.0) THEN
66227 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
66228 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
66229 ENDIF
66230 IF(IGM.GE.0) THEN
66231 K(IM,4)=N+1
66232 DO 300 I=1,NEP
66233 K(N+I,3)=IM
66234 300 CONTINUE
66235 ELSE
66236 K(N+1,3)=IPA(1)
66237 ENDIF
66238 IF(IGM.LE.0) THEN
66239 DO 310 I=1,NEP
66240 K(N+I,2)=K(IPA(I),2)
66241 310 CONTINUE
66242 ELSEIF(KFLM.NE.21) THEN
66243 K(N+1,2)=K(IM,2)
66244 K(N+2,2)=K(IM,5)
66245 IREF(N+1-NS)=IREF(IM-NS)
66246 IREF(N+2-NS)=IABS(K(N+2,2))
66247 ELSEIF(K(IM,5).EQ.21) THEN
66248 K(N+1,2)=21
66249 K(N+2,2)=21
66250 IREF(N+1-NS)=21
66251 IREF(N+2-NS)=21
66252 ELSE
66253 K(N+1,2)=K(IM,5)
66254 K(N+2,2)=-K(IM,5)
66255 IREF(N+1-NS)=IABS(K(N+1,2))
66256 IREF(N+2-NS)=IABS(K(N+2,2))
66257 ENDIF
66258
66259C...Reset flags on daughters and tries made.
66260 DO 320 IP=1,NEP
66261 K(N+IP,1)=3
66262 K(N+IP,4)=0
66263 K(N+IP,5)=0
66264 KFLD(IP)=IABS(K(N+IP,2))
66265 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
66266 ITRY(IP)=0
66267 ISL(IP)=0
66268 ISI(IP)=0
66269 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
66270 320 CONTINUE
66271 ISLM=0
66272
66273C...Maximum virtuality of daughters.
66274 IF(IGM.LE.0) THEN
66275 DO 330 I=1,NPA
66276 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
66277 P(N+I,5)=MIN(QMAX,PS(5))
66278 IR=IREF(N+I-NS)
66279 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
66280 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
66281 330 CONTINUE
66282 ELSE
66283 IF(MSTJ(43).LE.2) PEM=V(IM,2)
66284 IF(MSTJ(43).GE.3) PEM=P(IM,4)
66285 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
66286 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
66287 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
66288 ENDIF
66289 DO 340 I=1,NEP
66290 PMSD(I)=P(N+I,5)
66291 IF(ISI(I).EQ.1) THEN
66292 IR=IREF(N+I-NS)
66293 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
66294 ENDIF
66295 V(N+I,5)=P(N+I,5)**2
66296 340 CONTINUE
66297
66298C...Choose one of the daughters for evolution.
66299 350 INUM=0
66300 IF(NEP.EQ.1) INUM=1
66301 DO 360 I=1,NEP
66302 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
66303 360 CONTINUE
66304 DO 370 I=1,NEP
66305 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
66306 IR=IREF(N+I-NS)
66307 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
66308 ENDIF
66309 370 CONTINUE
66310 IF(INUM.EQ.0) THEN
66311 RMAX=0D0
66312 DO 380 I=1,NEP
66313 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
66314 RPM=P(N+I,5)/PMSD(I)
66315 IR=IREF(N+I-NS)
66316 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
66317 RMAX=RPM
66318 INUM=I
66319 ENDIF
66320 ENDIF
66321 380 CONTINUE
66322 ENDIF
66323
66324C...Cancel choice of predetermined daughter already treated.
66325 INUM=MAX(1,INUM)
66326 INUMT=INUM
66327 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
66328 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
66329 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
66330 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
66331 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
66332 ENDIF
66333
66334C...Store information on choice of evolving daughter.
66335 IEP(1)=N+INUM
66336 DO 390 I=2,NEP
66337 IEP(I)=IEP(I-1)+1
66338 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
66339 390 CONTINUE
66340 DO 400 I=1,NEP
66341 KFL(I)=IABS(K(IEP(I),2))
66342 400 CONTINUE
66343 ITRY(INUM)=ITRY(INUM)+1
66344 IF(ITRY(INUM).GT.200) THEN
66345 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
66346 IF(MSTU(21).GE.1) RETURN
66347 ENDIF
66348 Z=0.5D0
66349 IR=IREF(IEP(1)-NS)
66350 IF(KSH(IR).EQ.0) GOTO 450
66351 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
66352
66353C...Check if evolution already predetermined for daughter.
66354 IPSPD=0
66355 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
66356 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
66357 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
66358 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
66359 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
66360 ENDIF
66361 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
66362 ISSET(INUM)=0
66363 IF(IPSPD.NE.0) ISSET(INUM)=1
66364 ENDIF
66365
66366C...Select side for interference with initial state partons.
66367 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
66368 III=IEP(1)-NS-1
66369 ISII(III)=0
66370 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
66371 ISII(III)=1
66372 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
66373 IF(PYR(0).GT.0.5D0) ISII(III)=1
66374 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
66375 ISII(III)=1
66376 IF(PYR(0).GT.0.5D0) ISII(III)=2
66377 ENDIF
66378 ENDIF
66379
66380C...Calculate allowed z range.
66381 IF(NEP.EQ.1) THEN
66382 PMED=PS(4)
66383 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66384 PMED=P(IM,5)
66385 ELSE
66386 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
66387 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
66388 ENDIF
66389 IF(MOD(MSTJ(43),2).EQ.1) THEN
66390 ZC=PMTH(2,21)/PMED
66391 ZCE=PMTH(2,22)/PMED
66392 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
66393 ELSE
66394 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
66395 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
66396 PMTMPE=PMTH(2,22)
66397 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
66398 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
66399 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
66400 ENDIF
66401 ZC=MIN(ZC,0.491D0)
66402 ZCE=MIN(ZCE,0.49991D0)
66403 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
66404 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
66405 P(IEP(1),5)=PMTH(1,IR)
66406 V(IEP(1),5)=P(IEP(1),5)**2
66407 GOTO 450
66408 ENDIF
66409
66410C...Integral of Altarelli-Parisi z kernel for QCD.
66411C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
66412 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
66413 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
66414C...QUARKONIA+++
66415C...Evolution of QQ~[3S18] state if MSTP(148)=1.
66416 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
66417 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66418 FBR=6D0*LOG((1D0-ZC)/ZC)
66419C...QUARKONIA---
66420 ELSEIF(MSTJ(49).EQ.0) THEN
66421 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
66422 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
66423
66424C...Integral of Altarelli-Parisi z kernel for scalar gluon.
66425 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
66426 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
66427 ELSEIF(MSTJ(49).EQ.1) THEN
66428 FBR=(1D0-2D0*ZC)/3D0
66429 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
66430
66431C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
66432 ELSEIF(KFL(1).EQ.21) THEN
66433 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
66434 ELSE
66435 FBR=2D0*LOG((1D0-ZC)/ZC)
66436 ENDIF
66437
66438C...Reset QCD probability for colourless.
66439 IF(ISCOL(IR).EQ.0) FBR=0D0
66440
66441C...Integral of Altarelli-Parisi kernel for photon emission.
66442 FBRE=0D0
66443 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
66444 IF(KFL(1).LE.18) THEN
66445 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
66446 ENDIF
66447 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
66448 ENDIF
66449
66450C...Inner veto algorithm starts. Find maximum mass for evolution.
66451 410 PMS=V(IEP(1),5)
66452 IF(IGM.GE.0) THEN
66453 PM2=0D0
66454 DO 420 I=2,NEP
66455 PM=P(IEP(I),5)
66456 IRI=IREF(IEP(I)-NS)
66457 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
66458 PM2=PM2+PM
66459 420 CONTINUE
66460 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
66461 ENDIF
66462
66463C...Select mass for daughter in QCD evolution.
66464 B0=27D0/6D0
66465 DO 430 IFF=4,MSTJ(45)
66466 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
66467 430 CONTINUE
66468C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66469 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
66470C...Already predetermined choice.
66471 IF(IPSPD.NE.0) THEN
66472 PMSQCD=P(IPSPD,5)**2
66473 ELSEIF(FBR.LT.1D-3) THEN
66474 PMSQCD=0D0
66475 ELSEIF(MSTJ(44).LE.0) THEN
66476 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
66477 ELSEIF(MSTJ(44).EQ.1) THEN
66478 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
66479 ELSE
66480 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
66481 ENDIF
66482C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66483 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
66484 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
66485 V(IEP(1),5)=PMSQCD
66486 MCE=1
66487
66488C...Select mass for daughter in QED evolution.
66489 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
66490C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66491 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
66492 IF(FBRE.LT.1D-3) THEN
66493 PMSQED=0D0
66494 ELSE
66495 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
66496 & (PARU(101)*FBRE)))
66497 ENDIF
66498C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66499 PMSQED=PMSQED+PMTH(1,IR)**2
66500 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
66501 & PMTH(2,IR)**2
66502 IF(PMSQED.GT.PMSQCD) THEN
66503 V(IEP(1),5)=PMSQED
66504 MCE=2
66505 ENDIF
66506 ENDIF
66507
66508C...Check whether daughter mass below cutoff.
66509 P(IEP(1),5)=SQRT(V(IEP(1),5))
66510 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
66511 P(IEP(1),5)=PMTH(1,IR)
66512 V(IEP(1),5)=P(IEP(1),5)**2
66513 GOTO 450
66514 ENDIF
66515
66516C...Already predetermined choice of z, and flavour in g -> qqbar.
66517 IF(IPSPD.NE.0) THEN
66518 IPSGD1=K(IPSPD,4)
66519 IPSGD2=K(IPSPD,5)
66520 PMSGD1=P(IPSGD1,5)**2
66521 PMSGD2=P(IPSGD2,5)**2
66522 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
66523 & 4D0*PMSGD1*PMSGD2))
66524 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
66525 & PMSGD1+PMSGD2)/ALAMPS
66526 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
66527 IF(KFL(1).NE.21) THEN
66528 K(IEP(1),5)=21
66529 ELSE
66530 K(IEP(1),5)=IABS(K(IPSGD1,2))
66531 ENDIF
66532
66533C...Select z value of branching: q -> qgamma.
66534 ELSEIF(MCE.EQ.2) THEN
66535 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
66536 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66537 K(IEP(1),5)=22
66538
66539C...QUARKONIA+++
66540C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
66541 ELSEIF(MSTJ(49).EQ.0.AND.
66542 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66543 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66544C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
66545 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
66546 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66547 K(IEP(1),5)=21
66548C...QUARKONIA---
66549
66550C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
66551 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
66552 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66553C...Only do z weighting when no ME correction afterwards.
66554 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66555 K(IEP(1),5)=21
66556 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
66557 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66558 IF(PYR(0).GT.0.5D0) Z=1D0-Z
66559 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66560 K(IEP(1),5)=21
66561 ELSEIF(MSTJ(49).NE.1) THEN
66562 Z=PYR(0)
66563 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
66564 KFLB=1+INT(MSTJ(45)*PYR(0))
66565 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66566 IF(PMQ.GE.1D0) GOTO 410
66567 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
66568 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
66569 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
66570 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
66571 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
66572 ELSE
66573 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
66574 ENDIF
66575 K(IEP(1),5)=KFLB
66576
66577C...Ditto for scalar gluon model.
66578 ELSEIF(KFL(1).NE.21) THEN
66579 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
66580 K(IEP(1),5)=21
66581 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
66582 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66583 K(IEP(1),5)=21
66584 ELSE
66585 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66586 KFLB=1+INT(MSTJ(45)*PYR(0))
66587 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66588 IF(PMQ.GE.1D0) GOTO 410
66589 K(IEP(1),5)=KFLB
66590 ENDIF
66591
66592C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
66593 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
66594 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66595 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66596 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
66597 ELSE
66598 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
66599 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
66600 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
66601 IF(PT2APP.LT.PT2MIN) GOTO 410
66602 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
66603 ENDIF
66604 ENDIF
66605
66606C...Check if z consistent with chosen m.
66607 IF(KFL(1).EQ.21) THEN
66608 IRGD1=IABS(K(IEP(1),5))
66609 IRGD2=IRGD1
66610 ELSE
66611 IRGD1=IR
66612 IRGD2=IABS(K(IEP(1),5))
66613 ENDIF
66614 IF(NEP.EQ.1) THEN
66615 PED=PS(4)
66616 ELSEIF(NEP.GE.3) THEN
66617 PED=P(IEP(1),4)
66618 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66619 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
66620 ELSE
66621 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
66622 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
66623 ENDIF
66624 IF(MOD(MSTJ(43),2).EQ.1) THEN
66625 PMQTH3=0.5D0*PARJ(82)
66626 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66627 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
66628 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
66629 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
66630 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66631 & 4D0*PMQ1*PMQ2)))
66632 ZH=1D0+PMQ1-PMQ2
66633 ELSE
66634 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
66635 ZH=1D0
66636 ENDIF
66637 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66638 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66639 ELSEIF(IPSPD.NE.0) THEN
66640 ELSE
66641 ZL=0.5D0*(ZH-ZD)
66642 ZU=0.5D0*(ZH+ZD)
66643 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
66644 ENDIF
66645 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
66646 &(1D0-ZU)))
66647 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66648
66649C...Width suppression for q -> q + g.
66650 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
66651 IF(IGM.EQ.0) THEN
66652 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
66653 ELSE
66654 EGLU=PMED*(1D0-Z)
66655 ENDIF
66656 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
66657 IF(MSTJ(40).EQ.1) THEN
66658 IF(CHI.LT.PYR(0)) GOTO 410
66659 ELSEIF(MSTJ(40).EQ.2) THEN
66660 IF(1D0-CHI.LT.PYR(0)) GOTO 410
66661 ENDIF
66662 ENDIF
66663
66664C...Three-jet matrix element correction.
66665 IF(M3JC.GE.1) THEN
66666 WME=1D0
66667 WSHOW=1D0
66668
66669C...QED matrix elements: only for massless case so far.
66670 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
66671 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66672 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66673 X3=(1D0-X1)+(1D0-X2)
66674 KI1=K(IPA(INUM),2)
66675 KI2=K(IPA(3-INUM),2)
66676 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
66677 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
66678 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
66679 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
66680 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66681 ELSEIF(MCE.EQ.2) THEN
66682
66683C...QCD matrix elements, including mass effects.
66684 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
66685 PS1ME=V(IEP(1),5)
66686 PM1ME=PMTH(1,IR)
66687 M3JCC=M3JC
66688 IF(IR.GE.31.AND.IGM.EQ.0) THEN
66689C...QCD ME: original parton, first branching.
66690 PM2ME=PMTH(1,63-IR)
66691 ECMME=PS(5)
66692 ELSEIF(IR.GE.31) THEN
66693C...QCD ME: original parton, subsequent branchings.
66694 PM2ME=PMTH(1,63-IR)
66695 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66696 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66697 ELSEIF(K(IM,2).EQ.21) THEN
66698C...QCD ME: secondary partons, first branching.
66699 PM2ME=PM1ME
66700 ZMME=V(IM,1)
66701 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
66702 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
66703 & 4D0*PS1ME*PM2ME**2))
66704 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
66705 & V(IM,5)
66706 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66707 M3JCC=66
66708 ELSE
66709C...QCD ME: secondary partons, subsequent branchings.
66710 PM2ME=PM1ME
66711 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66712 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66713 M3JCC=66
66714 ENDIF
66715C...Construct ME variables.
66716 R1ME=PM1ME/ECMME
66717 R2ME=PM2ME/ECMME
66718 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
66719 X2=1D0+R2ME**2-PS1ME/ECMME**2
66720C...Call ME, with right order important for two inequivalent showerers.
66721 IF(IR.EQ.IORD+30) THEN
66722 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
66723 ELSE
66724 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
66725 ENDIF
66726C...Split up total ME when two radiating partons.
66727 ISPRAD=1
66728 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
66729 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
66730 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
66731 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
66732 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
66733 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66734 & MAX(1D-10,2D0-X1-X2)
66735C...Evaluate shower rate to be compared with.
66736 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
66737 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66738 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
66739 ELSEIF(MSTJ(49).NE.1) THEN
66740
66741C...Toy model scalar theory matrix elements; no mass effects.
66742 ELSE
66743 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66744 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66745 X3=(1D0-X1)+(1D0-X2)
66746 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
66747 WME=X3**2
66748 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
66749 & PARJ(171)
66750 ENDIF
66751
66752 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
66753 ENDIF
66754
66755C...Impose angular ordering by rejection of nonordered emission.
66756 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
66757 PEMAO=V(IM,1)*P(IM,4)
66758 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
66759 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
66760 MAOD=0
66761 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
66762 & .OR.MSTJ(42).EQ.7)) THEN
66763 MAOD=0
66764 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
66765 & .OR.MSTJ(42).EQ.6)) THEN
66766 MAOD=1
66767 PMDAO=PMTH(2,K(IEP(1),5))
66768 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
66769 ELSE
66770 MAOD=1
66771 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
66772 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
66773 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
66774 ENDIF
66775 MAOM=1
66776 IAOM=IM
66777 440 IF(K(IAOM,5).EQ.22) THEN
66778 IAOM=K(IAOM,3)
66779 IF(K(IAOM,3).LE.NS) MAOM=0
66780 IF(MAOM.EQ.1) GOTO 440
66781 ENDIF
66782 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
66783 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
66784 IF(THE2ID.LT.THE2IM) GOTO 410
66785 ENDIF
66786 ENDIF
66787
66788C...Impose user-defined maximum angle at first branching.
66789 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
66790 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
66791 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
66792 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66793 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
66794 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66795 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66796 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
66797 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66798 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
66799 ENDIF
66800 ENDIF
66801
66802C...Impose angular constraint in first branching from interference
66803C...with initial state partons.
66804 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
66805 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
66806 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
66807 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
66808 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
66809 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
66810 ENDIF
66811 ENDIF
66812
66813C...End of inner veto algorithm. Check if only one leg evolved so far.
66814 450 V(IEP(1),1)=Z
66815 ISL(1)=0
66816 ISL(2)=0
66817 IF(NEP.EQ.1) GOTO 490
66818 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
66819 DO 460 I=1,NEP
66820 IR=IREF(N+I-NS)
66821 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
66822 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
66823 ENDIF
66824 460 CONTINUE
66825
66826C...Check if chosen multiplet m1,m2,z1,z2 is physical.
66827 IF(NEP.GE.3) THEN
66828 PMSUM=0D0
66829 DO 470 I=1,NEP
66830 PMSUM=PMSUM+P(N+I,5)
66831 470 CONTINUE
66832 IF(PMSUM.GE.PS(5)) GOTO 350
66833 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
66834 DO 480 I1=N+1,N+2
66835 IRDA=IREF(I1-NS)
66836 IF(KSH(IRDA).EQ.0) GOTO 480
66837 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
66838 IF(IRDA.EQ.21) THEN
66839 IRGD1=IABS(K(I1,5))
66840 IRGD2=IRGD1
66841 ELSE
66842 IRGD1=IRDA
66843 IRGD2=IABS(K(I1,5))
66844 ENDIF
66845 I2=2*N+3-I1
66846 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66847 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
66848 ELSE
66849 IF(I1.EQ.N+1) ZM=V(IM,1)
66850 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
66851 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
66852 & 4D0*V(N+1,5)*V(N+2,5))
66853 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
66854 & V(IM,5)
66855 ENDIF
66856 IF(MOD(MSTJ(43),2).EQ.1) THEN
66857 PMQTH3=0.5D0*PARJ(82)
66858 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66859 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
66860 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
66861 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
66862 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66863 & 4D0*PMQ1*PMQ2)))
66864 ZH=1D0+PMQ1-PMQ2
66865 ELSE
66866 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
66867 ZH=1D0
66868 ENDIF
66869 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
66870 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66871 ELSE
66872 ZL=0.5D0*(ZH-ZD)
66873 ZU=0.5D0*(ZH+ZD)
66874 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66875 & ISSET(1).EQ.0) THEN
66876 ISL(1)=1
66877 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66878 & ISSET(2).EQ.0) THEN
66879 ISL(2)=1
66880 ENDIF
66881 ENDIF
66882 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
66883 & ZL*(1D0-ZU)))
66884 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66885 480 CONTINUE
66886 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
66887 ISL(3-ISLM)=0
66888 ISLM=3-ISLM
66889 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
66890 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
66891 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
66892 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
66893 IF(ISL(1).EQ.1) ISL(2)=0
66894 IF(ISL(1).EQ.0) ISLM=1
66895 IF(ISL(2).EQ.0) ISLM=2
66896 ENDIF
66897 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
66898 ENDIF
66899 IRD1=IREF(N+1-NS)
66900 IRD2=IREF(N+2-NS)
66901 IF(IGM.GT.0) THEN
66902 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
66903 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
66904 PMQ1=V(N+1,5)/V(IM,5)
66905 PMQ2=V(N+2,5)/V(IM,5)
66906 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
66907 & 4D0*PMQ1*PMQ2)))
66908 ZH=1D0+PMQ1-PMQ2
66909 ZL=0.5D0*(ZH-ZD)
66910 ZU=0.5D0*(ZH+ZD)
66911 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
66912 ENDIF
66913 ENDIF
66914
66915C...Accepted branch. Construct four-momentum for initial partons.
66916 490 MAZIP=0
66917 MAZIC=0
66918 IF(NEP.EQ.1) THEN
66919 P(N+1,1)=0D0
66920 P(N+1,2)=0D0
66921 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
66922 & P(N+1,5))))
66923 P(N+1,4)=P(IPA(1),4)
66924 V(N+1,2)=P(N+1,4)
66925 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
66926 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
66927 P(N+1,1)=0D0
66928 P(N+1,2)=0D0
66929 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
66930 P(N+1,4)=PED1
66931 P(N+2,1)=0D0
66932 P(N+2,2)=0D0
66933 P(N+2,3)=-P(N+1,3)
66934 P(N+2,4)=P(IM,5)-PED1
66935 V(N+1,2)=P(N+1,4)
66936 V(N+2,2)=P(N+2,4)
66937 ELSEIF(NEP.GE.3) THEN
66938C...Rescale all momenta for energy conservation.
66939 LOOP=0
66940 PES=0D0
66941 PQS=0D0
66942 DO 510 I=1,NEP
66943 DO 500 J=1,4
66944 P(N+I,J)=P(IPA(I),J)
66945 500 CONTINUE
66946 PES=PES+P(N+I,4)
66947 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66948 510 CONTINUE
66949 520 LOOP=LOOP+1
66950 FAC=(PS(5)-PQS)/(PES-PQS)
66951 PES=0D0
66952 PQS=0D0
66953 DO 540 I=1,NEP
66954 DO 530 J=1,3
66955 P(N+I,J)=FAC*P(N+I,J)
66956 530 CONTINUE
66957 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)
66958 V(N+I,2)=P(N+I,4)
66959 PES=PES+P(N+I,4)
66960 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66961 540 CONTINUE
66962 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
66963
66964C...Construct transverse momentum for ordinary branching in shower.
66965 ELSE
66966 ZM=V(IM,1)
66967 LOOPPT=0
66968 550 LOOPPT=LOOPPT+1
66969 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
66970 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
66971 IF(PZM.LE.0D0) THEN
66972 PTS=0D0
66973 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
66974 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66975 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
66976 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
66977 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
66978 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
66979 ELSE
66980 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
66981 ENDIF
66982 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
66983 ZM=0.05D0+0.9D0*ZM
66984 GOTO 550
66985 ELSEIF(PTS.LT.0D0) THEN
66986 GOTO 280
66987 ENDIF
66988 PT=SQRT(MAX(0D0,PTS))
66989
66990C...Global statistics.
66991 MINT(353)=MINT(353)+1
66992 VINT(353)=VINT(353)+PT
66993 IF (MINT(353).EQ.1) VINT(358)=PT
66994
66995C...Find coefficient of azimuthal asymmetry due to gluon polarization.
66996 HAZIP=0D0
66997 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
66998 & .AND.IAU.NE.0) THEN
66999 IF(K(IGM,3).NE.0) MAZIP=1
67000 ZAU=V(IGM,1)
67001 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
67002 IF(MAZIP.EQ.0) ZAU=0D0
67003 IF(K(IGM,2).NE.21) THEN
67004 HAZIP=2D0*ZAU/(1D0+ZAU**2)
67005 ELSE
67006 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
67007 ENDIF
67008 IF(K(N+1,2).NE.21) THEN
67009 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
67010 ELSE
67011 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
67012 ENDIF
67013 ENDIF
67014
67015C...Find coefficient of azimuthal asymmetry due to soft gluon
67016C...interference.
67017 HAZIC=0D0
67018 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
67019 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
67020 IF(K(IGM,3).NE.0) MAZIC=N+1
67021 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
67022 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67023 & ZM.GT.0.5D0) MAZIC=N+2
67024 IF(K(IAU,2).EQ.22) MAZIC=0
67025 ZS=ZM
67026 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
67027 ZGM=V(IGM,1)
67028 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
67029 IF(MAZIC.EQ.0) ZGM=1D0
67030 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
67031 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
67032 HAZIC=MIN(0.95D0,HAZIC)
67033 ENDIF
67034 ENDIF
67035
67036C...Construct energies for ordinary branching in shower.
67037 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
67038 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67039 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67040 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67041 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67042 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
67043 P(N+1,4)=PEM*V(IM,1)
67044 ELSE
67045 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
67046 & SQRT(PMLS)*ZM)/V(IM,5)
67047 ENDIF
67048
67049C...Already predetermined choice of phi angle or not
67050 PHI=PARU(2)*PYR(0)
67051 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
67052 IPSPD=IP1+IM-NS-2
67053 IF(K(IPSPD,4).GT.0) THEN
67054 IPSGD1=K(IPSPD,4)
67055 IF(IM.EQ.NS+2) THEN
67056 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67057 ELSE
67058 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
67059 ENDIF
67060 ENDIF
67061 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
67062 IPSPD=IP1+IM-NS-2
67063 IF(K(IPSPD,4).GT.0) THEN
67064 IPSGD1=K(IPSPD,4)
67065 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
67066 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
67067 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
67068 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
67069 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67070 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
67071 ENDIF
67072 ENDIF
67073
67074C...Construct momenta for ordinary branching in shower.
67075 P(N+1,1)=PT*COS(PHI)
67076 P(N+1,2)=PT*SIN(PHI)
67077 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67078 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67079 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67080 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67081 ELSEIF(PZM.GT.0D0) THEN
67082 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
67083 & 2D0*PEM*P(N+1,4))/PZM
67084 ELSE
67085 P(N+1,3)=0D0
67086 ENDIF
67087 P(N+2,1)=-P(N+1,1)
67088 P(N+2,2)=-P(N+1,2)
67089 P(N+2,3)=PZM-P(N+1,3)
67090 P(N+2,4)=PEM-P(N+1,4)
67091 IF(MSTJ(43).LE.2) THEN
67092 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
67093 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
67094 ENDIF
67095 ENDIF
67096
67097C...Rotate and boost daughters.
67098 IF(IGM.GT.0) THEN
67099 IF(MSTJ(43).LE.2) THEN
67100 BEX=P(IGM,1)/P(IGM,4)
67101 BEY=P(IGM,2)/P(IGM,4)
67102 BEZ=P(IGM,3)/P(IGM,4)
67103 GA=P(IGM,4)/P(IGM,5)
67104 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
67105 & P(IM,4))
67106 ELSE
67107 BEX=0D0
67108 BEY=0D0
67109 BEZ=0D0
67110 GA=1D0
67111 GABEP=0D0
67112 ENDIF
67113 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
67114 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
67115 IF(PTIMB.GT.1D-4) THEN
67116 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
67117 ELSE
67118 PHI=0D0
67119 ENDIF
67120 DO 570 I=N+1,N+2
67121 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
67122 & SIN(THE)*COS(PHI)*P(I,3)
67123 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
67124 & SIN(THE)*SIN(PHI)*P(I,3)
67125 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
67126 DP(4)=P(I,4)
67127 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
67128 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
67129 P(I,1)=DP(1)+DGABP*BEX
67130 P(I,2)=DP(2)+DGABP*BEY
67131 P(I,3)=DP(3)+DGABP*BEZ
67132 P(I,4)=GA*(DP(4)+DBP)
67133 570 CONTINUE
67134 ENDIF
67135
67136C...Weight with azimuthal distribution, if required.
67137 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
67138 DO 580 J=1,3
67139 DPT(1,J)=P(IM,J)
67140 DPT(2,J)=P(IAU,J)
67141 DPT(3,J)=P(N+1,J)
67142 580 CONTINUE
67143 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
67144 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
67145 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
67146 DO 590 J=1,3
67147 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
67148 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
67149 590 CONTINUE
67150 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
67151 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
67152 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
67153 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
67154 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
67155 IF(MAZIP.NE.0) THEN
67156 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
67157 & GOTO 560
67158 ENDIF
67159 IF(MAZIC.NE.0) THEN
67160 IF(MAZIC.EQ.N+2) CAD=-CAD
67161 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
67162 & .LT.PYR(0)) GOTO 560
67163 ENDIF
67164 ENDIF
67165 ENDIF
67166
67167C...Azimuthal anisotropy due to interference with initial state partons.
67168 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
67169 &K(N+2,2).EQ.21)) THEN
67170 III=IM-NS-1
67171 IF(ISII(III).GE.1) THEN
67172 IAZIID=N+1
67173 IF(K(N+1,2).NE.21) IAZIID=N+2
67174 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67175 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
67176 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
67177 IF(III.EQ.2) THEIID=PARU(1)-THEIID
67178 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
67179 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
67180 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
67181 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
67182 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
67183 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
67184 & .LT.PYR(0)) GOTO 560
67185 ENDIF
67186 ENDIF
67187
67188C...Continue loop over partons that may branch, until none left.
67189 IF(IGM.GE.0) K(IM,1)=14
67190 N=N+NEP
67191 NEP=2
67192 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
67193 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
67194 IF(MSTU(21).GE.1) N=NS
67195 IF(MSTU(21).GE.1) RETURN
67196 ENDIF
67197 GOTO 290
67198
67199C...Set information on imagined shower initiator.
67200 600 IF(NPA.GE.2) THEN
67201 K(NS+1,1)=11
67202 K(NS+1,2)=94
67203 K(NS+1,3)=IP1
67204 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
67205 K(NS+1,4)=NS+2
67206 K(NS+1,5)=NS+1+NPA
67207 IIM=1
67208 ELSE
67209 IIM=0
67210 ENDIF
67211
67212C...Reconstruct string drawing information.
67213 DO 610 I=NS+1+IIM,N
67214 KQ=KCHG(PYCOMP(K(I,2)),2)
67215 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
67216 K(I,1)=1
67217 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
67218 & IABS(K(I,2)).LE.18) THEN
67219 K(I,1)=1
67220 ELSEIF(K(I,1).LE.10) THEN
67221 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
67222 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
67223 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
67224 ID1=MOD(K(I,4),MSTU(5))
67225 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
67226 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
67227 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
67228 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
67229 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67230 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
67231 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67232 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
67233 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
67234 K(ID2,5)=K(ID2,5)+MSTU(5)*I
67235 ELSE
67236 ID1=MOD(K(I,4),MSTU(5))
67237 ID2=ID1+1
67238 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67239 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
67240 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
67241 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67242 K(ID1,5)=K(ID1,5)+MSTU(5)*I
67243 ELSE
67244 K(ID1,4)=0
67245 K(ID1,5)=0
67246 ENDIF
67247 K(ID2,4)=0
67248 K(ID2,5)=0
67249 ENDIF
67250 610 CONTINUE
67251
67252C...Transformation from CM frame.
67253 IF(NPA.EQ.1) THEN
67254 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
67255 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
67256 MSTU(33)=1
67257 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
67258 ELSEIF(NPA.EQ.2) THEN
67259 BEX=PS(1)/PS(4)
67260 BEY=PS(2)/PS(4)
67261 BEZ=PS(3)/PS(4)
67262 GA=PS(4)/PS(5)
67263 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
67264 & /(1D0+GA)-P(IPA(1),4))
67265 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
67266 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
67267 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
67268 MSTU(33)=1
67269 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
67270 ELSE
67271 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
67272 & PS(3)/PS(4))
67273 MSTU(33)=1
67274 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
67275 ENDIF
67276
67277C...Decay vertex of shower.
67278 DO 630 I=NS+1,N
67279 DO 620 J=1,5
67280 V(I,J)=V(IP1,J)
67281 620 CONTINUE
67282 630 CONTINUE
67283
67284C...Delete trivial shower, else connect initiators.
67285 IF(N.LE.NS+NPA+IIM) THEN
67286 N=NS
67287 ELSE
67288 DO 640 IP=1,NPA
67289 K(IPA(IP),1)=14
67290 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
67291 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
67292 K(NS+IIM+IP,3)=IPA(IP)
67293 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
67294 IF(K(NS+IIM+IP,1).NE.1) THEN
67295 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
67296 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
67297 ENDIF
67298 640 CONTINUE
67299 ENDIF
67300
67301 RETURN
67302 END
67303
67304C*********************************************************************
67305
67306C...PYPTFS
67307C...Generates pT-ordered timelike final-state parton showers.
67308
67309C...MODE defines how to find radiators and recoilers.
67310C... = 0 : based on colour flow between undecayed partons.
67311C... = 1 : for IPART <= NPARTD only consider primary partons,
67312C... whether decayed or not; else as above.
67313C... = 2 : based on common history, whether decayed or not.
67314
67315 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
67316
67317C...Double precision and integer declarations.
67318 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67319 IMPLICIT INTEGER(I-N)
67320 INTEGER PYK,PYCHGE,PYCOMP
67321C...Parameter statement to help give large particle numbers.
67322 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67323 &KEXCIT=4000000,KDIMEN=5000000)
67324C...Parameter statement for maximum size of showers.
67325 PARAMETER (MAXNUR=1000)
67326C...Commonblocks.
67327 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
67328 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67329 COMMON/PYCTAG/NCT,MCT(4000,2)
67330 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67331 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67332 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
67333 COMMON/PYINT1/MINT(400),VINT(400)
67334 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
67335 &/PYINT1/
67336C...Local arrays.
67337 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
67338 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
67339 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
67340 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
67341C...Statement functions.
67342 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
67343 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
67344
67345C...Initial values. Check that valid system.
67346 PTGEN=0D0
67347 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
67348 &MSTJ(41).NE.12) RETURN
67349 IF(NPART.LE.0) THEN
67350 CALL PYERRM(2,'(PYPTFS:) showering system too small')
67351 RETURN
67352 ENDIF
67353 PT2CMX=PTMAX**2
67354
67355C...Mass thresholds and Lambda for QCD evolution.
67356 PMB=PMAS(5,1)
67357 PMC=PMAS(4,1)
67358 ALAM5=PARJ(81)
67359 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
67360 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
67361 PMBS=PMB**2
67362 PMCS=PMC**2
67363 ALAM5S=ALAM5**2
67364 ALAM4S=ALAM4**2
67365 ALAM3S=ALAM3**2
67366
67367C...Cutoff scale for QCD evolution. Starting pT2.
67368 NFLAV=MAX(0,MIN(5,MSTJ(45)))
67369 PT0C=0.5D0*PARJ(82)
67370 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
67371
67372C...Parameters for QED evolution.
67373 AEM2PI=PARU(101)/PARU(2)
67374 PT0EQ=0.5D0*PARJ(83)
67375 PT0EL=0.5D0*PARJ(90)
67376
67377C...Reset. Remove irrelevant colour tags.
67378 NEVOL=0
67379 DO 100 J=1,4
67380 PSUM(J)=0D0
67381 100 CONTINUE
67382 DO 110 I=MINT(84)+1,N
67383 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
67384 K(I,5)=0
67385 MCT(I,2)=0
67386 ENDIF
67387 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
67388 K(I,4)=0
67389 MCT(I,1)=0
67390 ENDIF
67391 110 CONTINUE
67392 NPARTS=NPART
67393
67394C...Begin loop to set up showering partons. Sum four-momenta.
67395 DO 210 IP=1,NPART
67396 I=IPART(IP)
67397 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
67398 IF(K(I,1).GT.10) GOTO 210
67399 ELSEIF(K(I,3).GT.MINT(84)) THEN
67400 IF(K(I,3).GT.MINT(84)+2) GOTO 210
67401 ELSE
67402 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
67403 ENDIF
67404 DO 120 J=1,4
67405 PSUM(J)=PSUM(J)+P(I,J)
67406 120 CONTINUE
67407
67408C...Find colour and charge, but skip diquarks.
67409 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
67410 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
67411 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
67412
67413C...Either colour or anticolour charge radiates; for gluon both.
67414 DO 160 JSGCOL=1,-1,-2
67415 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
67416 JCOL=4+(1-JSGCOL)/2
67417 JCOLR=9-JCOL
67418
67419C...Basic info about radiating parton.
67420 NEVOL=NEVOL+1
67421 IPOS(NEVOL)=I
67422 IFLG(NEVOL)=0
67423 ISCOL(NEVOL)=JSGCOL
67424 ISCHG(NEVOL)=0
67425 PTSCA(NEVOL)=PTPART(IP)
67426
67427C...Begin search for colour recoiler when MODE = 0 or 1.
67428 IF(MODE.LE.1) THEN
67429C...Find sister with matching anticolour to the radiating parton.
67430 IROLD=I
67431 IRNEW=K(IROLD,JCOL)/MSTU(5)
67432 MOVE=1
67433
67434C...The following will add MCT colour tracing for unprepped events
67435C...If not done, trace Les Houches colour tags for this dipole
67436C IF (MCT(I,JCOL-3).EQ.0) THEN
67437C CALL PYCTTR(I,JCOL,INEW)
67438C...Clean up mother/daughter 'read' tags set by PYCTTR
67439C DO 125 IR=1,N
67440C K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
67441C K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
67442C 125 CONTINUE
67443C ENDIF
67444
67445C...Skip radiation off loose colour ends.
67446 130 IF(IRNEW.EQ.0) THEN
67447 NEVOL=NEVOL-1
67448 GOTO 160
67449
67450C...Optionally skip radiation on dipole to beam remnant.
67451 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
67452 NEVOL=NEVOL-1
67453 GOTO 160
67454
67455C...For now always skip radiation on dipole to junction.
67456 ELSEIF(K(IRNEW,2).EQ.88) THEN
67457 NEVOL=NEVOL-1
67458 GOTO 160
67459
67460C...For MODE=1: if reached primary then done.
67461 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
67462 & IRNEW.LE.NPARTD) THEN
67463
67464C...If sister stable and points back then done.
67465 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67466 & THEN
67467 IF(K(IRNEW,1).LT.10) THEN
67468
67469C...If sister unstable then go to her daughter.
67470 ELSE
67471 IROLD=IRNEW
67472 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67473 MOVE=2
67474 GOTO 130
67475 ENDIF
67476
67477C...If found mother then look for aunt.
67478 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67479 & IROLD) THEN
67480 IROLD=IRNEW
67481 IRNEW=K(IROLD,JCOL)/MSTU(5)
67482 GOTO 130
67483
67484C...If daughter stable then done.
67485 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67486 & THEN
67487 IF(K(IRNEW,1).LT.10) THEN
67488
67489C...If daughter unstable then go to granddaughter.
67490 ELSE
67491 IROLD=IRNEW
67492 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67493 MOVE=2
67494 GOTO 130
67495 ENDIF
67496
67497C...If daughter points to another daughter then done or move up.
67498 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67499 & IROLD) THEN
67500 IF(K(IRNEW,1).LT.10) THEN
67501 ELSE
67502 IROLD=IRNEW
67503 IRNEW=K(IRNEW,JCOL)/MSTU(5)
67504 MOVE=1
67505 GOTO 130
67506 ENDIF
67507 ENDIF
67508
67509C...Begin search for colour recoiler when MODE = 2.
67510 ELSE
67511 IROLD=I
67512 IRNEW=K(IROLD,JCOL)/MSTU(5)
67513 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
67514C...Step up to mother if radiating parton already branched.
67515 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
67516 IROLD=IRNEW
67517 IRNEW=K(IROLD,JCOL)/MSTU(5)
67518 GOTO 140
67519C...Pick sister by history if no anticolour available.
67520 ELSE
67521 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67522 IRNEW=IROLD-1
67523 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
67524 & THEN
67525 IRNEW=IROLD+1
67526C...Last resort: pick at random among other primaries.
67527 ELSE
67528 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67529 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67530 ENDIF
67531 ENDIF
67532 ENDIF
67533C...Trace down if sister branched.
67534 150 IF(K(IRNEW,1).GT.10) THEN
67535 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67536 GOTO 150
67537 ENDIF
67538 ENDIF
67539
67540C...Now found other end of colour dipole.
67541 IREC(NEVOL)=IRNEW
67542 ENDIF
67543 160 CONTINUE
67544
67545C...Also electrical charge may radiate; so far only quarks and leptons.
67546 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
67547 & IABS(K(I,2)).LE.18) THEN
67548
67549C...Basic info about radiating parton.
67550 NEVOL=NEVOL+1
67551 IPOS(NEVOL)=I
67552 IFLG(NEVOL)=0
67553 ISCOL(NEVOL)=0
67554 ISCHG(NEVOL)=KCHA
67555 PTSCA(NEVOL)=PTPART(IP)
67556
67557C...Pick nearest (= smallest invariant mass) charged particle
67558C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
67559 IF(MODE.LE.1) THEN
67560 IRNEW=0
67561 PM2MIN=VINT(2)
67562 DO 170 IP2=1,NPART+N-MINT(53)
67563 IF(IP2.EQ.IP) GOTO 170
67564 IF(IP2.LE.NPART) THEN
67565 I2=IPART(IP2)
67566 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
67567 IF(K(I2,1).GT.10) GOTO 170
67568 ELSEIF(K(I2,3).GT.MINT(84)) THEN
67569 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
67570 ELSE
67571 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
67572 ENDIF
67573 ELSE
67574 I2=MINT(53)+IP2-NPART
67575 ENDIF
67576 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
67577 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
67578 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
67579 IF(PM2INV.LT.PM2MIN) THEN
67580 IRNEW=I2
67581 PM2MIN=PM2INV
67582 ENDIF
67583 170 CONTINUE
67584 IF(IRNEW.EQ.0) THEN
67585 NEVOL=NEVOL-1
67586 GOTO 210
67587 ENDIF
67588
67589C...Begin search for charge recoiler when MODE = 2.
67590 ELSE
67591 IROLD=I
67592C...Pick sister by history; step up if parton already branched.
67593 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
67594 IROLD=K(IROLD,3)
67595 GOTO 180
67596 ENDIF
67597 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67598 IRNEW=IROLD-1
67599 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
67600 IRNEW=IROLD+1
67601C...Last resort: pick at random among other primaries.
67602 ELSE
67603 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67604 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67605 ENDIF
67606C...Trace down if sister branched.
67607 190 IF(K(IRNEW,1).GT.10) THEN
67608 DO 200 IR=IRNEW+1,N
67609 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
67610 IRNEW=IR
67611 GOTO 190
67612 ENDIF
67613 200 CONTINUE
67614 ENDIF
67615 ENDIF
67616 IREC(NEVOL)=IRNEW
67617 ENDIF
67618
67619C...End loop to set up showering partons. System invariant mass.
67620 210 CONTINUE
67621 IF(NEVOL.LE.0) RETURN
67622 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
67623
67624C...Check if 3-jet matrix elements to be used.
67625 M3JC=0
67626 ALPHA=0.5D0
67627 NMESYS=0
67628 IF(MSTJ(47).GE.1) THEN
67629
67630C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
67631 KFSRCE=0
67632 IPART1=K(IPART(1),3)
67633 IPART2=K(IPART(2),3)
67634 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
67635 KFSRCE=IABS(K(IPART1,2))
67636 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
67637 IPART1=K(IPART1,3)
67638 GOTO 220
67639 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
67640 IPART2=K(IPART2,3)
67641 GOTO 220
67642 ENDIF
67643 ITYPES=0
67644 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
67645 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
67646 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
67647 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
67648 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
67649 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
67650 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
67651 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
67652
67653C...Identify two primary showerers.
67654 KFLA1=IABS(K(IPART(1),2))
67655 ITYPE1=0
67656 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
67657 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
67658 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
67659 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
67660 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
67661 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
67662 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
67663 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
67664 KFLA2=IABS(K(IPART(2),2))
67665 ITYPE2=0
67666 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
67667 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
67668 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
67669 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
67670 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
67671 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
67672 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
67673 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
67674
67675C...Order of showerers. Presence of gluino.
67676 ITYPMN=MIN(ITYPE1,ITYPE2)
67677 ITYPMX=MAX(ITYPE1,ITYPE2)
67678 IORD=1
67679 IF(ITYPE1.GT.ITYPE2) IORD=2
67680 IGLUI=0
67681 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
67682
67683C...Require exactly two primary showerers for ME corrections.
67684 NPRIM=0
67685 IF(IPART1.GT.0) THEN
67686 DO 230 I=1,N
67687 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
67688 230 CONTINUE
67689 ENDIF
67690 IF(NPRIM.NE.2) THEN
67691
67692C...Predetermined and default matrix element kinds.
67693 ELSEIF(MSTJ(38).NE.0) THEN
67694 M3JC=MSTJ(38)
67695 ALPHA=PARJ(80)
67696 MSTJ(38)=0
67697 ELSEIF(MSTJ(47).GE.6) THEN
67698 M3JC=MSTJ(47)
67699 ELSE
67700 ICLASS=1
67701 ICOMBI=4
67702
67703C...Vector/axial vector -> q + qbar; q -> q + V.
67704 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
67705 & ITYPES.EQ.3)) THEN
67706 ICLASS=2
67707 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
67708 ICOMBI=1
67709 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
67710 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
67711C...gamma*/Z0: assume e+e- initial state if unknown.
67712 EI=-1D0
67713 IF(KFSRCE.EQ.23) THEN
67714 IANNFL=IPART1
67715 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67716 IF(IANNFL.GT.0) THEN
67717 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67718 ENDIF
67719 IF(IANNFL.NE.0) THEN
67720 KANNFL=IABS(K(IANNFL,2))
67721 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
67722 ENDIF
67723 ENDIF
67724 AI=SIGN(1D0,EI+0.1D0)
67725 VI=AI-4D0*EI*PARU(102)
67726 EF=KCHG(KFLA1,1)/3D0
67727 AF=SIGN(1D0,EF+0.1D0)
67728 VF=AF-4D0*EF*PARU(102)
67729 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
67730 SH=PSUM(5)**2
67731 SQMZ=PMAS(23,1)**2
67732 SQWZ=PSUM(5)*PMAS(23,2)
67733 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
67734 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
67735 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
67736 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
67737 ICOMBI=3
67738 ALPHA=VECT/(VECT+AXIV)
67739 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
67740 ICOMBI=4
67741 ENDIF
67742C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
67743 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
67744 ICLASS=2
67745 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67746 & ITYPES.EQ.1)) THEN
67747 ICLASS=3
67748
67749C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
67750 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
67751 ICLASS=4
67752 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
67753 ICOMBI=1
67754 ELSEIF(KFSRCE.EQ.36) THEN
67755 ICOMBI=2
67756 ENDIF
67757 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67758 & ITYPES.EQ.1)) THEN
67759 ICLASS=5
67760
67761C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
67762 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67763 & ITYPES.EQ.3)) THEN
67764 ICLASS=6
67765 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67766 & ITYPES.EQ.2)) THEN
67767 ICLASS=7
67768 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
67769 ICLASS=8
67770 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67771 & ITYPES.EQ.2)) THEN
67772 ICLASS=9
67773
67774C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
67775 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67776 & ITYPES.EQ.5)) THEN
67777 ICLASS=10
67778 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67779 & ITYPES.EQ.2)) THEN
67780 ICLASS=11
67781 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67782 & ITYPES.EQ.1)) THEN
67783 ICLASS=12
67784
67785C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
67786 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
67787 ICLASS=13
67788 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67789 & ITYPES.EQ.2)) THEN
67790 ICLASS=14
67791 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67792 & ITYPES.EQ.1)) THEN
67793 ICLASS=15
67794
67795C...g -> ~g + ~g (eikonal approximation).
67796 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
67797 ICLASS=16
67798 ENDIF
67799 M3JC=5*ICLASS+ICOMBI
67800 ENDIF
67801
67802C...Store pair that together define matrix element treatment.
67803 IF(M3JC.NE.0) THEN
67804 NMESYS=1
67805 MESYS(NMESYS,0)=M3JC
67806 MESYS(NMESYS,1)=IPART(1)
67807 MESYS(NMESYS,2)=IPART(2)
67808 ENDIF
67809
67810C...Store qqbar or l+l- pairs for QED radiation.
67811 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
67812 NMESYS=NMESYS+1
67813 MESYS(NMESYS,0)=101
67814 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
67815 MESYS(NMESYS,1)=IPART(1)
67816 MESYS(NMESYS,2)=IPART(2)
67817 ENDIF
67818
67819C...Store other qqbar/l+l- pairs from g/gamma branchings.
67820 DO 270 I1=1,N
67821 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
67822 I1M=K(I1,3)
67823 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
67824 I1M=K(I1M,3)
67825 GOTO 240
67826 ENDIF
67827C...Move up this check to avoid out-of-bounds.
67828 IF(I1M.EQ.0) GOTO 270
67829 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
67830 DO 260 I2=I1+1,N
67831 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
67832 I2M=K(I2,3)
67833 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
67834 I2M=K(I2M,3)
67835 GOTO 250
67836 ENDIF
67837 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
67838 NMESYS=NMESYS+1
67839 MESYS(NMESYS,0)=66
67840 MESYS(NMESYS,1)=I1
67841 MESYS(NMESYS,2)=I2
67842 NMESYS=NMESYS+1
67843 MESYS(NMESYS,0)=102
67844 MESYS(NMESYS,1)=I1
67845 MESYS(NMESYS,2)=I2
67846 ENDIF
67847 260 CONTINUE
67848 270 CONTINUE
67849 ENDIF
67850
67851C..Loopback point for counting number of emissions.
67852 NGEN=0
67853 280 NGEN=NGEN+1
67854
67855C...Begin loop to evolve all existing partons, if required.
67856 290 IMX=0
67857 PT2MX=0D0
67858 DO 360 IEVOL=1,NEVOL
67859 IF(IFLG(IEVOL).EQ.0) THEN
67860
67861C...Basic info on radiator and recoil.
67862 I=IPOS(IEVOL)
67863 IR=IREC(IEVOL)
67864 SHT=SHAT(I,IR)
67865 PM2I=P(I,5)**2
67866 PM2R=P(IR,5)**2
67867
67868C...Invariant mass of "dipole".Starting value for pT evolution.
67869 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
67870 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
67871
67872C...Case of evolution by QCD branching.
67873 IF(ISCOL(IEVOL).NE.0) THEN
67874
67875C...Parton-by-parton maximum scale from initial conditions.
67876 IF(MSTP(72).EQ.0) THEN
67877 DO 300 IPRT=1,NPARTS
67878 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
67879 300 CONTINUE
67880 ENDIF
67881
67882C...If kinematically impossible then do not evolve.
67883 IF(PT2.LT.PT2CMN) THEN
67884 IFLG(IEVOL)=-1
67885 GOTO 360
67886 ENDIF
67887
67888C...Check if part of system for which ME corrections should be applied.
67889 IMESYS=0
67890 DO 310 IME=1,NMESYS
67891 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67892 & MESYS(IME,0).LT.100) IMESYS=IME
67893 310 CONTINUE
67894
67895C...Special flag for colour octet states.
67896 MOCT=0
67897 IF(K(I,2).EQ.21) MOCT=1
67898 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
67899
67900C...Upper estimate for matrix element weighting and colour factor.
67901C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
67902 WTPSGL=2D0
67903 COLFAC=4D0/3D0
67904 IF(MOCT.GE.1) COLFAC=3D0/2D0
67905 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
67906 WTPSQQ=0.5D0*0.5D0*NFLAV
67907
67908C...Determine overestimated z range: switch at c and b masses.
67909 320 IZRG=1
67910 PT2MNE=PT2CMN
67911 B0=27D0/6D0
67912 ALAMS=ALAM3S
67913 IF(PT2.GT.1.01D0*PMCS) THEN
67914 IZRG=2
67915 PT2MNE=PMCS
67916 B0=25D0/6D0
67917 ALAMS=ALAM4S
67918 ENDIF
67919 IF(PT2.GT.1.01D0*PMBS) THEN
67920 IZRG=3
67921 PT2MNE=PMBS
67922 B0=23D0/6D0
67923 ALAMS=ALAM5S
67924 ENDIF
67925 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
67926 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
67927
67928C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
67929 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
67930 EVCOEF=EVEMGL
67931 IF(MOCT.EQ.1) THEN
67932 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
67933 EVCOEF=EVCOEF+EVEMQQ
67934 ENDIF
67935
67936C...Pick pT2 (in overestimated z range).
67937 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
67938
67939C...Loopback if crossed c/b mass thresholds.
67940 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
67941 PT2=PMBS
67942 GOTO 320
67943 ENDIF
67944 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
67945 PT2=PMCS
67946 GOTO 320
67947 ENDIF
67948
67949C...Finish if below lower cutoff.
67950 IF(PT2.LT.PT2CMN) THEN
67951 IFLG(IEVOL)=-1
67952 GOTO 360
67953 ENDIF
67954
67955C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
67956 IFLAG=1
67957 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
67958
67959C...Pick z: dz/(1-z) or dz.
67960 IF(IFLAG.EQ.1) THEN
67961 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
67962 ELSE
67963 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
67964 ENDIF
67965
67966C...Loopback if outside allowed range for given pT2.
67967 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
67968 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
67969 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
67970 PM2=PM2I+PT2/(Z*(1D0-Z))
67971 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
67972
67973C...No weighting for primary partons; to be done later on.
67974 IF(IMESYS.GT.0) THEN
67975
67976C...Weighting of q->qg/X->Xg branching.
67977 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
67978 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
67979
67980C...Weighting of g->gg branching.
67981 ELSEIF(IFLAG.EQ.1) THEN
67982 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
67983
67984C...Flavour choice and weighting of g->qqbar branching.
67985 ELSE
67986 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
67987 PMQ=PMAS(KFQ,1)
67988 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
67989 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
67990 IF(WTME.LT.PYR(0)) GOTO 330
67991 IFLAG=10+KFQ
67992 ENDIF
67993
67994C...Case of evolution by QED branching.
67995 ELSEIF(ISCHG(IEVOL).NE.0) THEN
67996
67997C...If kinematically impossible then do not evolve.
67998 PT2EMN=PT0EQ**2
67999 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
68000 IF(PT2.LT.PT2EMN) THEN
68001 IFLG(IEVOL)=-1
68002 GOTO 360
68003 ENDIF
68004
68005C...Check if part of system for which ME corrections should be applied.
68006 IMESYS=0
68007 DO 340 IME=1,NMESYS
68008 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
68009 & MESYS(IME,0).GT.100) IMESYS=IME
68010 340 CONTINUE
68011
68012C...Charge. Matrix element weighting factor.
68013 CHG=ISCHG(IEVOL)/3D0
68014 WTPSGA=2D0
68015
68016C...Determine overestimated z range. Find evolution coefficient.
68017 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
68018 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
68019 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
68020
68021C...Pick pT2 (in overestimated z range).
68022 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
68023
68024C...Finish if below lower cutoff.
68025 IF(PT2.LT.PT2EMN) THEN
68026 IFLG(IEVOL)=-1
68027 GOTO 360
68028 ENDIF
68029
68030C...Pick z: dz/(1-z).
68031 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
68032
68033C...Loopback if outside allowed range for given pT2.
68034 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
68035 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
68036 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
68037 PM2=PM2I+PT2/(Z*(1D0-Z))
68038 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
68039
68040C...Weighting by branching kernel, except if ME weighting later.
68041 IF(IMESYS.EQ.0) THEN
68042 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
68043 ENDIF
68044 IFLAG=3
68045 ENDIF
68046
68047C...Save acceptable branching.
68048 IFLG(IEVOL)=IFLAG
68049 IMESAV(IEVOL)=IMESYS
68050 PT2SAV(IEVOL)=PT2
68051 ZSAV(IEVOL)=Z
68052 SHTSAV(IEVOL)=SHT
68053 ENDIF
68054
68055C...Check if branching has highest pT.
68056 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
68057 IMX=IEVOL
68058 PT2MX=PT2SAV(IEVOL)
68059 ENDIF
68060 360 CONTINUE
68061
68062C...Finished if no more branchings to be done.
68063 IF(IMX.EQ.0) GOTO 480
68064
68065C...Restore info on hardest branching to be processed.
68066 I=IPOS(IMX)
68067 IR=IREC(IMX)
68068 KCOL=ISCOL(IMX)
68069 KCHA=ISCHG(IMX)
68070 IMESYS=IMESAV(IMX)
68071 PT2=PT2SAV(IMX)
68072 Z=ZSAV(IMX)
68073 SHT=SHTSAV(IMX)
68074 PM2I=P(I,5)**2
68075 PM2R=P(IR,5)**2
68076 PM2=PM2I+PT2/(Z*(1D0-Z))
68077
68078C...Special flag for colour octet states.
68079 MOCT=0
68080 IF(K(I,2).EQ.21) MOCT=1
68081 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
68082
68083C...Restore further info for g->qqbar branching.
68084 KFQ=0
68085 IF(IFLG(IMX).GT.10) THEN
68086 KFQ=IFLG(IMX)-10
68087 PMQ=PMAS(KFQ,1)
68088 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
68089 ENDIF
68090
68091C...For branching g include azimuthal asymmetries from polarization.
68092 ASYPOL=0D0
68093 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
68094C...Trace grandmother via intermediate recoil copies.
68095 KFGM=0
68096 IM=I
68097 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
68098 & K(IM,3).GT.0) THEN
68099 IM=K(IM,3)
68100 IF(IM.GT.MINT(84)) GOTO 370
68101 ENDIF
68102 IGM=K(IM,3)
68103 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
68104 & KFGM=IABS(K(IGM,2))
68105C...Define approximate energy sharing by identifying aunt.
68106 IAU=IM+1
68107 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
68108 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
68109 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
68110C...Coefficient from gluon production.
68111 IF(KFGM.LE.6) THEN
68112 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
68113 ELSE
68114 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
68115 ENDIF
68116C...Coefficient from gluon decay.
68117 IF(KFQ.EQ.0) THEN
68118 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
68119 ELSE
68120 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
68121 ENDIF
68122 ENDIF
68123 ENDIF
68124
68125C...Create new slots for branching products and recoil.
68126 INEW=N+1
68127 IGNEW=N+2
68128 IRNEW=N+3
68129 N=N+3
68130
68131C...Set status, flavour and mother of new ones.
68132 K(INEW,1)=K(I,1)
68133 K(IGNEW,1)=3
68134 IF(KCHA.NE.0) K(IGNEW,1)=1
68135 K(IRNEW,1)=K(IR,1)
68136 IF(KFQ.EQ.0) THEN
68137 K(INEW,2)=K(I,2)
68138 K(IGNEW,2)=21
68139 IF(KCHA.NE.0) K(IGNEW,2)=22
68140 ELSE
68141 K(INEW,2)=-ISIGN(KFQ,KCOL)
68142 K(IGNEW,2)=-K(INEW,2)
68143 ENDIF
68144 K(IRNEW,2)=K(IR,2)
68145 K(INEW,3)=I
68146 K(IGNEW,3)=I
68147 K(IRNEW,3)=IR
68148
68149C...Find rest frame and angles of branching+recoil.
68150 DO 380 J=1,5
68151 P(INEW,J)=P(I,J)
68152 P(IGNEW,J)=0D0
68153 P(IRNEW,J)=P(IR,J)
68154 380 CONTINUE
68155 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
68156 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
68157 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
68158 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
68159 PHI=PYANGL(P(INEW,1),P(INEW,2))
68160 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
68161
68162C...Derive kinematics of branching: generics (like g->gg).
68163 DO 390 J=1,4
68164 P(INEW,J)=0D0
68165 P(IRNEW,J)=0D0
68166 390 CONTINUE
68167 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
68168 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
68169 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
68170 PTCOR=SQRT(MAX(0D0,PT2COR))
68171 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
68172 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
68173C...Specific kinematics reduction for q->qg with m_q > 0.
68174 IF(MOCT.NE.1) THEN
68175 PTCOR=(1D0-PM2I/PM2)*PTCOR
68176 PZN=PZN+PM2I*PZG/PM2
68177 PZG=(1D0-PM2I/PM2)*PZG
68178C...Specific kinematics reduction for g->qqbar with m_q > 0.
68179 ELSEIF(KFQ.NE.0) THEN
68180 P(INEW,5)=PMQ
68181 P(IGNEW,5)=PMQ
68182 PTCOR=ROOTQQ*PTCOR
68183 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
68184 PZG=PZM-PZN
68185 ENDIF
68186
68187C...Pick phi and construct kinematics of branching.
68188 400 PHIROT=PARU(2)*PYR(0)
68189 P(INEW,1)=PTCOR*COS(PHIROT)
68190 P(INEW,2)=PTCOR*SIN(PHIROT)
68191 P(INEW,3)=PZN
68192 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
68193 P(IGNEW,1)=-P(INEW,1)
68194 P(IGNEW,2)=-P(INEW,2)
68195 P(IGNEW,3)=PZG
68196 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
68197 P(IRNEW,1)=0D0
68198 P(IRNEW,2)=0D0
68199 P(IRNEW,3)=-PZM
68200 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
68201
68202C...Boost branching system to lab frame.
68203 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
68204
68205C...Renew choice of phi angle according to polarization asymmetry.
68206 IF(ABS(ASYPOL).GT.1D-3) THEN
68207 DO 410 J=1,3
68208 DPT(1,J)=P(I,J)
68209 DPT(2,J)=P(IAU,J)
68210 DPT(3,J)=P(INEW,J)
68211 410 CONTINUE
68212 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
68213 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
68214 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
68215 DO 420 J=1,3
68216 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
68217 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
68218 420 CONTINUE
68219 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
68220 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
68221 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
68222 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
68223 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
68224 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
68225 & GOTO 400
68226 ENDIF
68227 ENDIF
68228
68229C...Matrix element corrections for primary partons when requested.
68230 IF(IMESYS.GT.0) THEN
68231 M3JC=MESYS(IMESYS,0)
68232
68233C...Identify recoiling partner and set up three-body kinematics.
68234 IRP=MESYS(IMESYS,1)
68235 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
68236 IF(IRP.EQ.IR) IRP=IRNEW
68237 DO 430 J=1,4
68238 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
68239 430 CONTINUE
68240 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
68241 & PSUM(3)**2))
68242 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
68243 & PSUM(3)*P(INEW,3))/PSUM(5)**2
68244 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
68245 & PSUM(3)*P(IRP,3))/PSUM(5)**2
68246 X3=2D0-X1-X2
68247 R1ME=P(INEW,5)/PSUM(5)
68248 R2ME=P(IRP,5)/PSUM(5)
68249
68250C...Matrix elements for gluon emission.
68251 IF(M3JC.LT.100) THEN
68252
68253C...Call ME, with right order important for two inequivalent showerers.
68254 IF(MESYS(IMESYS,IORD).EQ.I) THEN
68255 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
68256 ELSE
68257 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
68258 ENDIF
68259
68260C...Split up total ME when two radiating partons.
68261 ISPRAD=1
68262 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
68263 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
68264 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
68265 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
68266 & MAX(1D-10,2D0-X1-X2)
68267
68268C...Evaluate shower rate.
68269 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68270 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68271 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
68272
68273C...Matrix elements for photon emission: still rather primitive.
68274 ELSE
68275
68276C...For generic charge combination currently only massless expression.
68277 IF(M3JC.EQ.101) THEN
68278 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
68279 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
68280 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
68281 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
68282
68283C...For flavour neutral system assume vector source and include masses.
68284 ELSE
68285 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
68286 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
68287 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68288 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68289 ENDIF
68290 ENDIF
68291
68292C...Perform weighting with W_ME/W_PS.
68293 IF(WME.LT.PYR(0)*WPS) THEN
68294 N=N-3
68295 IFLG(IMX)=0
68296 PT2CMX=PT2
68297 GOTO 290
68298 ENDIF
68299 ENDIF
68300
68301C...Now for sure accepted branching. Save highest pT.
68302 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
68303
68304C...Update status for obsolete ones. Bookkkep the moved original parton
68305C...and new daughter (arbitrary choice for g->gg or g->qqbar).
68306C...Do not bookkeep radiated photon, since it cannot radiate further.
68307 K(I,1)=K(I,1)+10
68308 K(IR,1)=K(IR,1)+10
68309 DO 440 IP=1,NPART
68310 IF(IPART(IP).EQ.I) IPART(IP)=INEW
68311 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
68312 440 CONTINUE
68313 IF(KCHA.EQ.0) THEN
68314 NPART=NPART+1
68315 IPART(NPART)=IGNEW
68316 ENDIF
68317
68318C...Initialize colour flow of branching.
68319C...Use both old and new style colour tags for flexibility.
68320 K(INEW,4)=0
68321 K(IGNEW,4)=0
68322 K(INEW,5)=0
68323 K(IGNEW,5)=0
68324 JCOLP=4+(1-KCOL)/2
68325 JCOLN=9-JCOLP
68326 MCT(INEW,1)=0
68327 MCT(INEW,2)=0
68328 MCT(IGNEW,1)=0
68329 MCT(IGNEW,2)=0
68330 MCT(IRNEW,1)=0
68331 MCT(IRNEW,2)=0
68332
68333C...Trivial colour flow for l->lgamma and q->qgamma.
68334 IF(IABS(KCHA).EQ.3) THEN
68335 K(I,4)=INEW
68336 K(I,5)=IGNEW
68337 ELSEIF(KCHA.NE.0) THEN
68338 IF(K(I,4).NE.0) THEN
68339 K(I,4)=K(I,4)+INEW
68340 K(INEW,4)=MSTU(5)*I
68341 MCT(INEW,1)=MCT(I,1)
68342 ENDIF
68343 IF(K(I,5).NE.0) THEN
68344 K(I,5)=K(I,5)+INEW
68345 K(INEW,5)=MSTU(5)*I
68346 MCT(INEW,2)=MCT(I,2)
68347 ENDIF
68348
68349C...Set colour flow for q->qg and g->gg.
68350 ELSEIF(KFQ.EQ.0) THEN
68351 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68352 K(IGNEW,JCOLP)=MSTU(5)*I
68353 K(INEW,JCOLP)=MSTU(5)*IGNEW
68354 K(IGNEW,JCOLN)=MSTU(5)*INEW
68355 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68356 NCT=NCT+1
68357 MCT(INEW,JCOLP-3)=NCT
68358 MCT(IGNEW,JCOLN-3)=NCT
68359 IF(MOCT.GE.1) THEN
68360 K(I,JCOLN)=K(I,JCOLN)+INEW
68361 K(INEW,JCOLN)=MSTU(5)*I
68362 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68363 ENDIF
68364
68365C...Set colour flow for g->qqbar.
68366 ELSE
68367 K(I,JCOLN)=K(I,JCOLN)+INEW
68368 K(INEW,JCOLN)=MSTU(5)*I
68369 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68370 K(IGNEW,JCOLP)=MSTU(5)*I
68371 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68372 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68373 ENDIF
68374
68375C...Daughter info for colourless recoiling parton.
68376 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
68377 K(IR,4)=IRNEW
68378 K(IR,5)=IRNEW
68379 K(IRNEW,4)=0
68380 K(IRNEW,5)=0
68381
68382C...Colour of recoiling parton sails through unchanged.
68383 ELSE
68384 IF(K(IR,4).NE.0) THEN
68385 K(IR,4)=K(IR,4)+IRNEW
68386 K(IRNEW,4)=MSTU(5)*IR
68387 MCT(IRNEW,1)=MCT(IR,1)
68388 ENDIF
68389 IF(K(IR,5).NE.0) THEN
68390 K(IR,5)=K(IR,5)+IRNEW
68391 K(IRNEW,5)=MSTU(5)*IR
68392 MCT(IRNEW,2)=MCT(IR,2)
68393 ENDIF
68394 ENDIF
68395
68396C...Vertex information trivial.
68397 DO 450 J=1,5
68398 V(INEW,J)=V(I,J)
68399 V(IGNEW,J)=V(I,J)
68400 V(IRNEW,J)=V(IR,J)
68401 450 CONTINUE
68402
68403C...Update list of old radiators.
68404 DO 460 IEVOL=1,NEVOL
68405 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
68406 IPOS(IEVOL)=INEW
68407 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
68408 IREC(IEVOL)=IRNEW
68409 IFLG(IEVOL)=0
68410 ELSEIF(IPOS(IEVOL).EQ.I) THEN
68411 IPOS(IEVOL)=INEW
68412 IFLG(IEVOL)=0
68413 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
68414 IPOS(IEVOL)=IRNEW
68415 IREC(IEVOL)=INEW
68416 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
68417 IFLG(IEVOL)=0
68418 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
68419 IPOS(IEVOL)=IRNEW
68420 IFLG(IEVOL)=0
68421 ENDIF
68422C...Update links of old connected partons.
68423 IF(IREC(IEVOL).EQ.I) THEN
68424 IREC(IEVOL)=INEW
68425 IFLG(IEVOL)=0
68426 ELSEIF(IREC(IEVOL).EQ.IR) THEN
68427 IREC(IEVOL)=IRNEW
68428 IFLG(IEVOL)=0
68429 ENDIF
68430 460 CONTINUE
68431
68432C...q->qg or g->gg: create new gluon radiators.
68433 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
68434 NEVOL=NEVOL+1
68435 IPOS(NEVOL)=INEW
68436 IREC(NEVOL)=IGNEW
68437 IFLG(NEVOL)=0
68438 ISCOL(NEVOL)=KCOL
68439 ISCHG(NEVOL)=0
68440 PTSCA(NEVOL)=SQRT(PT2)
68441 NEVOL=NEVOL+1
68442 IPOS(NEVOL)=IGNEW
68443 IREC(NEVOL)=INEW
68444 IFLG(NEVOL)=0
68445 ISCOL(NEVOL)=-KCOL
68446 ISCHG(NEVOL)=0
68447 PTSCA(NEVOL)=PTSCA(NEVOL-1)
68448 ENDIF
68449
68450C...Update matrix elements parton list and add new for g/gamma->qqbar.
68451 DO 470 IME=1,NMESYS
68452 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
68453 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
68454 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
68455 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
68456 470 CONTINUE
68457 IF(KFQ.NE.0) THEN
68458 NMESYS=NMESYS+1
68459 MESYS(NMESYS,0)=66
68460 MESYS(NMESYS,1)=INEW
68461 MESYS(NMESYS,2)=IGNEW
68462 NMESYS=NMESYS+1
68463 MESYS(NMESYS,0)=102
68464 MESYS(NMESYS,1)=INEW
68465 MESYS(NMESYS,2)=IGNEW
68466 ENDIF
68467
68468C...Global statistics.
68469 MINT(353)=MINT(353)+1
68470 VINT(353)=VINT(353)+PTCOR
68471 IF (MINT(353).EQ.1) VINT(358)=PTCOR
68472
68473C...Loopback for more emissions if enough space.
68474 PT2CMX=PT2
68475 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
68476 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
68477 GOTO 280
68478 ELSE
68479 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
68480 ENDIF
68481
68482C...Done.
68483 480 CONTINUE
68484
68485 RETURN
68486 END
68487
68488C*********************************************************************
68489
68490C...PYMAEL
68491C...Auxiliary to PYSHOW and PYPTFS.
68492C...Matrix elements for gluon (or photon) emission from
68493C...a two-body state; to be used by the parton shower routine.
68494C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
68495C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
68496C... = (alpha-strong/2 pi) * CF * PYMAEL,
68497C...i.e. normalization is such that one recovers the familiar
68498C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
68499C...Coupling structure:
68500C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
68501C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
68502C... = 16-19 : q -> q V
68503C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
68504C... = 26-29 : q -> q S
68505C... = 31-34 : V -> ~q ~qbar (~q = squark)
68506C... = 36-39 : ~q -> ~q V
68507C... = 41-44 : S -> ~q ~qbar
68508C... = 46-49 : ~q -> ~q S
68509C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
68510C... = 56-59 : ~q -> q chi
68511C... = 61-64 : q -> ~q chi
68512C... = 66-69 : ~g -> q ~qbar
68513C... = 71-74 : ~q -> q ~g
68514C... = 76-79 : q -> ~q ~g
68515C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
68516C...Note that the order of the decay products is important.
68517C...In each set of four, the variants are ordered as:
68518C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
68519C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
68520C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
68521C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
68522
68523 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
68524
68525C...Double precision and integer declarations.
68526 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68527 IMPLICIT INTEGER(I-N)
68528
68529C...Check input values. Return zero outside allowed phase space.
68530 PYMAEL=0D0
68531 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
68532 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
68533 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
68534 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
68535 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
68536 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
68537
68538C...Initial values and flags.
68539 ICLASS=NI/5
68540 ICOMBI=NI-5*ICLASS
68541 ISSET1=0
68542 ISSET2=0
68543 ISSET4=0
68544
68545C... Phase space.
68546 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
68547
68548C...Eikonal expression; also acts as default.
68549 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
68550 RLO=PS
68551 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
68552 ANUM=0D0
68553 ELSEIF(ICOMBI.EQ.2) THEN
68554 ANUM=(2D0-X1-X2)**2
68555 ELSEIF(ICOMBI.EQ.3) THEN
68556 ANUM=ALPCOR*(2D0-X1-X2)**2
68557 ELSE
68558 ANUM=0.5D0*(2D0-X1-X2)**2
68559 ENDIF
68560 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
68561 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
68562 & R1**2/(1D0+R2**2-R1**2-X2)**2-
68563 & R2**2/(1D0+R1**2-R2**2-X1)**2)
68564 ICOMBI=0
68565
68566C...V -> q qbar (V = gamma*/Z0/W+-/...).
68567 ELSEIF(ICLASS.EQ.2) THEN
68568 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68569 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68570 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
68571 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
68572 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
68573 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
68574 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68575 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
68576 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
68577 & (-1+R1**2-R2**2+X2)**2
68578 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68579 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68580 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
68581 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68582 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
68583 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68584 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68585 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
68586 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
68587 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
68588 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
68589 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
68590 RFO1=RFO1/2.D0
68591 ISSET1=1
68592 ENDIF
68593 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68594 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68595 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
68596 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
68597 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
68598 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
68599 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
68600 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
68601 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
68602 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68603 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68604 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
68605 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68606 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
68607 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68608 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68609 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
68610 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
68611 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
68612 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68613 & +X2)/(-1-R1**2+R2**2+X1)**2
68614 RFO2=RFO2/2.D0
68615 ISSET2=1
68616 ENDIF
68617 IF(ICOMBI.EQ.4) THEN
68618 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
68619 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
68620 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
68621 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
68622 & (-1-R1**2+R2**2+X1)**2
68623 RFO4=RFO4
68624 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
68625 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
68626 & -R1**2*X2**2+X1*X2**2)/
68627 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68628 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
68629 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
68630 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
68631 & (-1+R1**2-R2**2+X2)**2
68632 RFO4=RFO4/2.D0
68633 ISSET4=1
68634 ENDIF
68635
68636C...q -> q V.
68637 ELSEIF(ICLASS.EQ.3) THEN
68638 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68639 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
68640 & +R1**2*R2**2-2D0*R2**4)
68641 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
68642 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
68643 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
68644 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
68645 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
68646 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
68647 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68648 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
68649 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68650 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
68651 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68652 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68653 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
68654 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
68655 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68656 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
68657 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68658 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
68659 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
68660 ISSET1=1
68661 ENDIF
68662 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68663 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
68664 & +R1**2*R2**2-2D0*R2**4)
68665 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
68666 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
68667 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
68668 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
68669 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
68670 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
68671 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68672 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
68673 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68674 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
68675 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68676 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68677 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68678 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
68679 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68680 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
68681 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68682 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68683 & +X1*X2**2)/(-2+X1+X2)**2
68684 ISSET2=1
68685 ENDIF
68686 IF(ICOMBI.EQ.4) THEN
68687 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
68688 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
68689 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
68690 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
68691 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
68692 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68693 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
68694 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
68695 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68696 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68697 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68698 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
68699 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
68700 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68701 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68702 & +X1*X2**2)/(2-X1-X2)**2
68703 ISSET4=1
68704 ENDIF
68705
68706C...S -> q qbar (S = h0/H0/A0/H+-/...).
68707 ELSEIF(ICLASS.EQ.4) THEN
68708 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68709 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
68710 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68711 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68712 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68713 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
68714 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
68715 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68716 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68717 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68718 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68719 ISSET1=1
68720 ENDIF
68721 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68722 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
68723 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68724 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68725 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68726 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68727 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68728 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68729 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
68730 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
68731 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
68732 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68733 ISSET2=1
68734 ENDIF
68735 IF(ICOMBI.EQ.4) THEN
68736 RLO4=PS*(1D0-R1**2-R2**2)
68737 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
68738 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68739 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
68740 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
68741 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68742 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
68743 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68744 ISSET4=1
68745 ENDIF
68746
68747C...q -> q S.
68748 ELSEIF(ICLASS.EQ.5) THEN
68749 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68750 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68751 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68752 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68753 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
68754 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68755 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68756 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68757 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68758 & (-1+R1**2-R2**2+X2)**2
68759 ISSET1=1
68760 ENDIF
68761 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68762 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68763 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68764 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68765 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
68766 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68767 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68768 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68769 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68770 & (-1+R1**2-R2**2+X2)**2
68771 ISSET2=1
68772 ENDIF
68773 IF(ICOMBI.EQ.4) THEN
68774 RLO4=PS*(1D0+R1**2-R2**2)
68775 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
68776 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68777 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
68778 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68779 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68780 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68781 ISSET4=1
68782 ENDIF
68783
68784C...V -> ~q ~qbar (~q = squark).
68785 ELSEIF(ICLASS.EQ.6) THEN
68786 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68787 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
68788 & (-1-R1**2+R2**2+X1)**2
68789 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
68790 & (-1-R1**2+R2**2+X1)
68791 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
68792 & /(-1+R1**2-R2**2+X2)**2
68793 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
68794 & (-1+R1**2-R2**2+X2)
68795 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
68796 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
68797 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
68798 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68799 ISSET1=1
68800
68801C...~q -> ~q V.
68802 ELSEIF(ICLASS.EQ.7) THEN
68803 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68804 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
68805 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
68806 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
68807 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68808 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
68809 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
68810 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
68811 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
68812 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
68813 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
68814 & (3*(-2+X1+X2))
68815 RFO1=3D0*RFO1/8D0
68816 ISSET1=1
68817
68818C...S -> ~q ~qbar.
68819 ELSEIF(ICLASS.EQ.8) THEN
68820 RLO1=PS
68821 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68822 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
68823 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
68824 & -R1**2*X2**2+X1*X2**2)/
68825 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
68826 RFO1=2D0*RFO1
68827 ISSET1=1
68828
68829C...~q -> ~q S.
68830 ELSEIF(ICLASS.EQ.9) THEN
68831 RLO1=PS
68832 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68833 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68834 & -(X1+X2)/(-2+X1+X2)**2
68835 ISSET1=1
68836
68837C...chi -> q ~qbar (chi = neutralino/chargino).
68838 ELSEIF(ICLASS.EQ.10) THEN
68839 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68840 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68841 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68842 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
68843 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68844 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68845 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68846 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68847 & (-1+R1**2-R2**2+X2)**2
68848 ISSET1=1
68849 ENDIF
68850 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68851 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
68852 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
68853 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
68854 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
68855 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68856 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68857 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68858 & (-1+R1**2-R2**2+X2)**2
68859 ISSET2=1
68860 ENDIF
68861 IF(ICOMBI.EQ.4) THEN
68862 RLO4=PS*(1+R1**2-R2**2)
68863 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68864 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
68865 & +X2+R1**2*X2-X1*X2/2)/
68866 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68867 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68868 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68869 ISSET4=1
68870 ENDIF
68871
68872C...~q -> q chi.
68873 ELSEIF(ICLASS.EQ.11) THEN
68874 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68875 RLO1=PS*(1D0-(R1+R2)**2)
68876 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68877 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68878 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68879 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68880 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68881 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68882 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68883 ISSET1=1
68884 ENDIF
68885 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68886 RLO2=PS*(1D0-(R1-R2)**2)
68887 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
68888 & (-2+X1+X2)**2
68889 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68890 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68891 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68892 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
68893 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68894 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68895 ISSET2=1
68896 ENDIF
68897 IF(ICOMBI.EQ.4) THEN
68898 RLO4=PS*(1D0-R1**2-R2**2)
68899 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68900 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
68901 & +3*R1**2*X2-R2**2*X2-X1*X2)/
68902 & (-1+R1**2-R2**2+X2)**2
68903 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
68904 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
68905 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68906 ISSET4=1
68907 ENDIF
68908
68909C...q -> ~q chi.
68910 ELSEIF(ICLASS.EQ.12) THEN
68911 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68912 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
68913 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68914 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
68915 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
68916 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
68917 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68918 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68919 ISSET1=1
68920 END IF
68921 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68922 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
68923 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
68924 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
68925 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
68926 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
68927 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68928 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68929 ISSET2=1
68930 END IF
68931 IF(ICOMBI.EQ.4) THEN
68932 RLO4=PS*(1D0-R1**2+R2**2)
68933 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68934 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
68935 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
68936 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
68937 & +R1**2*X2-X1*X2/2-X2**2/2)/
68938 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68939 ISSET4=1
68940 END IF
68941
68942C...~g -> q ~qbar.
68943 ELSEIF(ICLASS.EQ.13) THEN
68944 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68945 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68946 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
68947 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
68948 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
68949 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
68950 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68951 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
68952 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
68953 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
68954 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
68955 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
68956 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
68957 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68958 & (3*(-1+R1**2-R2**2+X2)**2)
68959 RFO1=3D0*RFO1/4D0
68960 ISSET1=1
68961 ENDIF
68962 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68963 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68964 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
68965 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
68966 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
68967 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
68968 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
68969 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
68970 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
68971 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
68972 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
68973 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68974 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
68975 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
68976 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68977 & (3*(-1+R1**2-R2**2+X2)**2)
68978 RFO2=3D0*RFO2/4D0
68979 ISSET2=1
68980 ENDIF
68981 IF(ICOMBI.EQ.4) THEN
68982 RLO4=PS*(1D0+R1**2-R2**2)
68983 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
68984 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
68985 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
68986 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
68987 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
68988 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68989 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
68990 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68991 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
68992 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68993 & (3*(-1+R1**2-R2**2+X2)**2)
68994 RFO4=3D0*RFO4/8D0
68995 ISSET4=1
68996 ENDIF
68997
68998C...~q -> q ~g.
68999 ELSEIF(ICLASS.EQ.14) THEN
69000 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69001 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
69002 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
69003 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
69004 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
69005 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
69006 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
69007 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
69008 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69009 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
69010 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
69011 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69012 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
69013 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
69014 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69015 RFO1=RFO1
69016 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
69017 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
69018 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69019 RFO1=9D0*RFO1/64D0
69020 ISSET1=1
69021 ENDIF
69022 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69023 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
69024 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
69025 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
69026 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
69027 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
69028 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
69029 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
69030 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
69031 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
69032 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
69033 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69034 RFO2=RFO2
69035 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
69036 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
69037 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69038 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
69039 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
69040 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69041 RFO2=9D0*RFO2/64D0
69042 ISSET2=1
69043 ENDIF
69044 IF(ICOMBI.EQ.4) THEN
69045 RLO4=PS*(1-R1**2-R2**2)
69046 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
69047 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
69048 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
69049 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
69050 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
69051 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
69052 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
69053 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69054 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
69055 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
69056 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
69057 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
69058 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
69059 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
69060 RFO4=9D0*RFO4/128D0
69061 ISSET4=1
69062 ENDIF
69063
69064C...q -> ~q ~g.
69065 ELSEIF(ICLASS.EQ.15) THEN
69066 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69067 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
69068 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69069 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
69070 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
69071 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
69072 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
69073 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69074 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
69075 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
69076 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69077 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
69078 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
69079 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
69080 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69081 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69082 RFO1=9D0*RFO1/32D0
69083 ISSET1=1
69084 END IF
69085 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69086 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
69087 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
69088 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
69089 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
69090 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
69091 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
69092 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69093 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
69094 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
69095 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69096 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
69097 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
69098 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
69099 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
69100 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69101 RFO2=9D0*RFO2/32D0
69102 ISSET2=1
69103 END IF
69104 IF(ICOMBI.EQ.4) THEN
69105 RLO4=PS*(1D0-R1**2+R2**2)
69106 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69107 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
69108 & -R2**2*X2/2-X1*X2/2)/
69109 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
69110 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
69111 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69112 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
69113 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69114 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
69115 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
69116 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69117 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69118 RFO4=9D0*RFO4/64D0
69119 ISSET4=1
69120 END IF
69121
69122C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
69123 ELSEIF(ICLASS.EQ.16) THEN
69124 RLO=PS
69125 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
69126 ANUM=0D0
69127 ELSEIF(ICOMBI.EQ.2) THEN
69128 ANUM=(2D0-X1-X2)**2
69129 ELSEIF(ICOMBI.EQ.3) THEN
69130 ANUM=ALPCOR*(2D0-X1-X2)**2
69131 ELSE
69132 ANUM=0.5D0*(2D0-X1-X2)**2
69133 ENDIF
69134 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
69135 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
69136 & R1**2/(1D0+R2**2-R1**2-X2)**2-
69137 & R2**2/(1D0+R1**2-R2**2-X1)**2)
69138 RFO=9D0*RFO/4D0
69139 ICOMBI=0
69140 ENDIF
69141
69142C...Find relevant LO and FO expression.
69143 IF(ICOMBI.EQ.0) THEN
69144 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
69145 RLO=RLO1
69146 RFO=RFO1
69147 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
69148 RLO=RLO2
69149 RFO=RFO2
69150 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69151 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
69152 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
69153 ELSEIF(ISSET4.EQ.1) THEN
69154 RLO=RLO4
69155 RFO=RFO4
69156 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69157 RLO=0.5D0*(RLO1+RLO2)
69158 RFO=0.5D0*(RFO1+RFO2)
69159 ELSEIF(ISSET1.EQ.1) THEN
69160 RLO=RLO1
69161 RFO=RFO1
69162 ELSE
69163 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
69164 RLO=1D0
69165 RFO=0D0
69166 ENDIF
69167
69168C...Output.
69169 PYMAEL=RFO/RLO
69170
69171 RETURN
69172 END
69173
69174C*********************************************************************
69175
69176C...PYBOEI
69177C...Modifies an event so as to approximately take into account
69178C...Bose-Einstein effects according to a simple phenomenological
69179C...parametrization.
69180
69181 SUBROUTINE PYBOEI(NSAV)
69182
69183C...Double precision and integer declarations.
69184 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69185 IMPLICIT INTEGER(I-N)
69186 INTEGER PYK,PYCHGE,PYCOMP
69187C...Parameter statement to help give large particle numbers.
69188 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69189 &KEXCIT=4000000,KDIMEN=5000000)
69190C...Commonblocks.
69191 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69192 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69193 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69194 COMMON/PYINT1/MINT(400),VINT(400)
69195 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
69196C...Local arrays and data.
69197 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
69198 &BEIW(100),BEI3W(100)
69199 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
69200C...Statement function: squared invariant mass.
69201 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
69202 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
69203
69204C...Boost event to overall CM frame. Calculate CM energy.
69205 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
69206 DO 100 J=1,4
69207 DPS(J)=0D0
69208 100 CONTINUE
69209 DO 120 I=1,N
69210 KFA=IABS(K(I,2))
69211 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
69212 & .AND.K(I,3).GT.0) THEN
69213 KFMA=IABS(K(K(I,3),2))
69214 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
69215 ENDIF
69216 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
69217 DO 110 J=1,4
69218 DPS(J)=DPS(J)+P(I,J)
69219 110 CONTINUE
69220 120 CONTINUE
69221 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
69222 &-DPS(3)/DPS(4))
69223 PECM=0D0
69224 DO 130 I=1,N
69225 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
69226 130 CONTINUE
69227
69228C...Check if we have separated strings
69229
69230C...Reserve copy of particles by species at end of record.
69231 IWP=0
69232 IWN=0
69233 NBE(0)=N+MSTU(3)
69234 NMAX=NBE(0)
69235 SMMIN=PECM
69236 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
69237 NBE(IBE)=NBE(IBE-1)
69238 DO 180 I=NSAV+1,N
69239 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
69240 DO 140 IIBE=1,IBE-1
69241 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
69242 140 CONTINUE
69243 ELSE
69244 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
69245 ENDIF
69246 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
69247 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
69248 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
69249 RETURN
69250 ENDIF
69251 NBE(IBE)=NBE(IBE)+1
69252 NMAX=NBE(IBE)
69253 K(NBE(IBE),1)=I
69254 K(NBE(IBE),2)=0
69255 K(NBE(IBE),3)=0
69256 K(NBE(IBE),4)=0
69257 K(NBE(IBE),5)=0
69258 P(NBE(IBE),1)=0.0D0
69259 P(NBE(IBE),2)=0.0D0
69260 P(NBE(IBE),3)=0.0D0
69261 P(NBE(IBE),4)=0.0D0
69262 P(NBE(IBE),5)=0.0D0
69263 SMMIN=MIN(SMMIN,P(I,5))
69264C...Check if particles comes from different W's or Z's
69265 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
69266 IM=I
69267 150 IF(K(IM,3).GT.0) THEN
69268 IM=K(IM,3)
69269 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
69270 K(NBE(IBE),5)=IM
69271 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
69272 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
69273 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
69274 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
69275 ENDIF
69276 ENDIF
69277C...Check if particles comes from different strings.
69278 IF(PARJ(94).GT.0.0D0) THEN
69279 IM=I
69280 160 IF(K(IM,3).GT.0) THEN
69281 IM=K(IM,3)
69282 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
69283 K(NBE(IBE),5)=IM
69284 ENDIF
69285 ENDIF
69286 DO 170 J=1,3
69287 P(NBE(IBE),J)=0D0
69288 V(NBE(IBE),J)=0D0
69289 170 CONTINUE
69290 P(NBE(IBE),5)=-1.0D0
69291 180 CONTINUE
69292 190 CONTINUE
69293 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
69294
69295C...Calculate separation between W+ and W- or between two Z0's.
69296C...No separation if there has been re-connections.
69297 SIGW=PARJ(93)
69298 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
69299 IF(K(IWP,2).EQ.23) THEN
69300 DMW=PMAS(23,1)
69301 DGW=PMAS(23,2)
69302 ELSE
69303 DMW=PMAS(24,1)
69304 DGW=PMAS(24,2)
69305 ENDIF
69306 DMP=P(IWP,5)
69307 DMN=P(IWN,5)
69308 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
69309 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
69310 TAUP=-TAUPD*LOG(PYR(IDUM))
69311 TAUN=-TAUND*LOG(PYR(IDUM))
69312 DXP=TAUP*PYP(IWP,8)/DMP
69313 DXN=TAUN*PYP(IWN,8)/DMN
69314 DX=DXP+DXN
69315 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
69316 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
69317 ENDIF
69318
69319C...Add separation between strings.
69320 IF(PARJ(94).GT.0.0D0) THEN
69321 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
69322 IWP=-1
69323 IWN=-1
69324 ENDIF
69325
69326 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
69327 DO 220 IBE=1,MIN(9,MSTJ(52))
69328 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
69329 Q2MIN=PECM**2
69330 I1=K(I1M,1)
69331 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
69332 IF(I2M.EQ.I1M) GOTO 200
69333 I2=K(I2M,1)
69334 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
69335 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
69336 & (P(I1,5)+P(I2,5))**2
69337 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
69338 Q2MIN=Q2
69339 ENDIF
69340 200 CONTINUE
69341 P(I1M,5)=Q2MIN
69342 210 CONTINUE
69343 220 CONTINUE
69344 ENDIF
69345
69346C...Tabulate integral for subsequent momentum shift.
69347 DO 400 IBE=1,MIN(9,MSTJ(52))
69348 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
69349 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
69350 & .LE.1) GOTO 270
69351 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
69352 & NBE(7)-NBE(6)).LE.1) GOTO 270
69353 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
69354 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
69355 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
69356 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
69357 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
69358 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
69359 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
69360 QDELW=0.1D0*MIN(PMHQ,SIGW)
69361 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
69362 IF(MSTJ(51).EQ.1) THEN
69363 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
69364 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
69365 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
69366 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
69367 BEEX=EXP(0.5D0*QDEL/PARJ(93))
69368 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
69369 BEEXW=EXP(0.5D0*QDELW/SIGW)
69370 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
69371 BERT=EXP(-QDEL/PARJ(93))
69372 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
69373 BERTW=EXP(-QDELW/SIGW)
69374 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
69375 ELSE
69376 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
69377 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
69378 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
69379 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
69380 ENDIF
69381 DO 230 IBIN=1,NBIN
69382 QBIN=QDEL*(IBIN-0.5D0)
69383 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69384 IF(MSTJ(51).EQ.1) THEN
69385 BEEX=BEEX*BERT
69386 BEI(IBIN)=BEI(IBIN)*BEEX
69387 ELSE
69388 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
69389 ENDIF
69390 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
69391 230 CONTINUE
69392 DO 240 IBIN=1,NBIN3
69393 QBIN=QDEL3*(IBIN-0.5D0)
69394 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69395 IF(MSTJ(51).EQ.1) THEN
69396 BEEX3=BEEX3*BERT3
69397 BEI3(IBIN)=BEI3(IBIN)*BEEX3
69398 ELSE
69399 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
69400 ENDIF
69401 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
69402 240 CONTINUE
69403 DO 250 IBIN=1,NBINW
69404 QBIN=QDELW*(IBIN-0.5D0)
69405 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69406 IF(MSTJ(51).EQ.1) THEN
69407 BEEXW=BEEXW*BERTW
69408 BEIW(IBIN)=BEIW(IBIN)*BEEXW
69409 ELSE
69410 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
69411 ENDIF
69412 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
69413 250 CONTINUE
69414 DO 260 IBIN=1,NBIN3W
69415 QBIN=QDEL3W*(IBIN-0.5D0)
69416 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
69417 & SQRT(QBIN**2+PMHQ**2)
69418 IF(MSTJ(51).EQ.1) THEN
69419 BEEX3W=BEEX3W*BERT3W
69420 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
69421 ELSE
69422 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
69423 ENDIF
69424 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
69425 260 CONTINUE
69426
69427C...Loop through particle pairs and find old relative momentum.
69428 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
69429 I1=K(I1M,1)
69430 DO 380 I2M=I1M+1,NBE(IBE)
69431 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
69432 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
69433 I2=K(I2M,1)
69434 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
69435 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
69436 IF(Q2OLD.LE.0.0D0) GOTO 380
69437 QOLD=SQRT(Q2OLD)
69438
69439C...Calculate new relative momentum.
69440 QMOV=0.0D0
69441 QMOV3=0.0D0
69442 QMOVW=0.0D0
69443 QMOV3W=0.0D0
69444 IF(QOLD.LT.1D-3*QDEL) THEN
69445 GOTO 280
69446 ELSEIF(QOLD.LE.QDEL) THEN
69447 QMOV=QOLD/3D0
69448 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
69449 RBIN=QOLD/QDEL
69450 IBIN=RBIN
69451 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
69452 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
69453 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69454 ELSE
69455 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69456 ENDIF
69457 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
69458 IF(QOLD.LT.1D-3*QDEL3) THEN
69459 GOTO 290
69460 ELSEIF(QOLD.LE.QDEL3) THEN
69461 QMOV3=QOLD/3D0
69462 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
69463 RBIN3=QOLD/QDEL3
69464 IBIN3=RBIN3
69465 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
69466 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
69467 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69468 ELSE
69469 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69470 ENDIF
69471 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
69472 RSCALE=1.0D0
69473 IF(MSTJ(54).EQ.2)
69474 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
69475 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
69476 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
69477
69478 IF(QOLD.LT.1D-3*QDELW) THEN
69479 GOTO 300
69480 ELSEIF(QOLD.LE.QDELW) THEN
69481 QMOVW=QOLD/3D0
69482 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
69483 RBINW=QOLD/QDELW
69484 IBINW=RBINW
69485 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
69486 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
69487 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69488 ELSE
69489 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69490 ENDIF
69491 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
69492 IF(QOLD.LT.1D-3*QDEL3W) THEN
69493 GOTO 310
69494 ELSEIF(QOLD.LE.QDEL3W) THEN
69495 QMOV3W=QOLD/3D0
69496 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
69497 RBIN3W=QOLD/QDEL3W
69498 IBIN3W=RBIN3W
69499 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
69500 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
69501 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69502 ELSE
69503 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69504 ENDIF
69505 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
69506 IF(MSTJ(54).EQ.2)
69507 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
69508
69509 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
69510 DO 330 J=1,3
69511 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
69512 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
69513 330 CONTINUE
69514 IF(MSTJ(54).GE.1) THEN
69515 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
69516 DO 340 J=1,3
69517 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
69518 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
69519 340 CONTINUE
69520 ELSEIF(MSTJ(54).LE.-1) THEN
69521 EDEL=P(I1,4)+P(I2,4)-
69522 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
69523 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69524 & (P(I1,3)-P(I2,3))**2
69525 WMAX=-1.0D20
69526 MI3=0
69527 MI4=0
69528 S12=SDIP(I1,I2)
69529 SM1=(P(I1,5)+SMMIN)**2
69530 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69531 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
69532 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
69533 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69534 & K(I3M,5).NE.K(I1M,5)) GOTO 360
69535 I3=K(I3M,1)
69536 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
69537 S13=SDIP(I1,I3)
69538 S23=SDIP(I2,I3)
69539 SM3=(P(I3,5)+SMMIN)**2
69540 IF(MSTJ(54).EQ.-2) THEN
69541 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
69542 & S23*MIN(SM1,SM3))*SM1)
69543 ELSE
69544 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
69545 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
69546 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
69547 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
69548 ENDIF
69549 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
69550 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
69551 & GOTO 360
69552 ELSE
69553 IF(WMAX*WI.GE.1.0) GOTO 360
69554 ENDIF
69555 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
69556 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
69557 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
69558 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69559 & K(I4M,5).NE.K(I1M,5)) GOTO 350
69560 I4=K(I4M,1)
69561 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
69562 & GOTO 350
69563 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
69564 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69565 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
69566 & GOTO 350
69567 IF(MSTJ(54).EQ.-2) THEN
69568 S14=SDIP(I1,I4)
69569 S24=SDIP(I2,I4)
69570 S34=SDIP(I3,I4)
69571 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
69572 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
69573 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
69574 W=MIN(W,MIN(S23,S24)*S13*S14)
69575 W=1.0D0/W
69576 ELSE
69577C...weight=1-cos(theta)/mtot2
69578 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
69579 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
69580 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
69581 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
69582 W=1.0D0/S1234
69583 IF(W.LE.WMAX) GOTO 350
69584 ENDIF
69585 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
69586 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
69587 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
69588 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
69589 IF(W.LE.WMAX) GOTO 350
69590 MI3=I3M
69591 MI4=I4M
69592 WMAX=W
69593 350 CONTINUE
69594 360 CONTINUE
69595 IF(MI4.EQ.0) GOTO 380
69596 I3=K(MI3,1)
69597 I4=K(MI4,1)
69598 EOLD=P(I3,4)+P(I4,4)
69599 ENEW=EOLD+EDEL
69600 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69601 & (P(I3,3)+P(I4,3))**2
69602 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
69603 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
69604 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
69605 DO 370 J=1,3
69606 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
69607 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
69608 370 CONTINUE
69609 ENDIF
69610 380 CONTINUE
69611 390 CONTINUE
69612 400 CONTINUE
69613
69614C...Shift momenta and recalculate energies.
69615 ESUMP=0.0D0
69616 ESUM=0.0D0
69617 PROD=0.0D0
69618 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69619 I=K(IM,1)
69620 ESUMP=ESUMP+P(I,4)
69621 DO 410 J=1,3
69622 P(I,J)=P(I,J)+P(IM,J)
69623 410 CONTINUE
69624 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69625 ESUM=ESUM+P(I,4)
69626 DO 420 J=1,3
69627 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69628 420 CONTINUE
69629 430 CONTINUE
69630
69631 PARJ(96)=0.0D0
69632 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
69633 440 ALPHA=(ESUMP-ESUM)/PROD
69634 PARJ(96)=PARJ(96)+ALPHA
69635 PROD=0.0D0
69636 ESUM=0.0D0
69637 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69638 I=K(IM,1)
69639 DO 450 J=1,3
69640 P(I,J)=P(I,J)+ALPHA*V(IM,J)
69641 450 CONTINUE
69642 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69643 ESUM=ESUM+P(I,4)
69644 DO 460 J=1,3
69645 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69646 460 CONTINUE
69647 470 CONTINUE
69648 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
69649 & GOTO 440
69650 ENDIF
69651
69652C...Rescale all momenta for energy conservation.
69653 PES=0D0
69654 PQS=0D0
69655 DO 480 I=1,N
69656 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
69657 PES=PES+P(I,4)
69658 PQS=PQS+P(I,5)**2/P(I,4)
69659 480 CONTINUE
69660 PARJ(95)=PES-PECM
69661 FAC=(PECM-PQS)/(PES-PQS)
69662 DO 500 I=1,N
69663 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
69664 DO 490 J=1,3
69665 P(I,J)=FAC*P(I,J)
69666 490 CONTINUE
69667 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69668 500 CONTINUE
69669
69670C...Boost back to correct reference frame.
69671 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
69672 DO 520 I=1,N
69673 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
69674 520 CONTINUE
69675
69676 RETURN
69677 END
69678
69679C*********************************************************************
69680
69681C...PYBESQ
69682C...Calculates the momentum shift in a system of two particles assuming
69683C...the relative momentum squared should be shifted to Q2NEW. NI is the
69684C...last position occupied in /PYJETS/.
69685
69686 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
69687
69688C...Double precision and integer declarations.
69689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69690 IMPLICIT INTEGER(I-N)
69691 INTEGER PYK,PYCHGE,PYCOMP
69692C...Parameter statement to help give large particle numbers.
69693 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69694 &KEXCIT=4000000,KDIMEN=5000000)
69695C...Commonblocks.
69696 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69697 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69698 SAVE /PYJETS/,/PYDAT1/
69699C...Local arrays and data.
69700 DIMENSION DP(5)
69701 SAVE HC1
69702
69703 IF(MSTJ(55).EQ.0) THEN
69704 DQ2=Q2NEW-Q2OLD
69705 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69706 & (P(I1,3)-P(I2,3))**2
69707 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
69708 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
69709 SE=P(I1,4)+P(I2,4)
69710 DE=P(I1,4)-P(I2,4)
69711 DQ2SE=DQ2+SE**2
69712 DA=SE*DE*DP12-DP2*DQ2SE
69713 DB=DP2*DQ2SE-DP12**2
69714 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
69715 DO 100 J=1,3
69716 PD=HA*(P(I1,J)-P(I2,J))
69717 P(NI+1,J)=PD
69718 P(NI+2,J)=-PD
69719 100 CONTINUE
69720 RETURN
69721 ENDIF
69722
69723 K(NI+1,1)=1
69724 K(NI+2,1)=1
69725 DO 110 J=1,5
69726 P(NI+1,J)=P(I1,J)
69727 P(NI+2,J)=P(I2,J)
69728 DP(J)=P(I1,J)+P(I2,J)
69729 110 CONTINUE
69730
69731C...Boost to cms and rotate first particle to z-axis
69732 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
69733 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
69734 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
69735 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
69736 S=Q2NEW+(P(I1,5)+P(I2,5))**2
69737 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
69738 P(NI+1,1)=0.0D0
69739 P(NI+1,2)=0.0D0
69740 P(NI+1,3)=PZ
69741 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
69742 P(NI+2,1)=0.0D0
69743 P(NI+2,2)=0.0D0
69744 P(NI+2,3)=-PZ
69745 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
69746 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
69747 CALL PYROBO(NI+1,NI+2,THE,PHI,
69748 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
69749
69750 DO 120 J=1,3
69751 P(NI+1,J)=P(NI+1,J)-P(I1,J)
69752 P(NI+2,J)=P(NI+2,J)-P(I2,J)
69753 120 CONTINUE
69754
69755 RETURN
69756 END
69757
69758C*********************************************************************
69759
69760C...PYMASS
69761C...Gives the mass of a particle/parton.
69762
69763 FUNCTION PYMASS(KF)
69764
69765C...Double precision and integer declarations.
69766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69767 IMPLICIT INTEGER(I-N)
69768 INTEGER PYK,PYCHGE,PYCOMP
69769C...Commonblocks.
69770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69772 SAVE /PYDAT1/,/PYDAT2/
69773
69774C...Reset variables. Compressed code. Special case for popcorn diquarks.
69775 PYMASS=0D0
69776 KFA=IABS(KF)
69777 KC=PYCOMP(KF)
69778 IF(KC.EQ.0) THEN
69779 MSTJ(93)=0
69780 RETURN
69781 ENDIF
69782
69783C...Guarantee use of constituent masses for internal checks.
69784 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
69785 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
69786 IF(KFA.LE.5) THEN
69787 PYMASS=PARF(100+KFA)
69788 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
69789 ELSEIF(KFA.LE.10) THEN
69790 PYMASS=PMAS(KFA,1)
69791 ELSEIF(MSTJ(93).EQ.1) THEN
69792 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
69793 ELSE
69794 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
69795 ENDIF
69796
69797C...Other masses can be read directly off table.
69798 ELSE
69799 PYMASS=PMAS(KC,1)
69800 ENDIF
69801
69802C...Optional mass broadening according to truncated Breit-Wigner
69803C...(either in m or in m^2).
69804 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
69805 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
69806 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
69807 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
69808 ELSE
69809 PM0=PYMASS
69810 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
69811 & (PM0*PMAS(KC,2)))
69812 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
69813 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
69814 & (PMUPP-PMLOW)*PYR(0))))
69815 ENDIF
69816 ENDIF
69817 MSTJ(93)=0
69818
69819 RETURN
69820 END
69821
69822C*********************************************************************
69823
69824C...PYMRUN
69825C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
69826C...for Higgs couplings. Everything else sent on to PYMASS.
69827
69828 FUNCTION PYMRUN(KF,Q2)
69829
69830C...Double precision and integer declarations.
69831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69832 IMPLICIT INTEGER(I-N)
69833 INTEGER PYK,PYCHGE,PYCOMP
69834C...Commonblocks.
69835 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69837 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69838 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
69839
69840C...Most masses not handled here.
69841 KFA=IABS(KF)
69842 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
69843 PYMRUN=PYMASS(KF)
69844
69845C...Current-algebra masses, but no Q2 dependence.
69846 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
69847 PYMRUN=PARF(90+KFA)
69848
69849C...Running current-algebra masses.
69850 ELSE
69851 AS=PYALPS(Q2)
69852 PYMRUN=PARF(90+KFA)*
69853 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
69854 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
69855 ENDIF
69856
69857 RETURN
69858 END
69859
69860C*********************************************************************
69861
69862C...PYNAME
69863C...Gives the particle/parton name as a character string.
69864
69865 SUBROUTINE PYNAME(KF,CHAU)
69866
69867C...Double precision and integer declarations.
69868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69869 IMPLICIT INTEGER(I-N)
69870 INTEGER PYK,PYCHGE,PYCOMP
69871C...Commonblocks.
69872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69874 COMMON/PYDAT4/CHAF(500,2)
69875 CHARACTER CHAF*16
69876 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
69877C...Local character variable.
69878 CHARACTER CHAU*16
69879
69880C...Read out code with distinction particle/antiparticle.
69881 CHAU=' '
69882 KC=PYCOMP(KF)
69883 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
69884
69885
69886 RETURN
69887 END
69888
69889C*********************************************************************
69890
69891C...PYCHGE
69892C...Gives three times the charge for a particle/parton.
69893
69894 FUNCTION PYCHGE(KF)
69895
69896C...Double precision and integer declarations.
69897 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69898 IMPLICIT INTEGER(I-N)
69899 INTEGER PYK,PYCHGE,PYCOMP
69900C...Commonblocks.
69901 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69902 SAVE /PYDAT2/
69903
69904C...Read out charge and change sign for antiparticle.
69905 PYCHGE=0
69906 KC=PYCOMP(KF)
69907 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
69908
69909 RETURN
69910 END
69911
69912C*********************************************************************
69913
69914C...PYCOMP
69915C...Compress the standard KF codes for use in mass and decay arrays;
69916C...also checks whether a given code actually is defined.
69917
69918 FUNCTION PYCOMP(KF)
69919
69920C...Double precision and integer declarations.
69921 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69922 IMPLICIT INTEGER(I-N)
69923 INTEGER PYK,PYCHGE,PYCOMP
69924C...Commonblocks.
69925 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69926 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69927 SAVE /PYDAT1/,/PYDAT2/
69928C...Local arrays and saved data.
69929 DIMENSION KFORD(100:500),KCORD(101:500)
69930 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
69931
69932C...Whenever necessary reorder codes for faster search.
69933 IF(MSTU(20).EQ.0) THEN
69934 NFORD=100
69935 KFORD(100)=0
69936 DO 120 I=101,500
69937 KFA=KCHG(I,4)
69938 IF(KFA.LE.100) GOTO 120
69939 NFORD=NFORD+1
69940 DO 100 I1=NFORD-1,0,-1
69941 IF(KFA.GE.KFORD(I1)) GOTO 110
69942 KFORD(I1+1)=KFORD(I1)
69943 KCORD(I1+1)=KCORD(I1)
69944 100 CONTINUE
69945 110 KFORD(I1+1)=KFA
69946 KCORD(I1+1)=I
69947 120 CONTINUE
69948 MSTU(20)=1
69949 KFLAST=0
69950 KCLAST=0
69951 ENDIF
69952
69953C...Fast action if same code as in latest call.
69954 IF(KF.EQ.KFLAST) THEN
69955 PYCOMP=KCLAST
69956 RETURN
69957 ENDIF
69958
69959C...Starting values. Remove internal diquark flags.
69960 PYCOMP=0
69961 KFA=IABS(KF)
69962 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
69963 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
69964
69965C...Simple cases: direct translation.
69966 IF(KFA.GT.KFORD(NFORD)) THEN
69967 ELSEIF(KFA.LE.100) THEN
69968 PYCOMP=KFA
69969
69970C...Else binary search.
69971 ELSE
69972 IMIN=100
69973 IMAX=NFORD+1
69974 130 IAVG=(IMIN+IMAX)/2
69975 IF(KFORD(IAVG).GT.KFA) THEN
69976 IMAX=IAVG
69977 IF(IMAX.GT.IMIN+1) GOTO 130
69978 ELSEIF(KFORD(IAVG).LT.KFA) THEN
69979 IMIN=IAVG
69980 IF(IMAX.GT.IMIN+1) GOTO 130
69981 ELSE
69982 PYCOMP=KCORD(IAVG)
69983 ENDIF
69984 ENDIF
69985
69986C...Check if antiparticle allowed.
69987 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
69988 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
69989 ENDIF
69990
69991C...Save codes for possible future fast action.
69992 KFLAST=KF
69993 KCLAST=PYCOMP
69994
69995 RETURN
69996 END
69997
69998C*********************************************************************
69999
70000C...PYERRM
70001C...Informs user of errors in program execution.
70002
70003 SUBROUTINE PYERRM(MERR,CHMESS)
70004
70005C...Double precision and integer declarations.
70006 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70007 IMPLICIT INTEGER(I-N)
70008 INTEGER PYK,PYCHGE,PYCOMP
70009C...Commonblocks.
70010 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70011 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70012 SAVE /PYJETS/,/PYDAT1/
70013C...Local character variable.
70014 CHARACTER CHMESS*(*)
70015
70016C...Write first few warnings, then be silent.
70017 IF(MERR.LE.10) THEN
70018 MSTU(27)=MSTU(27)+1
70019 MSTU(28)=MERR
70020 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
70021 & MERR,MSTU(31),CHMESS
70022
70023C...Write first few errors, then be silent or stop program.
70024 ELSEIF(MERR.LE.20) THEN
70025 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
70026 MSTU(30)=MSTU(30)+1
70027 MSTU(24)=MERR-10
70028 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
70029 & MERR-10,MSTU(31),CHMESS
70030 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
70031 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
70032 WRITE(MSTU(11),5200)
70033 IF(MERR.NE.17) CALL PYLIST(2)
70034 CALL PYSTOP(3)
70035 ENDIF
70036
70037C...Stop program in case of irreparable error.
70038 ELSE
70039 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
70040 CALL PYSTOP(3)
70041 ENDIF
70042
70043C...Formats for output.
70044 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
70045 &' PYEXEC calls:'/5X,A)
70046 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
70047 &' PYEXEC calls:'/5X,A)
70048 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
70049 &'event!')
70050 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
70051 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
70052
70053 RETURN
70054 END
70055
70056C*********************************************************************
70057
70058C...PYALEM
70059C...Calculates the running alpha_electromagnetic.
70060
70061 FUNCTION PYALEM(Q2)
70062
70063C...Double precision and integer declarations.
70064 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70065 IMPLICIT INTEGER(I-N)
70066 INTEGER PYK,PYCHGE,PYCOMP
70067C...Commonblocks.
70068 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70069 SAVE /PYDAT1/
70070
70071C...Calculate real part of photon vacuum polarization.
70072C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
70073C...For hadrons use parametrization of H. Burkhardt et al.
70074C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
70075 AEMPI=PARU(101)/(3D0*PARU(1))
70076 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
70077 RPIGG=0D0
70078 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
70079 RPIGG=0D0
70080 ELSEIF(MSTU(101).EQ.2) THEN
70081 RPIGG=1D0-PARU(101)/PARU(103)
70082 ELSEIF(Q2.LT.0.09D0) THEN
70083 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
70084 ELSEIF(Q2.LT.9D0) THEN
70085 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
70086 & 0.00238D0*LOG(1D0+3.927D0*Q2)
70087 ELSEIF(Q2.LT.1D4) THEN
70088 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
70089 & 0.00299D0*LOG(1D0+Q2)
70090 ELSE
70091 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
70092 & 0.00293D0*LOG(1D0+Q2)
70093 ENDIF
70094
70095C...Calculate running alpha_em.
70096 PYALEM=PARU(101)/(1D0-RPIGG)
70097 PARU(108)=PYALEM
70098
70099 RETURN
70100 END
70101
70102C*********************************************************************
70103
70104C...PYALPS
70105C...Gives the value of alpha_strong.
70106
70107 FUNCTION PYALPS(Q2)
70108
70109C...Double precision and integer declarations.
70110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70111 IMPLICIT INTEGER(I-N)
70112 INTEGER PYK,PYCHGE,PYCOMP
70113C...Commonblocks.
70114 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70115 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70116 SAVE /PYDAT1/,/PYDAT2/
70117C...Coefficients for second-order threshold matching.
70118C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
70119 DIMENSION STEPDN(6),STEPUP(6)
70120c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
70121c &(2D0*321D0/3703D0),0D0/
70122c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
70123c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
70124 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
70125 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
70126
70127C...Constant alpha_strong trivial. Pick artificial Lambda.
70128 IF(MSTU(111).LE.0) THEN
70129 PYALPS=PARU(111)
70130 MSTU(118)=MSTU(112)
70131 PARU(117)=0.2D0
70132 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
70133 & ((33D0-2D0*MSTU(112))*PARU(111)))
70134 PARU(118)=PARU(111)
70135 RETURN
70136 ENDIF
70137
70138C...Find effective Q2, number of flavours and Lambda.
70139 Q2EFF=Q2
70140 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
70141 NF=MSTU(112)
70142 ALAM2=PARU(112)**2
70143 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
70144 Q2THR=PARU(113)*PMAS(NF,1)**2
70145 IF(Q2EFF.LT.Q2THR) THEN
70146 NF=NF-1
70147 Q2RAT=Q2THR/ALAM2
70148 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
70149 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
70150 GOTO 100
70151 ENDIF
70152 ENDIF
70153 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
70154 Q2THR=PARU(113)*PMAS(NF+1,1)**2
70155 IF(Q2EFF.GT.Q2THR) THEN
70156 NF=NF+1
70157 Q2RAT=Q2THR/ALAM2
70158 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
70159 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
70160 GOTO 110
70161 ENDIF
70162 ENDIF
70163 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
70164 PARU(117)=SQRT(ALAM2)
70165
70166C...Evaluate first or second order alpha_strong.
70167 B0=(33D0-2D0*NF)/6D0
70168 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
70169 IF(MSTU(111).EQ.1) THEN
70170 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
70171 ELSE
70172 B1=(153D0-19D0*NF)/6D0
70173 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
70174 & (B0**2*ALGQ)))
70175 ENDIF
70176 MSTU(118)=NF
70177 PARU(118)=PYALPS
70178
70179 RETURN
70180 END
70181
70182C*********************************************************************
70183
70184C...PYANGL
70185C...Reconstructs an angle from given x and y coordinates.
70186
70187 FUNCTION PYANGL(X,Y)
70188
70189C...Double precision and integer declarations.
70190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70191 IMPLICIT INTEGER(I-N)
70192 INTEGER PYK,PYCHGE,PYCOMP
70193C...Commonblocks.
70194 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70195 SAVE /PYDAT1/
70196
70197 PYANGL=0D0
70198 R=SQRT(X**2+Y**2)
70199 IF(R.LT.1D-20) RETURN
70200 IF(ABS(X)/R.LT.0.8D0) THEN
70201 PYANGL=SIGN(ACOS(X/R),Y)
70202 ELSE
70203 PYANGL=ASIN(Y/R)
70204 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
70205 PYANGL=PARU(1)-PYANGL
70206 ELSEIF(X.LT.0D0) THEN
70207 PYANGL=-PARU(1)-PYANGL
70208 ENDIF
70209 ENDIF
70210
70211 RETURN
70212 END
70213
70214C*********************************************************************
70215
70216C...PYROBO
70217C...Performs rotations and boosts.
70218
70219 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
70220
70221C...Double precision and integer declarations.
70222 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70223 IMPLICIT INTEGER(I-N)
70224 INTEGER PYK,PYCHGE,PYCOMP
70225C...Commonblocks.
70226 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70227 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70228 SAVE /PYJETS/,/PYDAT1/
70229C...Local arrays.
70230 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
70231
70232C...Find and check range of rotation/boost.
70233 IMIN=IMI
70234 IF(IMIN.LE.0) IMIN=1
70235 IF(MSTU(1).GT.0) IMIN=MSTU(1)
70236 IMAX=IMA
70237 IF(IMAX.LE.0) IMAX=N
70238 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70239 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
70240 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
70241 RETURN
70242 ENDIF
70243
70244C...Optional resetting of V (when not set before.)
70245 IF(MSTU(33).NE.0) THEN
70246 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
70247 DO 100 J=1,5
70248 V(I,J)=0D0
70249 100 CONTINUE
70250 110 CONTINUE
70251 MSTU(33)=0
70252 ENDIF
70253
70254C...Rotate, typically from z axis to direction (theta,phi).
70255 IF(THE**2+PHI**2.GT.1D-20) THEN
70256 ROT(1,1)=COS(THE)*COS(PHI)
70257 ROT(1,2)=-SIN(PHI)
70258 ROT(1,3)=SIN(THE)*COS(PHI)
70259 ROT(2,1)=COS(THE)*SIN(PHI)
70260 ROT(2,2)=COS(PHI)
70261 ROT(2,3)=SIN(THE)*SIN(PHI)
70262 ROT(3,1)=-SIN(THE)
70263 ROT(3,2)=0D0
70264 ROT(3,3)=COS(THE)
70265 DO 140 I=IMIN,IMAX
70266 IF(K(I,1).LE.0) GOTO 140
70267 DO 120 J=1,3
70268 PR(J)=P(I,J)
70269 VR(J)=V(I,J)
70270 120 CONTINUE
70271 DO 130 J=1,3
70272 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
70273 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
70274 130 CONTINUE
70275 140 CONTINUE
70276 ENDIF
70277
70278C...Boost, typically from rest to momentum/energy=beta.
70279 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
70280 DBX=BEX
70281 DBY=BEY
70282 DBZ=BEZ
70283 DB=SQRT(DBX**2+DBY**2+DBZ**2)
70284 EPS1=1D0-1D-12
70285 IF(DB.GT.EPS1) THEN
70286C...Rescale boost vector if too close to unity.
70287 CALL PYERRM(3,'(PYROBO:) boost vector too large')
70288 DBX=DBX*(EPS1/DB)
70289 DBY=DBY*(EPS1/DB)
70290 DBZ=DBZ*(EPS1/DB)
70291 DB=EPS1
70292 ENDIF
70293 DGA=1D0/SQRT(1D0-DB**2)
70294 DO 160 I=IMIN,IMAX
70295 IF(K(I,1).LE.0) GOTO 160
70296 DO 150 J=1,4
70297 DP(J)=P(I,J)
70298 DV(J)=V(I,J)
70299 150 CONTINUE
70300 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
70301 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
70302 P(I,1)=DP(1)+DGABP*DBX
70303 P(I,2)=DP(2)+DGABP*DBY
70304 P(I,3)=DP(3)+DGABP*DBZ
70305 P(I,4)=DGA*(DP(4)+DBP)
70306 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
70307 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
70308 V(I,1)=DV(1)+DGABV*DBX
70309 V(I,2)=DV(2)+DGABV*DBY
70310 V(I,3)=DV(3)+DGABV*DBZ
70311 V(I,4)=DGA*(DV(4)+DBV)
70312 160 CONTINUE
70313 ENDIF
70314
70315 RETURN
70316 END
70317
70318C*********************************************************************
70319
70320C...PYEDIT
70321C...Performs global manipulations on the event record, in particular
70322C...to exclude unstable or undetectable partons/particles.
70323
70324 SUBROUTINE PYEDIT(MEDIT)
70325
70326C...Double precision and integer declarations.
70327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70328 IMPLICIT INTEGER(I-N)
70329 INTEGER PYK,PYCHGE,PYCOMP
70330C...Parameter statement to help give large particle numbers.
70331 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70332 &KEXCIT=4000000,KDIMEN=5000000)
70333C...Commonblocks.
70334 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70335 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70336 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70337 COMMON/PYCTAG/NCT,MCT(4000,2)
70338 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
70339C...Local arrays.
70340 DIMENSION NS(2),PTS(2),PLS(2)
70341
70342C...Remove unwanted partons/particles.
70343 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
70344 IMAX=N
70345 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70346 I1=MAX(1,MSTU(1))-1
70347 DO 110 I=MAX(1,MSTU(1)),IMAX
70348 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
70349 IF(MEDIT.EQ.1) THEN
70350 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70351 ELSEIF(MEDIT.EQ.2) THEN
70352 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70353 KC=PYCOMP(K(I,2))
70354 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70355 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70356 & K(I,2).EQ.KSUSY1+39) GOTO 110
70357 ELSEIF(MEDIT.EQ.3) THEN
70358 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70359 KC=PYCOMP(K(I,2))
70360 IF(KC.EQ.0) GOTO 110
70361 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
70362 ELSEIF(MEDIT.EQ.5) THEN
70363 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
70364 KC=PYCOMP(K(I,2))
70365 IF(KC.EQ.0) GOTO 110
70366 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
70367 & KCHG(KC,2).EQ.0) GOTO 110
70368 ENDIF
70369
70370C...Pack remaining partons/particles. Origin no longer known.
70371 I1=I1+1
70372 DO 100 J=1,5
70373 K(I1,J)=K(I,J)
70374 P(I1,J)=P(I,J)
70375 V(I1,J)=V(I,J)
70376 100 CONTINUE
70377 K(I1,3)=0
70378 110 CONTINUE
70379 IF(I1.LT.N) MSTU(3)=0
70380 IF(I1.LT.N) MSTU(70)=0
70381 N=I1
70382
70383C...Selective removal of class of entries. New position of retained.
70384 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
70385 I1=0
70386 DO 120 I=1,N
70387 K(I,3)=MOD(K(I,3),MSTU(5))
70388 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
70389 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
70390 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
70391 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
70392 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
70393 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
70394 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
70395 I1=I1+1
70396 K(I,3)=K(I,3)+MSTU(5)*I1
70397 120 CONTINUE
70398
70399C...Find new event history information and replace old.
70400 DO 140 I=1,N
70401 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
70402 & K(I,3)/MSTU(5).EQ.0) GOTO 140
70403 ID=I
70404 130 IM=MOD(K(ID,3),MSTU(5))
70405 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
70406 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
70407 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
70408 ID=IM
70409 GOTO 130
70410 ENDIF
70411 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
70412 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
70413 & K(IM,2).EQ.94) THEN
70414 ID=IM
70415 GOTO 130
70416 ENDIF
70417 ENDIF
70418 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
70419 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
70420 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
70421 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
70422 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
70423 & K(K(I,4),3)/MSTU(5)
70424 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
70425 & K(K(I,5),3)/MSTU(5)
70426 ELSE
70427 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
70428 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
70429 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
70430 KCD=MOD(K(I,4),MSTU(5))
70431 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70432 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70433 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
70434 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
70435 KCD=MOD(K(I,5),MSTU(5))
70436 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70437 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70438 ENDIF
70439 140 CONTINUE
70440
70441C...Pack remaining entries.
70442 I1=0
70443 MSTU90=MSTU(90)
70444 MSTU(90)=0
70445 DO 170 I=1,N
70446 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
70447 I1=I1+1
70448 DO 150 J=1,5
70449 K(I1,J)=K(I,J)
70450 P(I1,J)=P(I,J)
70451 V(I1,J)=V(I,J)
70452 150 CONTINUE
70453C...Also update LHA1 colour tags
70454 MCT(I1,1)=MCT(I,1)
70455 MCT(I1,2)=MCT(I,2)
70456 K(I1,3)=MOD(K(I1,3),MSTU(5))
70457 DO 160 IZ=1,MSTU90
70458 IF(I.EQ.MSTU(90+IZ)) THEN
70459 MSTU(90)=MSTU(90)+1
70460 MSTU(90+MSTU(90))=I1
70461 PARU(90+MSTU(90))=PARU(90+IZ)
70462 ENDIF
70463 160 CONTINUE
70464 170 CONTINUE
70465 IF(I1.LT.N) MSTU(3)=0
70466 IF(I1.LT.N) MSTU(70)=0
70467 N=I1
70468
70469C...Fill in some missing daughter pointers (lost in colour flow).
70470 ELSEIF(MEDIT.EQ.16) THEN
70471 DO 220 I=1,N
70472 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
70473 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
70474C...Find daughters who point to mother.
70475 DO 180 I1=I+1,N
70476 IF(K(I1,3).NE.I) THEN
70477 ELSEIF(K(I,4).EQ.0) THEN
70478 K(I,4)=I1
70479 ELSE
70480 K(I,5)=I1
70481 ENDIF
70482 180 CONTINUE
70483 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70484 IF(K(I,4).NE.0) GOTO 220
70485C...Find daughters who point to documentation version of mother.
70486 IM=K(I,3)
70487 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
70488 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
70489 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
70490 DO 190 I1=I+1,N
70491 IF(K(I1,3).NE.IM) THEN
70492 ELSEIF(K(I,4).EQ.0) THEN
70493 K(I,4)=I1
70494 ELSE
70495 K(I,5)=I1
70496 ENDIF
70497 190 CONTINUE
70498 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70499 IF(K(I,4).NE.0) GOTO 220
70500C...Find daughters who point to documentation daughters who,
70501C...in their turn, point to documentation mother.
70502 ID1=IM
70503 ID2=IM
70504 DO 200 I1=IM+1,I-1
70505 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
70506 ID2=I1
70507 IF(ID1.EQ.IM) ID1=I1
70508 ENDIF
70509 200 CONTINUE
70510 DO 210 I1=I+1,N
70511 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
70512 ELSEIF(K(I,4).EQ.0) THEN
70513 K(I,4)=I1
70514 ELSE
70515 K(I,5)=I1
70516 ENDIF
70517 210 CONTINUE
70518 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70519 220 CONTINUE
70520
70521C...Save top entries at bottom of PYJETS commonblock.
70522 ELSEIF(MEDIT.EQ.21) THEN
70523 IF(2*N.GE.MSTU(4)) THEN
70524 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
70525 RETURN
70526 ENDIF
70527 DO 240 I=1,N
70528 DO 230 J=1,5
70529 K(MSTU(4)-I,J)=K(I,J)
70530 P(MSTU(4)-I,J)=P(I,J)
70531 V(MSTU(4)-I,J)=V(I,J)
70532 230 CONTINUE
70533 240 CONTINUE
70534 MSTU(32)=N
70535
70536C...Restore bottom entries of commonblock PYJETS to top.
70537 ELSEIF(MEDIT.EQ.22) THEN
70538 DO 260 I=1,MSTU(32)
70539 DO 250 J=1,5
70540 K(I,J)=K(MSTU(4)-I,J)
70541 P(I,J)=P(MSTU(4)-I,J)
70542 V(I,J)=V(MSTU(4)-I,J)
70543 250 CONTINUE
70544 260 CONTINUE
70545 N=MSTU(32)
70546
70547C...Mark primary entries at top of commonblock PYJETS as untreated.
70548 ELSEIF(MEDIT.EQ.23) THEN
70549 I1=0
70550 DO 270 I=1,N
70551 KH=K(I,3)
70552 IF(KH.GE.1) THEN
70553 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
70554 ENDIF
70555 IF(KH.NE.0) GOTO 280
70556 I1=I1+1
70557 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
70558 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
70559 270 CONTINUE
70560 280 N=I1
70561
70562C...Place largest axis along z axis and second largest in xy plane.
70563 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
70564 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
70565 & P(MSTU(61),2)),0D0,0D0,0D0)
70566 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
70567 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
70568 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
70569 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
70570 IF(MEDIT.EQ.31) RETURN
70571
70572C...Rotate to put slim jet along +z axis.
70573 DO 290 IS=1,2
70574 NS(IS)=0
70575 PTS(IS)=0D0
70576 PLS(IS)=0D0
70577 290 CONTINUE
70578 DO 300 I=1,N
70579 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
70580 IF(MSTU(41).GE.2) THEN
70581 KC=PYCOMP(K(I,2))
70582 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70583 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70584 & K(I,2).EQ.KSUSY1+39) GOTO 300
70585 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70586 & .EQ.0) GOTO 300
70587 ENDIF
70588 IS=2D0-SIGN(0.5D0,P(I,3))
70589 NS(IS)=NS(IS)+1
70590 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
70591 300 CONTINUE
70592 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
70593 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
70594
70595C...Rotate to put second largest jet into -z,+x quadrant.
70596 DO 310 I=1,N
70597 IF(P(I,3).GE.0D0) GOTO 310
70598 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
70599 IF(MSTU(41).GE.2) THEN
70600 KC=PYCOMP(K(I,2))
70601 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70602 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70603 & K(I,2).EQ.KSUSY1+39) GOTO 310
70604 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70605 & .EQ.0) GOTO 310
70606 ENDIF
70607 IS=2D0-SIGN(0.5D0,P(I,1))
70608 PLS(IS)=PLS(IS)-P(I,3)
70609 310 CONTINUE
70610 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
70611 & 0D0,0D0,0D0)
70612 ENDIF
70613
70614 RETURN
70615 END
70616
70617C*********************************************************************
70618
70619C...PYLIST
70620C...Gives program heading, or lists an event, or particle
70621C...data, or current parameter values.
70622
70623 SUBROUTINE PYLIST(MLIST)
70624
70625C...Double precision and integer declarations.
70626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70627 IMPLICIT INTEGER(I-N)
70628 INTEGER PYK,PYCHGE,PYCOMP
70629C...Parameter statement to help give large particle numbers.
70630 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70631 &KEXCIT=4000000,KDIMEN=5000000)
70632
70633C...HEPEVT commonblock.
70634 PARAMETER (NMXHEP=4000)
70635 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
70636 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
70637 DOUBLE PRECISION PHEP,VHEP
70638 SAVE /HEPEVT/
70639
70640C...User process event common block.
70641 INTEGER MAXNUP
70642 PARAMETER (MAXNUP=500)
70643 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
70644 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
70645 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
70646 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
70647 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
70648 SAVE /HEPEUP/
70649
70650C...Commonblocks.
70651 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70652 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70653 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70654 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
70655 COMMON/PYCTAG/NCT,MCT(4000,2)
70656 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
70657C...Local arrays, character variables and data.
70658 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
70659 DIMENSION PS(6)
70660 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
70661
70662C...Initialization printout: version number and date of last change.
70663 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
70664 CALL PYLOGO
70665 MSTU(12)=12345
70666 IF(MLIST.EQ.0) RETURN
70667 ENDIF
70668
70669C...List event data, including additional lines after N.
70670 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
70671 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
70672 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
70673 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
70674 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
70675 LMX=12
70676 IF(MLIST.GE.2) LMX=16
70677 ISTR=0
70678 IMAX=N
70679 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70680 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
70681 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
70682 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
70683 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
70684
70685C...Get particle name, pad it and check it is not too long.
70686 CALL PYNAME(K(I,2),CHAP)
70687 LEN=0
70688 DO 100 LEM=1,16
70689 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
70690 100 CONTINUE
70691 MDL=(K(I,1)+19)/10
70692 LDL=0
70693 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
70694 CHAC=CHAP
70695 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
70696 ELSE
70697 LDL=1
70698 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
70699 IF(LEN.EQ.0) THEN
70700 CHAC=CHDL(MDL)(1:2*LDL)//' '
70701 ELSE
70702 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
70703 & CHDL(MDL)(LDL+1:2*LDL)//' '
70704 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
70705 ENDIF
70706 ENDIF
70707
70708C...Add information on string connection.
70709 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
70710 & THEN
70711 KC=PYCOMP(K(I,2))
70712 KCC=0
70713 IF(KC.NE.0) KCC=KCHG(KC,2)
70714 IF(IABS(K(I,2)).EQ.39) THEN
70715 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
70716 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
70717 ISTR=1
70718 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
70719 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
70720 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
70721 ELSEIF(KCC.NE.0) THEN
70722 ISTR=0
70723 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
70724 ENDIF
70725 ENDIF
70726 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
70727 & CHAC(LMX-1:LMX-1)='I'
70728
70729C...Write data for particle/jet.
70730 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
70731 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
70732 & (P(I,J2),J2=1,5)
70733 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
70734 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
70735 & (P(I,J2),J2=1,5)
70736 ELSEIF(MLIST.EQ.1) THEN
70737 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
70738 & (P(I,J2),J2=1,5)
70739 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
70740 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
70741 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
70742 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70743 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
70744 & (P(I,J2),J2=1,5)
70745 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
70746 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70747 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
70748 & ,10000),MCT(I,1),MCT(I,2)
70749 ELSE
70750 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
70751 & (P(I,J2),J2=1,5)
70752 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
70753 & ,MCT(I,1),MCT(I,2)
70754 ENDIF
70755 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
70756
70757C...Insert extra separator lines specified by user.
70758 IF(MSTU(70).GE.1) THEN
70759 ISEP=0
70760 DO 110 J=1,MIN(10,MSTU(70))
70761 IF(I.EQ.MSTU(70+J)) ISEP=1
70762 110 CONTINUE
70763 IF(ISEP.EQ.1) THEN
70764 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
70765 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
70766 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
70767 ENDIF
70768 ENDIF
70769 120 CONTINUE
70770
70771C...Sum of charges and momenta.
70772 DO 130 J=1,6
70773 PS(J)=PYP(0,J)
70774 130 CONTINUE
70775 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
70776 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
70777 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
70778 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
70779 ELSEIF(MLIST.EQ.1) THEN
70780 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
70781 ELSEIF(MLIST.LE.3) THEN
70782 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
70783 ELSE
70784 WRITE(MSTU(11),7000) PS(6)
70785 ENDIF
70786
70787C...Simple listing of HEPEVT entries (mainly for test purposes).
70788 ELSEIF(MLIST.EQ.5) THEN
70789 WRITE(MSTU(11),7100)
70790 DO 140 I=1,NHEP
70791 IF(ISTHEP(I).EQ.0) GOTO 140
70792 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
70793 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
70794 140 CONTINUE
70795
70796
70797C...Simple listing of user-process entries (mainly for test purposes).
70798 ELSEIF(MLIST.EQ.7) THEN
70799 WRITE(MSTU(11),7300)
70800 DO 150 I=1,NUP
70801 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
70802 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
70803 150 CONTINUE
70804
70805C...Give simple list of KF codes defined in program.
70806 ELSEIF(MLIST.EQ.11) THEN
70807 WRITE(MSTU(11),7500)
70808 DO 160 KF=1,80
70809 CALL PYNAME(KF,CHAP)
70810 CALL PYNAME(-KF,CHAN)
70811 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70812 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70813 160 CONTINUE
70814 DO 190 KFLS=1,3,2
70815 DO 180 KFLA=1,5
70816 DO 170 KFLB=1,KFLA-(3-KFLS)/2
70817 KF=1000*KFLA+100*KFLB+KFLS
70818 CALL PYNAME(KF,CHAP)
70819 CALL PYNAME(-KF,CHAN)
70820 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70821 170 CONTINUE
70822 180 CONTINUE
70823 190 CONTINUE
70824 DO 220 KMUL=0,5
70825 KFLS=3
70826 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
70827 IF(KMUL.EQ.5) KFLS=5
70828 KFLR=0
70829 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
70830 IF(KMUL.EQ.4) KFLR=2
70831 DO 210 KFLB=1,5
70832 DO 200 KFLC=1,KFLB-1
70833 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
70834 CALL PYNAME(KF,CHAP)
70835 CALL PYNAME(-KF,CHAN)
70836 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70837 IF(KF.EQ.311) THEN
70838 KFK=130
70839 CALL PYNAME(KFK,CHAP)
70840 WRITE(MSTU(11),7600) KFK,CHAP
70841 KFK=310
70842 CALL PYNAME(KFK,CHAP)
70843 WRITE(MSTU(11),7600) KFK,CHAP
70844 ENDIF
70845 200 CONTINUE
70846 KF=10000*KFLR+110*KFLB+KFLS
70847 CALL PYNAME(KF,CHAP)
70848 WRITE(MSTU(11),7600) KF,CHAP
70849 210 CONTINUE
70850 220 CONTINUE
70851 KF=100443
70852 CALL PYNAME(KF,CHAP)
70853 WRITE(MSTU(11),7600) KF,CHAP
70854 KF=100553
70855 CALL PYNAME(KF,CHAP)
70856 WRITE(MSTU(11),7600) KF,CHAP
70857 DO 260 KFLSP=1,3
70858 KFLS=2+2*(KFLSP/3)
70859 DO 250 KFLA=1,5
70860 DO 240 KFLB=1,KFLA
70861 DO 230 KFLC=1,KFLB
70862 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
70863 & GOTO 230
70864 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
70865 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
70866 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
70867 CALL PYNAME(KF,CHAP)
70868 CALL PYNAME(-KF,CHAN)
70869 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70870 230 CONTINUE
70871 240 CONTINUE
70872 250 CONTINUE
70873 260 CONTINUE
70874 DO 270 KC=1,500
70875 KF=KCHG(KC,4)
70876 IF(KF.LT.1000000) GOTO 270
70877 CALL PYNAME(KF,CHAP)
70878 CALL PYNAME(-KF,CHAN)
70879 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70880 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70881 270 CONTINUE
70882
70883C...List parton/particle data table. Check whether to be listed.
70884 ELSEIF(MLIST.EQ.12) THEN
70885 WRITE(MSTU(11),7700)
70886 DO 300 KC=1,MSTU(6)
70887 KF=KCHG(KC,4)
70888 IF(KF.EQ.0) GOTO 300
70889 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
70890 & GOTO 300
70891
70892C...Find particle name and mass. Print information.
70893 CALL PYNAME(KF,CHAP)
70894 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
70895 CALL PYNAME(-KF,CHAN)
70896 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
70897 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
70898
70899C...Particle decay: channel number, branching ratios, matrix element,
70900C...decay products.
70901 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
70902 DO 280 J=1,5
70903 CALL PYNAME(KFDP(IDC,J),CHAD(J))
70904 280 CONTINUE
70905 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
70906 & (CHAD(J),J=1,5)
70907 290 CONTINUE
70908 300 CONTINUE
70909
70910C...List parameter value table.
70911 ELSEIF(MLIST.EQ.13) THEN
70912 WRITE(MSTU(11),8000)
70913 DO 310 I=1,200
70914 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
70915 310 CONTINUE
70916 ENDIF
70917
70918C...Format statements for output on unit MSTU(11) (by default 6).
70919 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
70920 &5X,'KF orig p_x p_y p_z E m'/)
70921 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
70922 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70923 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
70924 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
70925 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70926 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
70927 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
70928 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
70929 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
70930 & ,' C tag AC tag'/)
70931 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
70932 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
70933 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
70934 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
70935 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
70936 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
70937 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
70938 6200 FORMAT(66X,5(1X,F12.3))
70939 6300 FORMAT(1X,78('='))
70940 6400 FORMAT(1X,130('='))
70941 6500 FORMAT(1X,65('='))
70942 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
70943 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
70944 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
70945 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
70946 &5F13.5)
70947 7000 FORMAT(19X,'sum charge:',F6.2)
70948 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
70949 &//' I IST ID Mothers Daughters p_x p_y p_z',
70950 &' E m')
70951 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
70952 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
70953 &//' I IST ID Mothers Colours p_x p_y p_z',
70954 &' E m')
70955 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
70956 7500 FORMAT(///20X,'List of KF codes in program'/)
70957 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
70958 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
70959 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
70960 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
70961 &1X,'ME',3X,'Br.rat.',4X,'decay products')
70962 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
70963 &1X,1P,E13.5,3X,I2)
70964 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
70965 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
70966 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
70967 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
70968
70969 RETURN
70970 END
70971
70972C*********************************************************************
70973
70974C...PYLOGO
70975C...Writes a logo for the program.
70976
70977 SUBROUTINE PYLOGO
70978
70979C...Double precision and integer declarations.
70980 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70981 IMPLICIT INTEGER(I-N)
70982 INTEGER PYK,PYCHGE,PYCOMP
70983C...Parameter for length of information block.
70984 PARAMETER (IREFER=21)
70985C...Commonblocks.
70986 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70987 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
70988 SAVE /PYDAT1/,/PYPARS/
70989C...Local arrays and character variables.
70990 INTEGER IDATI(6)
70991 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
70992 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
70993
70994C...Data on months, logo, titles, and references.
70995 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
70996 &'Oct','Nov','Dec'/
70997 DATA (LOGO(J),J=1,19)/
70998 &' *......* ',
70999 &' *:::!!:::::::::::* ',
71000 &' *::::::!!::::::::::::::* ',
71001 &' *::::::::!!::::::::::::::::* ',
71002 &' *:::::::::!!:::::::::::::::::* ',
71003 &' *:::::::::!!:::::::::::::::::* ',
71004 &' *::::::::!!::::::::::::::::*! ',
71005 &' *::::::!!::::::::::::::* !! ',
71006 &' !! *:::!!:::::::::::* !! ',
71007 &' !! !* -><- * !! ',
71008 &' !! !! !! ',
71009 &' !! !! !! ',
71010 &' !! !! ',
71011 &' !! lh !! ',
71012 &' !! !! ',
71013 &' !! hh !! ',
71014 &' !! ll !! ',
71015 &' !! !! ',
71016 &' !! '/
71017 DATA (LOGO(J),J=20,38)/
71018 &'Welcome to the Lund Monte Carlo!',
71019 &' ',
71020 &'PPP Y Y TTTTT H H III A ',
71021 &'P P Y Y T H H I A A ',
71022 &'PPP Y T HHHHH I AAAAA',
71023 &'P Y T H H I A A',
71024 &'P Y T H H III A A',
71025 &' ',
71026 &'This is PYTHIA version x.xxx ',
71027 &'Last date of change: xx xxx 200x',
71028 &' ',
71029 &'Now is xx xxx 200x at xx:xx:xx ',
71030 &' ',
71031 &'Disclaimer: this program comes ',
71032 &'without any guarantees. Beware ',
71033 &'of errors and use common sense ',
71034 &'when interpreting results. ',
71035 &' ',
71036 &'Copyright T. Sjostrand (2007) '/
71037 DATA (REFER(J),J=1,14)/
71038 &'An archive of program versions and d',
71039 &'ocumentation is found on the web: ',
71040 &'http://www.thep.lu.se/~torbjorn/Pyth',
71041 &'ia.html ',
71042 &' ',
71043 &' ',
71044 &'When you cite this program, the offi',
71045 &'cial reference is to the 6.4 manual:',
71046 &'T. Sjostrand, S. Mrenna and P. Skand',
71047 &'s, JHEP05 (2006) 026 ',
71048 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
71049 &'-T) [hep-ph/0603175]. ',
71050 &' ',
71051 &' '/
71052 DATA (REFER(J),J=15,32)/
71053 &'Also remember that the program, to a',
71054 &' large extent, represents original ',
71055 &'physics research. Other publications',
71056 &' of special relevance to your ',
71057 &'studies may therefore deserve separa',
71058 &'te mention. ',
71059 &' ',
71060 &' ',
71061 &'Main author: Torbjorn Sjostrand; CER',
71062 &'N/PH, CH-1211 Geneva, Switzerland, ',
71063 &' and Department of Theoretical Phys',
71064 &'ics, Lund University, Lund, Sweden; ',
71065 &' phone: + 41 - 22 - 767 82 27; e-ma',
71066 &'il: torbjorn@thep.lu.se ',
71067 &'Author: Stephen Mrenna; Computing Di',
71068 &'vision, GDS Group, ',
71069 &' Fermi National Accelerator Laborat',
71070 &'ory, MS 234, Batavia, IL 60510, USA;'/
71071 DATA (REFER(J),J=33,2*IREFER)/
71072 &' phone: + 1 - 630 - 840 - 2556; e-m',
71073 &'ail: mrenna@fnal.gov ',
71074 &'Author: Peter Skands; Theoretical Ph',
71075 &'ysics Department, ',
71076 &' Fermi National Accelerator Laborat',
71077 &'ory, MS 106, Batavia, IL 60510, USA;',
71078 &' and CERN/PH, CH-1211 Geneva, Switz',
71079 &'erland; ',
71080 &' phone: + 41 - 22 - 767 24 59; e-ma',
71081 &'il: skands@fnal.gov '/
71082
71083C...Check that PYDATA linked.
71084 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
71085 WRITE(*,'(1X,A)')
71086 & 'Error: PYDATA has not been linked.'
71087 WRITE(*,'(1X,A)') 'Execution stopped!'
71088 CALL PYSTOP(8)
71089
71090C...Write current version number and current date+time.
71091 ELSE
71092 WRITE(VERS,'(I1)') MSTP(181)
71093 LOGO(28)(24:24)=VERS
71094 WRITE(SUBV,'(I3)') MSTP(182)
71095 LOGO(28)(26:28)=SUBV
71096 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
71097 WRITE(DATE,'(I2)') MSTP(185)
71098 LOGO(29)(22:23)=DATE
71099 LOGO(29)(25:27)=MONTH(MSTP(184))
71100 WRITE(YEAR,'(I4)') MSTP(183)
71101 LOGO(29)(29:32)=YEAR
71102 CALL PYTIME(IDATI)
71103 IF(IDATI(1).LE.0) THEN
71104 LOGO(31)=' '
71105 ELSE
71106 WRITE(DATE,'(I2)') IDATI(3)
71107 LOGO(31)(8:9)=DATE
71108 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
71109 WRITE(YEAR,'(I4)') IDATI(1)
71110 LOGO(31)(15:18)=YEAR
71111 WRITE(HOUR,'(I2)') IDATI(4)
71112 LOGO(31)(23:24)=HOUR
71113 WRITE(MINU,'(I2)') IDATI(5)
71114 LOGO(31)(26:27)=MINU
71115 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
71116 WRITE(SECO,'(I2)') IDATI(6)
71117 LOGO(31)(29:30)=SECO
71118 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
71119 ENDIF
71120 ENDIF
71121
71122C...Loop over lines in header. Define page feed and side borders.
71123 DO 100 ILIN=1,29+IREFER
71124 LINE=' '
71125 IF(ILIN.EQ.1) THEN
71126 LINE(1:1)='1'
71127 ELSE
71128 LINE(2:3)='**'
71129 LINE(78:79)='**'
71130 ENDIF
71131
71132C...Separator lines and logos.
71133 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
71134 LINE(4:77)='***********************************************'//
71135 & '***************************'
71136 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
71137 LINE(6:37)=LOGO(ILIN-5)
71138 LINE(44:75)=LOGO(ILIN+14)
71139 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
71140 LINE(5:40)=REFER(2*ILIN-51)
71141 LINE(41:76)=REFER(2*ILIN-50)
71142 ENDIF
71143
71144C...Write lines to appropriate unit.
71145 WRITE(MSTU(11),'(A79)') LINE
71146 100 CONTINUE
71147
71148 RETURN
71149 END
71150
71151C*********************************************************************
71152
71153C...PYUPDA
71154C...Facilitates the updating of particle and decay data
71155C...by allowing it to be done in an external file.
71156
71157 SUBROUTINE PYUPDA(MUPDA,LFN)
71158
71159C...Double precision and integer declarations.
71160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71161 IMPLICIT INTEGER(I-N)
71162 INTEGER PYK,PYCHGE,PYCOMP
71163C...Commonblocks.
71164 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71165 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71166 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71167 COMMON/PYDAT4/CHAF(500,2)
71168 CHARACTER CHAF*16
71169 COMMON/PYINT4/MWID(500),WIDS(500,5)
71170 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
71171C...Local arrays, character variables and data.
71172 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
71173 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
71174 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
71175 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
71176 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
71177 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
71178 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
71179
71180C...Write header if not yet done.
71181 IF(MSTU(12).NE.12345) CALL PYLIST(0)
71182
71183C...Write information on file for editing.
71184 IF(MUPDA.EQ.1) THEN
71185 DO 110 KC=1,500
71186 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71187 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71188 & MWID(KC),MDCY(KC,1)
71189 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71190 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
71191 & (KFDP(IDC,J),J=1,5)
71192 100 CONTINUE
71193 110 CONTINUE
71194
71195C...Read complete set of information from edited file or
71196C...read partial set of new or updated information from edited file.
71197 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
71198
71199C...Reset counters.
71200 KCC=100
71201 NDC=0
71202 CHKF=' '
71203 IF(MUPDA.EQ.2) THEN
71204 DO 120 I=1,MSTU(6)
71205 KCHG(I,4)=0
71206 120 CONTINUE
71207 ELSE
71208 DO 130 KC=1,MSTU(6)
71209 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
71210 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
71211 130 CONTINUE
71212 ENDIF
71213
71214C...Begin of loop: read new line; unknown whether particle or
71215C...decay data.
71216 140 READ(LFN,5200,END=190) CHINL
71217
71218C...Identify particle code and whether already defined (for MUPDA=3).
71219 IF(CHINL(2:10).NE.' ') THEN
71220 CHKF=CHINL(2:10)
71221 READ(CHKF,5300) KF
71222 IF(MUPDA.EQ.2) THEN
71223 IF(KF.LE.100) THEN
71224 KC=KF
71225 ELSE
71226 KCC=KCC+1
71227 KC=KCC
71228 ENDIF
71229 ELSE
71230 KCREP=0
71231 IF(KF.LE.100) THEN
71232 KCREP=KF
71233 ELSE
71234 DO 150 KCR=101,KCC
71235 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
71236 150 CONTINUE
71237 ENDIF
71238C...Remove duplicate old decay data.
71239 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
71240 IDCREP=MDCY(KCREP,2)
71241 NDCREP=MDCY(KCREP,3)
71242 DO 160 I=1,KCC
71243 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
71244 160 CONTINUE
71245 DO 180 I=IDCREP,NDC-NDCREP
71246 MDME(I,1)=MDME(I+NDCREP,1)
71247 MDME(I,2)=MDME(I+NDCREP,2)
71248 BRAT(I)=BRAT(I+NDCREP)
71249 DO 170 J=1,5
71250 KFDP(I,J)=KFDP(I+NDCREP,J)
71251 170 CONTINUE
71252 180 CONTINUE
71253 NDC=NDC-NDCREP
71254 KC=KCREP
71255 ELSEIF(KCREP.NE.0) THEN
71256 KC=KCREP
71257 ELSE
71258 KCC=KCC+1
71259 KC=KCC
71260 ENDIF
71261 ENDIF
71262
71263C...Study line with particle data.
71264 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
71265 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
71266 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71267 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71268 & MWID(KC),MDCY(KC,1)
71269 MDCY(KC,2)=0
71270 MDCY(KC,3)=0
71271
71272C...Study line with decay data.
71273 ELSE
71274 NDC=NDC+1
71275 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
71276 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
71277 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
71278 MDCY(KC,3)=MDCY(KC,3)+1
71279 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
71280 & (KFDP(NDC,J),J=1,5)
71281 ENDIF
71282
71283C...End of loop; ensure that PYCOMP tables are updated.
71284 GOTO 140
71285 190 CONTINUE
71286 MSTU(20)=0
71287
71288C...Perform possible tests that new information is consistent.
71289 DO 220 KC=1,MSTU(6)
71290 KF=KCHG(KC,4)
71291 IF(KF.EQ.0) GOTO 220
71292 WRITE(CHKF,5300) KF
71293 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
71294 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
71295 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
71296 BRSUM=0D0
71297 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71298 IF(MDME(IDC,2).GT.80) GOTO 210
71299 KQ=KCHG(KC,1)
71300 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
71301 MERR=0
71302 DO 200 J=1,5
71303 KP=KFDP(IDC,J)
71304 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
71305 IF(KP.EQ.81) KQ=0
71306 ELSEIF(PYCOMP(KP).EQ.0) THEN
71307 MERR=3
71308 ELSE
71309 KQ=KQ-PYCHGE(KP)
71310 KPC=PYCOMP(KP)
71311 PMS=PMS-PMAS(KPC,1)
71312 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
71313 & PMAS(KPC,3))
71314 ENDIF
71315 200 CONTINUE
71316 IF(KQ.NE.0) MERR=MAX(2,MERR)
71317 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
71318 & MERR=MAX(1,MERR)
71319 IF(MERR.EQ.3) CALL PYERRM(17,
71320 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
71321 IF(MERR.EQ.2) CALL PYERRM(17,
71322 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
71323 IF(MERR.EQ.1) CALL PYERRM(7,
71324 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
71325 BRSUM=BRSUM+BRAT(IDC)
71326 210 CONTINUE
71327 WRITE(CHTMP,5500) BRSUM
71328 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
71329 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
71330 & CHTMP(9:16)//' for KF ='//CHKF)
71331 220 CONTINUE
71332
71333C...Write DATA statements for inclusion in program.
71334 ELSEIF(MUPDA.EQ.4) THEN
71335
71336C...Find out how many codes and decay channels are actually used.
71337 KCC=0
71338 NDC=0
71339 DO 230 I=1,MSTU(6)
71340 IF(KCHG(I,4).NE.0) THEN
71341 KCC=I
71342 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
71343 ENDIF
71344 230 CONTINUE
71345
71346C...Initialize writing of DATA statements for inclusion in program.
71347 DO 300 IVAR=1,22
71348 NDIM=MSTU(6)
71349 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
71350 NLIN=1
71351 CHLIN=' '
71352 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
71353 LLIN=35
71354 CHOLD='START'
71355
71356C...Loop through variables for conversion to characters.
71357 DO 280 IDIM=1,NDIM
71358 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
71359 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
71360 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
71361 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
71362 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
71363 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
71364 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
71365 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
71366 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
71367 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
71368 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
71369 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
71370 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
71371 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
71372 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
71373 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
71374 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
71375 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
71376 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
71377 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
71378 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
71379 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
71380
71381C...Replace variables beyond what is properly defined.
71382 IF(IVAR.LE.4) THEN
71383 IF(IDIM.GT.KCC) CHTMP=' 0'
71384 ELSEIF(IVAR.LE.8) THEN
71385 IF(IDIM.GT.KCC) CHTMP=' 0.0'
71386 ELSEIF(IVAR.LE.11) THEN
71387 IF(IDIM.GT.KCC) CHTMP=' 0'
71388 ELSEIF(IVAR.LE.13) THEN
71389 IF(IDIM.GT.NDC) CHTMP=' 0'
71390 ELSEIF(IVAR.LE.14) THEN
71391 IF(IDIM.GT.NDC) CHTMP=' 0.0'
71392 ELSEIF(IVAR.LE.19) THEN
71393 IF(IDIM.GT.NDC) CHTMP=' 0'
71394 ELSEIF(IVAR.LE.21) THEN
71395 IF(IDIM.GT.KCC) CHTMP=' '
71396 ELSE
71397 IF(IDIM.GT.KCC) CHTMP=' 0'
71398 ENDIF
71399
71400C...Length of variable, trailing decimal zeros, quotation marks.
71401 LLOW=1
71402 LHIG=1
71403 DO 240 LL=1,16
71404 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
71405 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
71406 240 CONTINUE
71407 CHNEW=CHTMP(LLOW:LHIG)//' '
71408 LNEW=1+LHIG-LLOW
71409 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
71410 LNEW=LNEW+1
71411 250 LNEW=LNEW-1
71412 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
71413 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
71414 IF(LNEW.EQ.0) THEN
71415 CHNEW(1:3)='0D0'
71416 LNEW=3
71417 ELSE
71418 CHNEW(LNEW+1:LNEW+2)='D0'
71419 LNEW=LNEW+2
71420 ENDIF
71421 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
71422 DO 260 LL=LNEW,1,-1
71423 IF(CHNEW(LL:LL).EQ.'''') THEN
71424 CHTMP=CHNEW
71425 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
71426 LNEW=LNEW+1
71427 ENDIF
71428 260 CONTINUE
71429 LNEW=MIN(14,LNEW)
71430 CHTMP=CHNEW
71431 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
71432 LNEW=LNEW+2
71433 ENDIF
71434
71435C...Form composite character string, often including repetition counter.
71436 IF(CHNEW.NE.CHOLD) THEN
71437 NRPT=1
71438 CHOLD=CHNEW
71439 CHCOM=CHNEW
71440 LCOM=LNEW
71441 ELSE
71442 LRPT=LNEW+1
71443 IF(NRPT.GE.2) LRPT=LNEW+3
71444 IF(NRPT.GE.10) LRPT=LNEW+4
71445 IF(NRPT.GE.100) LRPT=LNEW+5
71446 IF(NRPT.GE.1000) LRPT=LNEW+6
71447 LLIN=LLIN-LRPT
71448 NRPT=NRPT+1
71449 WRITE(CHTMP,5400) NRPT
71450 LRPT=1
71451 IF(NRPT.GE.10) LRPT=2
71452 IF(NRPT.GE.100) LRPT=3
71453 IF(NRPT.GE.1000) LRPT=4
71454 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
71455 LCOM=LRPT+1+LNEW
71456 ENDIF
71457
71458C...Add characters to end of line, to new line (after storing old line),
71459C...or to new block of lines (after writing old block).
71460 IF(LLIN+LCOM.LE.70) THEN
71461 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
71462 LLIN=LLIN+LCOM+1
71463 ELSEIF(NLIN.LE.19) THEN
71464 CHLIN(LLIN+1:72)=' '
71465 CHBLK(NLIN)=CHLIN
71466 NLIN=NLIN+1
71467 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
71468 LLIN=6+LCOM+1
71469 ELSE
71470 CHLIN(LLIN:72)='/'//' '
71471 CHBLK(NLIN)=CHLIN
71472 WRITE(CHTMP,5400) IDIM-NRPT
71473 CHBLK(1)(30:33)=CHTMP(13:16)
71474 DO 270 ILIN=1,NLIN
71475 WRITE(LFN,5700) CHBLK(ILIN)
71476 270 CONTINUE
71477 NLIN=1
71478 CHLIN=' '
71479 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
71480 & ',I= , )/'//CHCOM(1:LCOM)//','
71481 WRITE(CHTMP,5400) IDIM-NRPT+1
71482 CHLIN(25:28)=CHTMP(13:16)
71483 LLIN=35+LCOM+1
71484 ENDIF
71485 280 CONTINUE
71486
71487C...Write final block of lines.
71488 CHLIN(LLIN:72)='/'//' '
71489 CHBLK(NLIN)=CHLIN
71490 WRITE(CHTMP,5400) NDIM
71491 CHBLK(1)(30:33)=CHTMP(13:16)
71492 DO 290 ILIN=1,NLIN
71493 WRITE(LFN,5700) CHBLK(ILIN)
71494 290 CONTINUE
71495 300 CONTINUE
71496 ENDIF
71497
71498C...Formats for reading and writing particle data.
71499 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
71500 5100 FORMAT(10X,2I5,F12.6,5I10)
71501 5200 FORMAT(A120)
71502 5300 FORMAT(I9)
71503 5400 FORMAT(I16)
71504 5500 FORMAT(F16.5)
71505 5600 FORMAT(F16.6)
71506 5700 FORMAT(A72)
71507
71508 RETURN
71509 END
71510
71511C*********************************************************************
71512
71513C...PYK
71514C...Provides various integer-valued event related data.
71515
71516 FUNCTION PYK(I,J)
71517
71518C...Double precision and integer declarations.
71519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71520 IMPLICIT INTEGER(I-N)
71521 INTEGER PYK,PYCHGE,PYCOMP
71522C...Commonblocks.
71523 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71524 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71525 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71526 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71527
71528C...Default value. For I=0 number of entries, number of stable entries
71529C...or 3 times total charge.
71530 PYK=0
71531 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71532 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
71533 PYK=N
71534 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
71535 DO 100 I1=1,N
71536 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
71537 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
71538 & PYCHGE(K(I1,2))
71539 100 CONTINUE
71540 ELSEIF(I.EQ.0) THEN
71541
71542C...For I > 0 direct readout of K matrix or charge.
71543 ELSEIF(J.LE.5) THEN
71544 PYK=K(I,J)
71545 ELSEIF(J.EQ.6) THEN
71546 PYK=PYCHGE(K(I,2))
71547
71548C...Status (existing/fragmented/decayed), parton/hadron separation.
71549 ELSEIF(J.LE.8) THEN
71550 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
71551 IF(J.EQ.8) PYK=PYK*K(I,2)
71552 ELSEIF(J.LE.12) THEN
71553 KFA=IABS(K(I,2))
71554 KC=PYCOMP(KFA)
71555 KQ=0
71556 IF(KC.NE.0) KQ=KCHG(KC,2)
71557 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
71558 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
71559 IF(J.EQ.11) PYK=KC
71560 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
71561
71562C...Heaviest flavour in hadron/diquark.
71563 ELSEIF(J.EQ.13) THEN
71564 KFA=IABS(K(I,2))
71565 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
71566 IF(KFA.LT.10) PYK=KFA
71567 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
71568 PYK=PYK*ISIGN(1,K(I,2))
71569
71570C...Particle history: generation, ancestor, rank.
71571 ELSEIF(J.LE.15) THEN
71572 I2=I
71573 I1=I
71574 110 PYK=PYK+1
71575 I2=I1
71576 I1=K(I1,3)
71577 IF(I1.GT.0) THEN
71578 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
71579 ENDIF
71580 IF(J.EQ.15) PYK=I2
71581 ELSEIF(J.EQ.16) THEN
71582 KFA=IABS(K(I,2))
71583 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
71584 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
71585 I1=I
71586 120 I2=I1
71587 I1=K(I1,3)
71588 IF(I1.GT.0) THEN
71589 KFAM=IABS(K(I1,2))
71590 ILP=1
71591 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
71592 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
71593 & ILP=0
71594 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
71595 IF(ILP.EQ.1) GOTO 120
71596 ENDIF
71597 IF(K(I1,1).EQ.12) THEN
71598 DO 130 I3=I1+1,I2
71599 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
71600 & .AND.K(I3,2).NE.93) PYK=PYK+1
71601 130 CONTINUE
71602 ELSE
71603 I3=I2
71604 140 PYK=PYK+1
71605 I3=I3+1
71606 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
71607 ENDIF
71608 ENDIF
71609
71610C...Particle coming from collapsing jet system or not.
71611 ELSEIF(J.EQ.17) THEN
71612 I1=I
71613 150 PYK=PYK+1
71614 I3=I1
71615 I1=K(I1,3)
71616 I0=MAX(1,I1)
71617 KC=PYCOMP(K(I0,2))
71618 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
71619 IF(PYK.EQ.1) PYK=-1
71620 IF(PYK.GT.1) PYK=0
71621 RETURN
71622 ENDIF
71623 IF(KCHG(KC,2).EQ.0) GOTO 150
71624 IF(K(I1,1).NE.12) PYK=0
71625 IF(K(I1,1).NE.12) RETURN
71626 I2=I1
71627 160 I2=I2+1
71628 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
71629 K3M=K(I3-1,3)
71630 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
71631 K3P=K(I3+1,3)
71632 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
71633
71634C...Number of decay products. Colour flow.
71635 ELSEIF(J.EQ.18) THEN
71636 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
71637 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
71638 ELSEIF(J.LE.22) THEN
71639 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
71640 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
71641 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
71642 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
71643 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
71644 ELSE
71645 ENDIF
71646
71647 RETURN
71648 END
71649
71650C*********************************************************************
71651
71652C...PYP
71653C...Provides various real-valued event related data.
71654
71655 FUNCTION PYP(I,J)
71656
71657C...Double precision and integer declarations.
71658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71659 IMPLICIT INTEGER(I-N)
71660 INTEGER PYK,PYCHGE,PYCOMP
71661C...Commonblocks.
71662 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71663 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71664 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71665 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71666C...Local array.
71667 DIMENSION PSUM(4)
71668
71669C...Set default value. For I = 0 sum of momenta or charges,
71670C...or invariant mass of system.
71671 PYP=0D0
71672 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71673 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
71674 DO 100 I1=1,N
71675 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
71676 100 CONTINUE
71677 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
71678 DO 120 J1=1,4
71679 PSUM(J1)=0D0
71680 DO 110 I1=1,N
71681 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
71682 & P(I1,J1)
71683 110 CONTINUE
71684 120 CONTINUE
71685 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71686 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
71687 DO 130 I1=1,N
71688 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
71689 130 CONTINUE
71690 ELSEIF(I.EQ.0) THEN
71691
71692C...Direct readout of P matrix.
71693 ELSEIF(J.LE.5) THEN
71694 PYP=P(I,J)
71695
71696C...Charge, total momentum, transverse momentum, transverse mass.
71697 ELSEIF(J.LE.12) THEN
71698 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
71699 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
71700 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
71701 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
71702 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
71703
71704C...Theta and phi angle in radians or degrees.
71705 ELSEIF(J.LE.16) THEN
71706 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
71707 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
71708 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
71709
71710C...True rapidity, rapidity with pion mass, pseudorapidity.
71711 ELSEIF(J.LE.19) THEN
71712 PMR=0D0
71713 IF(J.EQ.17) PMR=P(I,5)
71714 IF(J.EQ.18) PMR=PYMASS(211)
71715 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71716 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71717 & 1D20)),P(I,3))
71718
71719C...Energy and momentum fractions (only to be used in CM frame).
71720 ELSEIF(J.LE.25) THEN
71721 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
71722 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
71723 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
71724 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
71725 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
71726 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
71727 ENDIF
71728
71729 RETURN
71730 END
71731
71732C*********************************************************************
71733
71734C...PYSPHE
71735C...Performs sphericity tensor analysis to give sphericity,
71736C...aplanarity and the related event axes.
71737
71738 SUBROUTINE PYSPHE(SPH,APL)
71739
71740C...Double precision and integer declarations.
71741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71742 IMPLICIT INTEGER(I-N)
71743 INTEGER PYK,PYCHGE,PYCOMP
71744C...Parameter statement to help give large particle numbers.
71745 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71746 &KEXCIT=4000000,KDIMEN=5000000)
71747C...Commonblocks.
71748 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71749 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71750 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71751 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71752C...Local arrays.
71753 DIMENSION SM(3,3),SV(3,3)
71754
71755C...Calculate matrix to be diagonalized.
71756 NP=0
71757 DO 110 J1=1,3
71758 DO 100 J2=J1,3
71759 SM(J1,J2)=0D0
71760 100 CONTINUE
71761 110 CONTINUE
71762 PS=0D0
71763 DO 140 I=1,N
71764 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
71765 IF(MSTU(41).GE.2) THEN
71766 KC=PYCOMP(K(I,2))
71767 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71768 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71769 & K(I,2).EQ.KSUSY1+39) GOTO 140
71770 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71771 & GOTO 140
71772 ENDIF
71773 NP=NP+1
71774 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71775 PWT=1D0
71776 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
71777 & MAX(1D-10,PA)**(PARU(41)-2D0)
71778 DO 130 J1=1,3
71779 DO 120 J2=J1,3
71780 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
71781 120 CONTINUE
71782 130 CONTINUE
71783 PS=PS+PWT*PA**2
71784 140 CONTINUE
71785
71786C...Very low multiplicities (0 or 1) not considered.
71787 IF(NP.LE.1) THEN
71788 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
71789 SPH=-1D0
71790 APL=-1D0
71791 RETURN
71792 ENDIF
71793 DO 160 J1=1,3
71794 DO 150 J2=J1,3
71795 SM(J1,J2)=SM(J1,J2)/PS
71796 150 CONTINUE
71797 160 CONTINUE
71798
71799C...Find eigenvalues to matrix (third degree equation).
71800 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71801 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71802 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71803 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71804 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71805 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71806 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71807 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
71808 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
71809 IF(P(N+2,4).LT.1D-5) THEN
71810 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
71811 SPH=-1D0
71812 APL=-1D0
71813 RETURN
71814 ENDIF
71815
71816C...Find first and last eigenvector by solving equation system.
71817 DO 240 I=1,3,2
71818 DO 180 J1=1,3
71819 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
71820 DO 170 J2=J1+1,3
71821 SV(J1,J2)=SM(J1,J2)
71822 SV(J2,J1)=SM(J1,J2)
71823 170 CONTINUE
71824 180 CONTINUE
71825 SMAX=0D0
71826 DO 200 J1=1,3
71827 DO 190 J2=1,3
71828 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
71829 JA=J1
71830 JB=J2
71831 SMAX=ABS(SV(J1,J2))
71832 190 CONTINUE
71833 200 CONTINUE
71834 SMAX=0D0
71835 DO 220 J3=JA+1,JA+2
71836 J1=J3-3*((J3-1)/3)
71837 RL=SV(J1,JB)/SV(JA,JB)
71838 DO 210 J2=1,3
71839 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
71840 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
71841 JC=J1
71842 SMAX=ABS(SV(J1,J2))
71843 210 CONTINUE
71844 220 CONTINUE
71845 JB1=JB+1-3*(JB/3)
71846 JB2=JB+2-3*((JB+1)/3)
71847 P(N+I,JB1)=-SV(JC,JB2)
71848 P(N+I,JB2)=SV(JC,JB1)
71849 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
71850 & SV(JA,JB)
71851 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
71852 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71853 DO 230 J=1,3
71854 P(N+I,J)=SGN*P(N+I,J)/PA
71855 230 CONTINUE
71856 240 CONTINUE
71857
71858C...Middle axis orthogonal to other two. Fill other codes.
71859 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71860 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
71861 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
71862 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
71863 DO 260 I=1,3
71864 K(N+I,1)=31
71865 K(N+I,2)=95
71866 K(N+I,3)=I
71867 K(N+I,4)=0
71868 K(N+I,5)=0
71869 P(N+I,5)=0D0
71870 DO 250 J=1,5
71871 V(I,J)=0D0
71872 250 CONTINUE
71873 260 CONTINUE
71874
71875C...Calculate sphericity and aplanarity. Select storing option.
71876 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
71877 APL=1.5D0*P(N+3,4)
71878 MSTU(61)=N+1
71879 MSTU(62)=NP
71880 IF(MSTU(43).LE.1) MSTU(3)=3
71881 IF(MSTU(43).GE.2) N=N+3
71882
71883 RETURN
71884 END
71885
71886C*********************************************************************
71887
71888C...PYTHRU
71889C...Performs thrust analysis to give thrust, oblateness
71890C...and the related event axes.
71891
71892 SUBROUTINE PYTHRU(THR,OBL)
71893
71894C...Double precision and integer declarations.
71895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71896 IMPLICIT INTEGER(I-N)
71897 INTEGER PYK,PYCHGE,PYCOMP
71898C...Parameter statement to help give large particle numbers.
71899 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71900 &KEXCIT=4000000,KDIMEN=5000000)
71901C...Commonblocks.
71902 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71903 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71904 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71905 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71906C...Local arrays.
71907 DIMENSION TDI(3),TPR(3)
71908
71909C...Take copy of particles that are to be considered in thrust analysis.
71910 NP=0
71911 PS=0D0
71912 DO 100 I=1,N
71913 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
71914 IF(MSTU(41).GE.2) THEN
71915 KC=PYCOMP(K(I,2))
71916 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71917 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71918 & K(I,2).EQ.KSUSY1+39) GOTO 100
71919 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71920 & GOTO 100
71921 ENDIF
71922 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
71923 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
71924 THR=-2D0
71925 OBL=-2D0
71926 RETURN
71927 ENDIF
71928 NP=NP+1
71929 K(N+NP,1)=23
71930 P(N+NP,1)=P(I,1)
71931 P(N+NP,2)=P(I,2)
71932 P(N+NP,3)=P(I,3)
71933 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71934 P(N+NP,5)=1D0
71935 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
71936 & P(N+NP,4)**(PARU(42)-1D0)
71937 PS=PS+P(N+NP,4)*P(N+NP,5)
71938 100 CONTINUE
71939
71940C...Very low multiplicities (0 or 1) not considered.
71941 IF(NP.LE.1) THEN
71942 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
71943 THR=-1D0
71944 OBL=-1D0
71945 RETURN
71946 ENDIF
71947
71948C...Loop over thrust and major. T axis along z direction in latter case.
71949 DO 320 ILD=1,2
71950 IF(ILD.EQ.2) THEN
71951 K(N+NP+1,1)=31
71952 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
71953 MSTU(33)=1
71954 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
71955 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
71956 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
71957 ENDIF
71958
71959C...Find and order particles with highest p (pT for major).
71960 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
71961 P(ILF,4)=0D0
71962 110 CONTINUE
71963 DO 160 I=N+1,N+NP
71964 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
71965 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
71966 IF(P(I,4).LE.P(ILF,4)) GOTO 140
71967 DO 120 J=1,5
71968 P(ILF+1,J)=P(ILF,J)
71969 120 CONTINUE
71970 130 CONTINUE
71971 ILF=N+NP+3
71972 140 DO 150 J=1,5
71973 P(ILF+1,J)=P(I,J)
71974 150 CONTINUE
71975 160 CONTINUE
71976
71977C...Find and order initial axes with highest thrust (major).
71978 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
71979 P(ILG,4)=0D0
71980 170 CONTINUE
71981 NC=2**(MIN(MSTU(44),NP)-1)
71982 DO 250 ILC=1,NC
71983 DO 180 J=1,3
71984 TDI(J)=0D0
71985 180 CONTINUE
71986 DO 200 ILF=1,MIN(MSTU(44),NP)
71987 SGN=P(N+NP+ILF+3,5)
71988 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
71989 DO 190 J=1,4-ILD
71990 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
71991 190 CONTINUE
71992 200 CONTINUE
71993 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
71994 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
71995 IF(TDS.LE.P(ILG,4)) GOTO 230
71996 DO 210 J=1,4
71997 P(ILG+1,J)=P(ILG,J)
71998 210 CONTINUE
71999 220 CONTINUE
72000 ILG=N+NP+MSTU(44)+4
72001 230 DO 240 J=1,3
72002 P(ILG+1,J)=TDI(J)
72003 240 CONTINUE
72004 P(ILG+1,4)=TDS
72005 250 CONTINUE
72006
72007C...Iterate direction of axis until stable maximum.
72008 P(N+NP+ILD,4)=0D0
72009 ILG=0
72010 260 ILG=ILG+1
72011 THP=0D0
72012 270 THPS=THP
72013 DO 280 J=1,3
72014 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
72015 IF(THP.GT.1D-10) TDI(J)=TPR(J)
72016 TPR(J)=0D0
72017 280 CONTINUE
72018 DO 300 I=N+1,N+NP
72019 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
72020 DO 290 J=1,4-ILD
72021 TPR(J)=TPR(J)+SGN*P(I,J)
72022 290 CONTINUE
72023 300 CONTINUE
72024 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
72025 IF(THP.GE.THPS+PARU(48)) GOTO 270
72026
72027C...Save good axis. Try new initial axis until a number of tries agree.
72028 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
72029 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
72030 IAGR=0
72031 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72032 DO 310 J=1,3
72033 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
72034 310 CONTINUE
72035 P(N+NP+ILD,4)=THP
72036 P(N+NP+ILD,5)=0D0
72037 ENDIF
72038 IAGR=IAGR+1
72039 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
72040 320 CONTINUE
72041
72042C...Find minor axis and value by orthogonality.
72043 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72044 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
72045 P(N+NP+3,2)=SGN*P(N+NP+2,1)
72046 P(N+NP+3,3)=0D0
72047 THP=0D0
72048 DO 330 I=N+1,N+NP
72049 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
72050 330 CONTINUE
72051 P(N+NP+3,4)=THP/PS
72052 P(N+NP+3,5)=0D0
72053
72054C...Fill axis information. Rotate back to original coordinate system.
72055 DO 350 ILD=1,3
72056 K(N+ILD,1)=31
72057 K(N+ILD,2)=96
72058 K(N+ILD,3)=ILD
72059 K(N+ILD,4)=0
72060 K(N+ILD,5)=0
72061 DO 340 J=1,5
72062 P(N+ILD,J)=P(N+NP+ILD,J)
72063 V(N+ILD,J)=0D0
72064 340 CONTINUE
72065 350 CONTINUE
72066 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
72067
72068C...Calculate thrust and oblateness. Select storing option.
72069 THR=P(N+1,4)
72070 OBL=P(N+2,4)-P(N+3,4)
72071 MSTU(61)=N+1
72072 MSTU(62)=NP
72073 IF(MSTU(43).LE.1) MSTU(3)=3
72074 IF(MSTU(43).GE.2) N=N+3
72075
72076 RETURN
72077 END
72078
72079C*********************************************************************
72080
72081C...PYCLUS
72082C...Subdivides the particle content of an event into jets/clusters.
72083
72084 SUBROUTINE PYCLUS(NJET)
72085
72086C...Double precision and integer declarations.
72087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72088 IMPLICIT INTEGER(I-N)
72089 INTEGER PYK,PYCHGE,PYCOMP
72090C...Parameter statement to help give large particle numbers.
72091 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72092 &KEXCIT=4000000,KDIMEN=5000000)
72093C...Commonblocks.
72094 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72095 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72096 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72097 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72098C...Local arrays and saved variables.
72099 DIMENSION PS(5)
72100 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
72101
72102C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
72103 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
72104 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
72105 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
72106 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72107 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
72108 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72109
72110C...If first time, reset. If reentering, skip preliminaries.
72111 IF(MSTU(48).LE.0) THEN
72112 NP=0
72113 DO 100 J=1,5
72114 PS(J)=0D0
72115 100 CONTINUE
72116 PSS=0D0
72117 PIMASS=PMAS(PYCOMP(211),1)
72118 ELSE
72119 NJET=NSAV
72120 IF(MSTU(43).GE.2) N=N-NJET
72121 DO 110 I=N+1,N+NJET
72122 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72123 110 CONTINUE
72124 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72125 R2ACC=PARU(44)**2
72126 ELSE
72127 R2ACC=PARU(45)*PS(5)**2
72128 ENDIF
72129 NLOOP=0
72130 GOTO 300
72131 ENDIF
72132
72133C...Find which particles are to be considered in cluster search.
72134 DO 140 I=1,N
72135 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
72136 IF(MSTU(41).GE.2) THEN
72137 KC=PYCOMP(K(I,2))
72138 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72139 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72140 & K(I,2).EQ.KSUSY1+39) GOTO 140
72141 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72142 & GOTO 140
72143 ENDIF
72144 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
72145 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
72146 NJET=-1
72147 RETURN
72148 ENDIF
72149
72150C...Take copy of these particles, with space left for jets later on.
72151 NP=NP+1
72152 K(N+NP,3)=I
72153 DO 120 J=1,5
72154 P(N+NP,J)=P(I,J)
72155 120 CONTINUE
72156 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72157 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72158 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72159 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72160 DO 130 J=1,4
72161 PS(J)=PS(J)+P(N+NP,J)
72162 130 CONTINUE
72163 PSS=PSS+P(N+NP,5)
72164 140 CONTINUE
72165 DO 160 I=N+1,N+NP
72166 K(I+NP,3)=K(I,3)
72167 DO 150 J=1,5
72168 P(I+NP,J)=P(I,J)
72169 150 CONTINUE
72170 160 CONTINUE
72171 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
72172
72173C...Very low multiplicities not considered.
72174 IF(NP.LT.MSTU(47)) THEN
72175 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
72176 NJET=-1
72177 RETURN
72178 ENDIF
72179
72180C...Find precluster configuration. If too few jets, make harder cuts.
72181 NLOOP=0
72182 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72183 R2ACC=PARU(44)**2
72184 ELSE
72185 R2ACC=PARU(45)*PS(5)**2
72186 ENDIF
72187 RINIT=1.25D0*PARU(43)
72188 IF(NP.LE.MSTU(47)+2) RINIT=0D0
72189 170 RINIT=0.8D0*RINIT
72190 NPRE=0
72191 NREM=NP
72192 DO 180 I=N+NP+1,N+2*NP
72193 K(I,4)=0
72194 180 CONTINUE
72195
72196C...Sum up small momentum region. Jet if enough absolute momentum.
72197 IF(MSTU(46).LE.2) THEN
72198 DO 190 J=1,4
72199 P(N+1,J)=0D0
72200 190 CONTINUE
72201 DO 210 I=N+NP+1,N+2*NP
72202 IF(P(I,5).GT.2D0*RINIT) GOTO 210
72203 NREM=NREM-1
72204 K(I,4)=1
72205 DO 200 J=1,4
72206 P(N+1,J)=P(N+1,J)+P(I,J)
72207 200 CONTINUE
72208 210 CONTINUE
72209 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
72210 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
72211 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72212 IF(NREM.EQ.0) GOTO 170
72213 ENDIF
72214
72215C...Find fastest remaining particle.
72216 220 NPRE=NPRE+1
72217 PMAX=0D0
72218 DO 230 I=N+NP+1,N+2*NP
72219 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
72220 IMAX=I
72221 PMAX=P(I,5)
72222 230 CONTINUE
72223 DO 240 J=1,5
72224 P(N+NPRE,J)=P(IMAX,J)
72225 240 CONTINUE
72226 NREM=NREM-1
72227 K(IMAX,4)=NPRE
72228
72229C...Sum up precluster around it according to pT separation.
72230 IF(MSTU(46).LE.2) THEN
72231 DO 260 I=N+NP+1,N+2*NP
72232 IF(K(I,4).NE.0) GOTO 260
72233 R2=R2T(I,IMAX)
72234 IF(R2.GT.RINIT**2) GOTO 260
72235 NREM=NREM-1
72236 K(I,4)=NPRE
72237 DO 250 J=1,4
72238 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
72239 250 CONTINUE
72240 260 CONTINUE
72241 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72242
72243C...Sum up precluster around it according to mass or
72244C...Durham pT separation.
72245 ELSE
72246 270 IMIN=0
72247 R2MIN=RINIT**2
72248 DO 280 I=N+NP+1,N+2*NP
72249 IF(K(I,4).NE.0) GOTO 280
72250 IF(MSTU(46).LE.4) THEN
72251 R2=R2M(I,N+NPRE)
72252 ELSE
72253 R2=R2D(I,N+NPRE)
72254 ENDIF
72255 IF(R2.GE.R2MIN) GOTO 280
72256 IMIN=I
72257 R2MIN=R2
72258 280 CONTINUE
72259 IF(IMIN.NE.0) THEN
72260 DO 290 J=1,4
72261 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
72262 290 CONTINUE
72263 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72264 NREM=NREM-1
72265 K(IMIN,4)=NPRE
72266 GOTO 270
72267 ENDIF
72268 ENDIF
72269
72270C...Check if more preclusters to be found. Start over if too few.
72271 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72272 IF(NREM.GT.0) GOTO 220
72273 NJET=NPRE
72274
72275C...Reassign all particles to nearest jet. Sum up new jet momenta.
72276 300 TSAV=0D0
72277 PSJT=0D0
72278 310 IF(MSTU(46).LE.1) THEN
72279 DO 330 I=N+1,N+NJET
72280 DO 320 J=1,4
72281 V(I,J)=0D0
72282 320 CONTINUE
72283 330 CONTINUE
72284 DO 360 I=N+NP+1,N+2*NP
72285 R2MIN=PSS**2
72286 DO 340 IJET=N+1,N+NJET
72287 IF(P(IJET,5).LT.RINIT) GOTO 340
72288 R2=R2T(I,IJET)
72289 IF(R2.GE.R2MIN) GOTO 340
72290 IMIN=IJET
72291 R2MIN=R2
72292 340 CONTINUE
72293 K(I,4)=IMIN-N
72294 DO 350 J=1,4
72295 V(IMIN,J)=V(IMIN,J)+P(I,J)
72296 350 CONTINUE
72297 360 CONTINUE
72298 PSJT=0D0
72299 DO 380 I=N+1,N+NJET
72300 DO 370 J=1,4
72301 P(I,J)=V(I,J)
72302 370 CONTINUE
72303 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72304 PSJT=PSJT+P(I,5)
72305 380 CONTINUE
72306 ENDIF
72307
72308C...Find two closest jets.
72309 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
72310 DO 400 ITRY1=N+1,N+NJET-1
72311 DO 390 ITRY2=ITRY1+1,N+NJET
72312 IF(MSTU(46).LE.2) THEN
72313 R2=R2T(ITRY1,ITRY2)
72314 ELSEIF(MSTU(46).LE.4) THEN
72315 R2=R2M(ITRY1,ITRY2)
72316 ELSE
72317 R2=R2D(ITRY1,ITRY2)
72318 ENDIF
72319 IF(R2.GE.R2MIN) GOTO 390
72320 IMIN1=ITRY1
72321 IMIN2=ITRY2
72322 R2MIN=R2
72323 390 CONTINUE
72324 400 CONTINUE
72325
72326C...If allowed, join two closest jets and start over.
72327 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
72328 IREC=MIN(IMIN1,IMIN2)
72329 IDEL=MAX(IMIN1,IMIN2)
72330 DO 410 J=1,4
72331 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
72332 410 CONTINUE
72333 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
72334 DO 430 I=IDEL+1,N+NJET
72335 DO 420 J=1,5
72336 P(I-1,J)=P(I,J)
72337 420 CONTINUE
72338 430 CONTINUE
72339 IF(MSTU(46).GE.2) THEN
72340 DO 440 I=N+NP+1,N+2*NP
72341 IORI=N+K(I,4)
72342 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
72343 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
72344 440 CONTINUE
72345 ENDIF
72346 NJET=NJET-1
72347 GOTO 300
72348
72349C...Divide up broad jet if empty cluster in list of final ones.
72350 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
72351 DO 450 I=N+1,N+NJET
72352 K(I,5)=0
72353 450 CONTINUE
72354 DO 460 I=N+NP+1,N+2*NP
72355 K(N+K(I,4),5)=K(N+K(I,4),5)+1
72356 460 CONTINUE
72357 IEMP=0
72358 DO 470 I=N+1,N+NJET
72359 IF(K(I,5).EQ.0) IEMP=I
72360 470 CONTINUE
72361 IF(IEMP.NE.0) THEN
72362 NLOOP=NLOOP+1
72363 ISPL=0
72364 R2MAX=0D0
72365 DO 480 I=N+NP+1,N+2*NP
72366 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
72367 IJET=N+K(I,4)
72368 R2=R2T(I,IJET)
72369 IF(R2.LE.R2MAX) GOTO 480
72370 ISPL=I
72371 R2MAX=R2
72372 480 CONTINUE
72373 IF(ISPL.NE.0) THEN
72374 IJET=N+K(ISPL,4)
72375 DO 490 J=1,4
72376 P(IEMP,J)=P(ISPL,J)
72377 P(IJET,J)=P(IJET,J)-P(ISPL,J)
72378 490 CONTINUE
72379 P(IEMP,5)=P(ISPL,5)
72380 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
72381 IF(NLOOP.LE.2) GOTO 300
72382 ENDIF
72383 ENDIF
72384 ENDIF
72385
72386C...If generalized thrust has not yet converged, continue iteration.
72387 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
72388 &THEN
72389 TSAV=PSJT/PSS
72390 GOTO 310
72391 ENDIF
72392
72393C...Reorder jets according to energy.
72394 DO 510 I=N+1,N+NJET
72395 DO 500 J=1,5
72396 V(I,J)=P(I,J)
72397 500 CONTINUE
72398 510 CONTINUE
72399 DO 540 INEW=N+1,N+NJET
72400 PEMAX=0D0
72401 DO 520 ITRY=N+1,N+NJET
72402 IF(V(ITRY,4).LE.PEMAX) GOTO 520
72403 IMAX=ITRY
72404 PEMAX=V(ITRY,4)
72405 520 CONTINUE
72406 K(INEW,1)=31
72407 K(INEW,2)=97
72408 K(INEW,3)=INEW-N
72409 K(INEW,4)=0
72410 DO 530 J=1,5
72411 P(INEW,J)=V(IMAX,J)
72412 530 CONTINUE
72413 V(IMAX,4)=-1D0
72414 K(IMAX,5)=INEW
72415 540 CONTINUE
72416
72417C...Clean up particle-jet assignments and jet information.
72418 DO 550 I=N+NP+1,N+2*NP
72419 IORI=K(N+K(I,4),5)
72420 K(I,4)=IORI-N
72421 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
72422 K(IORI,4)=K(IORI,4)+1
72423 550 CONTINUE
72424 IEMP=0
72425 PSJT=0D0
72426 DO 570 I=N+1,N+NJET
72427 K(I,5)=0
72428 PSJT=PSJT+P(I,5)
72429 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
72430 DO 560 J=1,5
72431 V(I,J)=0D0
72432 560 CONTINUE
72433 IF(K(I,4).EQ.0) IEMP=I
72434 570 CONTINUE
72435
72436C...Select storing option. Output variables. Check for failure.
72437 MSTU(61)=N+1
72438 MSTU(62)=NP
72439 MSTU(63)=NPRE
72440 PARU(61)=PS(5)
72441 PARU(62)=PSJT/PSS
72442 PARU(63)=SQRT(R2MIN)
72443 IF(NJET.LE.1) PARU(63)=0D0
72444 IF(IEMP.NE.0) THEN
72445 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
72446 NJET=-1
72447 RETURN
72448 ENDIF
72449 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72450 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72451 NSAV=NJET
72452
72453 RETURN
72454 END
72455
72456C*********************************************************************
72457
72458C...PYCELL
72459C...Provides a simple way of jet finding in eta-phi-ET coordinates,
72460C...as used for calorimeters at hadron colliders.
72461
72462 SUBROUTINE PYCELL(NJET)
72463
72464C...Double precision and integer declarations.
72465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72466 IMPLICIT INTEGER(I-N)
72467 INTEGER PYK,PYCHGE,PYCOMP
72468C...Parameter statement to help give large particle numbers.
72469 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72470 &KEXCIT=4000000,KDIMEN=5000000)
72471C...Commonblocks.
72472 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72473 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72474 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72475 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72476
72477C...Loop over all particles. Find cell that was hit by given particle.
72478 PTLRAT=1D0/SINH(PARU(51))**2
72479 NP=0
72480 NC=N
72481 DO 110 I=1,N
72482 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72483 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
72484 IF(MSTU(41).GE.2) THEN
72485 KC=PYCOMP(K(I,2))
72486 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72487 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72488 & K(I,2).EQ.KSUSY1+39) GOTO 110
72489 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72490 & GOTO 110
72491 ENDIF
72492 NP=NP+1
72493 PT=SQRT(P(I,1)**2+P(I,2)**2)
72494 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
72495 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
72496 & (ETA/PARU(51)+1D0))))
72497 PHI=PYANGL(P(I,1),P(I,2))
72498 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
72499 & (PHI/PARU(1)+1D0))))
72500 IETPH=MSTU(52)*IETA+IPHI
72501
72502C...Add to cell already hit, or book new cell.
72503 DO 100 IC=N+1,NC
72504 IF(IETPH.EQ.K(IC,3)) THEN
72505 K(IC,4)=K(IC,4)+1
72506 P(IC,5)=P(IC,5)+PT
72507 GOTO 110
72508 ENDIF
72509 100 CONTINUE
72510 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
72511 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72512 NJET=-2
72513 RETURN
72514 ENDIF
72515 NC=NC+1
72516 K(NC,3)=IETPH
72517 K(NC,4)=1
72518 K(NC,5)=2
72519 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
72520 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
72521 P(NC,5)=PT
72522 110 CONTINUE
72523
72524C...Smear true bin content by calorimeter resolution.
72525 IF(MSTU(53).GE.1) THEN
72526 DO 130 IC=N+1,NC
72527 PEI=P(IC,5)
72528 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
72529 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
72530 & COS(PARU(2)*PYR(0))
72531 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
72532 P(IC,5)=PEF
72533 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
72534 130 CONTINUE
72535 ENDIF
72536
72537C...Remove cells below threshold.
72538 IF(PARU(58).GT.0D0) THEN
72539 NCC=NC
72540 NC=N
72541 DO 140 IC=N+1,NCC
72542 IF(P(IC,5).GT.PARU(58)) THEN
72543 NC=NC+1
72544 K(NC,3)=K(IC,3)
72545 K(NC,4)=K(IC,4)
72546 K(NC,5)=K(IC,5)
72547 P(NC,1)=P(IC,1)
72548 P(NC,2)=P(IC,2)
72549 P(NC,5)=P(IC,5)
72550 ENDIF
72551 140 CONTINUE
72552 ENDIF
72553
72554C...Find initiator cell: the one with highest pT of not yet used ones.
72555 NJ=NC
72556 150 ETMAX=0D0
72557 DO 160 IC=N+1,NC
72558 IF(K(IC,5).NE.2) GOTO 160
72559 IF(P(IC,5).LE.ETMAX) GOTO 160
72560 ICMAX=IC
72561 ETA=P(IC,1)
72562 PHI=P(IC,2)
72563 ETMAX=P(IC,5)
72564 160 CONTINUE
72565 IF(ETMAX.LT.PARU(52)) GOTO 220
72566 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
72567 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72568 NJET=-2
72569 RETURN
72570 ENDIF
72571 K(ICMAX,5)=1
72572 NJ=NJ+1
72573 K(NJ,4)=0
72574 K(NJ,5)=1
72575 P(NJ,1)=ETA
72576 P(NJ,2)=PHI
72577 P(NJ,3)=0D0
72578 P(NJ,4)=0D0
72579 P(NJ,5)=0D0
72580
72581C...Sum up unused cells within required distance of initiator.
72582 DO 170 IC=N+1,NC
72583 IF(K(IC,5).EQ.0) GOTO 170
72584 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
72585 DPHIA=ABS(P(IC,2)-PHI)
72586 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
72587 PHIC=P(IC,2)
72588 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
72589 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
72590 K(IC,5)=-K(IC,5)
72591 K(NJ,4)=K(NJ,4)+K(IC,4)
72592 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
72593 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
72594 P(NJ,5)=P(NJ,5)+P(IC,5)
72595 170 CONTINUE
72596
72597C...Reject cluster below minimum ET, else accept.
72598 IF(P(NJ,5).LT.PARU(53)) THEN
72599 NJ=NJ-1
72600 DO 180 IC=N+1,NC
72601 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
72602 180 CONTINUE
72603 ELSEIF(MSTU(54).LE.2) THEN
72604 P(NJ,3)=P(NJ,3)/P(NJ,5)
72605 P(NJ,4)=P(NJ,4)/P(NJ,5)
72606 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
72607 & P(NJ,4))
72608 DO 190 IC=N+1,NC
72609 IF(K(IC,5).LT.0) K(IC,5)=0
72610 190 CONTINUE
72611 ELSE
72612 DO 200 J=1,4
72613 P(NJ,J)=0D0
72614 200 CONTINUE
72615 DO 210 IC=N+1,NC
72616 IF(K(IC,5).GE.0) GOTO 210
72617 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
72618 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
72619 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
72620 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
72621 K(IC,5)=0
72622 210 CONTINUE
72623 ENDIF
72624 GOTO 150
72625
72626C...Arrange clusters in falling ET sequence.
72627 220 DO 250 I=1,NJ-NC
72628 ETMAX=0D0
72629 DO 230 IJ=NC+1,NJ
72630 IF(K(IJ,5).EQ.0) GOTO 230
72631 IF(P(IJ,5).LT.ETMAX) GOTO 230
72632 IJMAX=IJ
72633 ETMAX=P(IJ,5)
72634 230 CONTINUE
72635 K(IJMAX,5)=0
72636 K(N+I,1)=31
72637 K(N+I,2)=98
72638 K(N+I,3)=I
72639 K(N+I,4)=K(IJMAX,4)
72640 K(N+I,5)=0
72641 DO 240 J=1,5
72642 P(N+I,J)=P(IJMAX,J)
72643 V(N+I,J)=0D0
72644 240 CONTINUE
72645 250 CONTINUE
72646 NJET=NJ-NC
72647
72648C...Convert to massless or massive four-vectors.
72649 IF(MSTU(54).EQ.2) THEN
72650 DO 260 I=N+1,N+NJET
72651 ETA=P(I,3)
72652 P(I,1)=P(I,5)*COS(P(I,4))
72653 P(I,2)=P(I,5)*SIN(P(I,4))
72654 P(I,3)=P(I,5)*SINH(ETA)
72655 P(I,4)=P(I,5)*COSH(ETA)
72656 P(I,5)=0D0
72657 260 CONTINUE
72658 ELSEIF(MSTU(54).GE.3) THEN
72659 DO 270 I=N+1,N+NJET
72660 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
72661 270 CONTINUE
72662 ENDIF
72663
72664C...Information about storage.
72665 MSTU(61)=N+1
72666 MSTU(62)=NP
72667 MSTU(63)=NC-N
72668 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72669 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72670
72671 RETURN
72672 END
72673
72674C*********************************************************************
72675
72676C...PYJMAS
72677C...Determines, approximately, the two jet masses that minimize
72678C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
72679
72680 SUBROUTINE PYJMAS(PMH,PML)
72681
72682C...Double precision and integer declarations.
72683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72684 IMPLICIT INTEGER(I-N)
72685 INTEGER PYK,PYCHGE,PYCOMP
72686C...Parameter statement to help give large particle numbers.
72687 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72688 &KEXCIT=4000000,KDIMEN=5000000)
72689C...Commonblocks.
72690 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72691 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72692 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72693 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72694C...Local arrays.
72695 DIMENSION SM(3,3),SAX(3),PS(3,5)
72696
72697C...Reset.
72698 NP=0
72699 DO 120 J1=1,3
72700 DO 100 J2=J1,3
72701 SM(J1,J2)=0D0
72702 100 CONTINUE
72703 DO 110 J2=1,4
72704 PS(J1,J2)=0D0
72705 110 CONTINUE
72706 120 CONTINUE
72707 PSS=0D0
72708 PIMASS=PMAS(PYCOMP(211),1)
72709
72710C...Take copy of particles that are to be considered in mass analysis.
72711 DO 170 I=1,N
72712 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
72713 IF(MSTU(41).GE.2) THEN
72714 KC=PYCOMP(K(I,2))
72715 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72716 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72717 & K(I,2).EQ.KSUSY1+39) GOTO 170
72718 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72719 & GOTO 170
72720 ENDIF
72721 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
72722 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
72723 PMH=-2D0
72724 PML=-2D0
72725 RETURN
72726 ENDIF
72727 NP=NP+1
72728 DO 130 J=1,5
72729 P(N+NP,J)=P(I,J)
72730 130 CONTINUE
72731 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72732 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72733 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72734
72735C...Fill information in sphericity tensor and total momentum vector.
72736 DO 150 J1=1,3
72737 DO 140 J2=J1,3
72738 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
72739 140 CONTINUE
72740 150 CONTINUE
72741 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72742 DO 160 J=1,4
72743 PS(3,J)=PS(3,J)+P(N+NP,J)
72744 160 CONTINUE
72745 170 CONTINUE
72746
72747C...Very low multiplicities (0 or 1) not considered.
72748 IF(NP.LE.1) THEN
72749 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
72750 PMH=-1D0
72751 PML=-1D0
72752 RETURN
72753 ENDIF
72754 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
72755 &PS(3,3)**2))
72756
72757C...Find largest eigenvalue to matrix (third degree equation).
72758 DO 190 J1=1,3
72759 DO 180 J2=J1,3
72760 SM(J1,J2)=SM(J1,J2)/PSS
72761 180 CONTINUE
72762 190 CONTINUE
72763 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
72764 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
72765 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
72766 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
72767 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
72768 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
72769 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
72770
72771C...Find largest eigenvector by solving equation system.
72772 DO 210 J1=1,3
72773 SM(J1,J1)=SM(J1,J1)-SMA
72774 DO 200 J2=J1+1,3
72775 SM(J2,J1)=SM(J1,J2)
72776 200 CONTINUE
72777 210 CONTINUE
72778 SMAX=0D0
72779 DO 230 J1=1,3
72780 DO 220 J2=1,3
72781 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
72782 JA=J1
72783 JB=J2
72784 SMAX=ABS(SM(J1,J2))
72785 220 CONTINUE
72786 230 CONTINUE
72787 SMAX=0D0
72788 DO 250 J3=JA+1,JA+2
72789 J1=J3-3*((J3-1)/3)
72790 RL=SM(J1,JB)/SM(JA,JB)
72791 DO 240 J2=1,3
72792 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
72793 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
72794 JC=J1
72795 SMAX=ABS(SM(J1,J2))
72796 240 CONTINUE
72797 250 CONTINUE
72798 JB1=JB+1-3*(JB/3)
72799 JB2=JB+2-3*((JB+1)/3)
72800 SAX(JB1)=-SM(JC,JB2)
72801 SAX(JB2)=SM(JC,JB1)
72802 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
72803
72804C...Divide particles into two initial clusters by hemisphere.
72805 DO 270 I=N+1,N+NP
72806 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
72807 IS=1
72808 IF(PSAX.LT.0D0) IS=2
72809 K(I,3)=IS
72810 DO 260 J=1,4
72811 PS(IS,J)=PS(IS,J)+P(I,J)
72812 260 CONTINUE
72813 270 CONTINUE
72814 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
72815 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
72816
72817C...Reassign one particle at a time; find maximum decrease of m^2 sum.
72818 280 PMD=0D0
72819 IM=0
72820 DO 290 J=1,4
72821 PS(3,J)=PS(1,J)-PS(2,J)
72822 290 CONTINUE
72823 DO 300 I=N+1,N+NP
72824 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)
72825 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
72826 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
72827 IF(PMDI.LT.PMD) THEN
72828 PMD=PMDI
72829 IM=I
72830 ENDIF
72831 300 CONTINUE
72832
72833C...Loop back if significant reduction in sum of m^2.
72834 IF(PMD.LT.-PARU(48)*PMS) THEN
72835 PMS=PMS+PMD
72836 IS=K(IM,3)
72837 DO 310 J=1,4
72838 PS(IS,J)=PS(IS,J)-P(IM,J)
72839 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
72840 310 CONTINUE
72841 K(IM,3)=3-IS
72842 GOTO 280
72843 ENDIF
72844
72845C...Final masses and output.
72846 MSTU(61)=N+1
72847 MSTU(62)=NP
72848 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
72849 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
72850 PMH=MAX(PS(1,5),PS(2,5))
72851 PML=MIN(PS(1,5),PS(2,5))
72852
72853 RETURN
72854 END
72855
72856C*********************************************************************
72857
72858C...PYFOWO
72859C...Calculates the first few Fox-Wolfram moments.
72860
72861 SUBROUTINE PYFOWO(H10,H20,H30,H40)
72862
72863C...Double precision and integer declarations.
72864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72865 IMPLICIT INTEGER(I-N)
72866 INTEGER PYK,PYCHGE,PYCOMP
72867C...Parameter statement to help give large particle numbers.
72868 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72869 &KEXCIT=4000000,KDIMEN=5000000)
72870C...Commonblocks.
72871 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72874 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72875
72876C...Copy momenta for particles and calculate H0.
72877 NP=0
72878 H0=0D0
72879 HD=0D0
72880 DO 110 I=1,N
72881 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72882 IF(MSTU(41).GE.2) THEN
72883 KC=PYCOMP(K(I,2))
72884 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72885 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72886 & K(I,2).EQ.KSUSY1+39) GOTO 110
72887 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72888 & GOTO 110
72889 ENDIF
72890 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
72891 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
72892 H10=-1D0
72893 H20=-1D0
72894 H30=-1D0
72895 H40=-1D0
72896 RETURN
72897 ENDIF
72898 NP=NP+1
72899 DO 100 J=1,3
72900 P(N+NP,J)=P(I,J)
72901 100 CONTINUE
72902 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72903 H0=H0+P(N+NP,4)
72904 HD=HD+P(N+NP,4)**2
72905 110 CONTINUE
72906 H0=H0**2
72907
72908C...Very low multiplicities (0 or 1) not considered.
72909 IF(NP.LE.1) THEN
72910 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
72911 H10=-1D0
72912 H20=-1D0
72913 H30=-1D0
72914 H40=-1D0
72915 RETURN
72916 ENDIF
72917
72918C...Calculate H1 - H4.
72919 H10=0D0
72920 H20=0D0
72921 H30=0D0
72922 H40=0D0
72923 DO 130 I1=N+1,N+NP
72924 DO 120 I2=I1+1,N+NP
72925 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72926 & (P(I1,4)*P(I2,4))
72927 H10=H10+P(I1,4)*P(I2,4)*CTHE
72928 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
72929 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
72930 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
72931 & 0.375D0)
72932 120 CONTINUE
72933 130 CONTINUE
72934
72935C...Calculate H1/H0 - H4/H0. Output.
72936 MSTU(61)=N+1
72937 MSTU(62)=NP
72938 H10=(HD+2D0*H10)/H0
72939 H20=(HD+2D0*H20)/H0
72940 H30=(HD+2D0*H30)/H0
72941 H40=(HD+2D0*H40)/H0
72942
72943 RETURN
72944 END
72945
72946C*********************************************************************
72947
72948C...PYTABU
72949C...Evaluates various properties of an event, with statistics
72950C...accumulated during the course of the run and
72951C...printed at the end.
72952
72953 SUBROUTINE PYTABU(MTABU)
72954
72955C...Double precision and integer declarations.
72956 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72957 IMPLICIT INTEGER(I-N)
72958 INTEGER PYK,PYCHGE,PYCOMP
72959C...Parameter statement to help give large particle numbers.
72960 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72961 &KEXCIT=4000000,KDIMEN=5000000)
72962C...Commonblocks.
72963 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72964 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72965 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72966 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
72967 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
72968C...Local arrays, character variables, saved variables and data.
72969 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
72970 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
72971 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
72972 &KFDM(8),KFDC(200,0:8),NPDC(200)
72973 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
72974 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
72975 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
72976 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
72977 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
72978 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
72979 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
72980 &NEVDC/0/,NKFDC/0/,NREDC/0/
72981
72982C...Reset statistics on initial parton state.
72983 IF(MTABU.EQ.10) THEN
72984 NEVIS=0
72985 NKFIS=0
72986
72987C...Identify and order flavour content of initial state.
72988 ELSEIF(MTABU.EQ.11) THEN
72989 NEVIS=NEVIS+1
72990 KFM1=2*IABS(MSTU(161))
72991 IF(MSTU(161).GT.0) KFM1=KFM1-1
72992 KFM2=2*IABS(MSTU(162))
72993 IF(MSTU(162).GT.0) KFM2=KFM2-1
72994 KFMN=MIN(KFM1,KFM2)
72995 KFMX=MAX(KFM1,KFM2)
72996 DO 100 I=1,NKFIS
72997 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
72998 IKFIS=-I
72999 GOTO 110
73000 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
73001 & KFMX.LT.KFIS(I,2))) THEN
73002 IKFIS=I
73003 GOTO 110
73004 ENDIF
73005 100 CONTINUE
73006 IKFIS=NKFIS+1
73007 110 IF(IKFIS.LT.0) THEN
73008 IKFIS=-IKFIS
73009 ELSE
73010 IF(NKFIS.GE.100) RETURN
73011 DO 130 I=NKFIS,IKFIS,-1
73012 KFIS(I+1,1)=KFIS(I,1)
73013 KFIS(I+1,2)=KFIS(I,2)
73014 DO 120 J=0,10
73015 NPIS(I+1,J)=NPIS(I,J)
73016 120 CONTINUE
73017 130 CONTINUE
73018 NKFIS=NKFIS+1
73019 KFIS(IKFIS,1)=KFMN
73020 KFIS(IKFIS,2)=KFMX
73021 DO 140 J=0,10
73022 NPIS(IKFIS,J)=0
73023 140 CONTINUE
73024 ENDIF
73025 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
73026
73027C...Count number of partons in initial state.
73028 NP=0
73029 DO 160 I=1,N
73030 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
73031 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
73032 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
73033 & THEN
73034 ELSE
73035 IM=I
73036 150 IM=K(IM,3)
73037 IF(IM.LE.0.OR.IM.GT.N) THEN
73038 NP=NP+1
73039 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73040 NP=NP+1
73041 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
73042 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
73043 & .NE.0) THEN
73044 ELSE
73045 GOTO 150
73046 ENDIF
73047 ENDIF
73048 160 CONTINUE
73049 NPCO=MAX(NP,1)
73050 IF(NP.GE.6) NPCO=6
73051 IF(NP.GE.8) NPCO=7
73052 IF(NP.GE.11) NPCO=8
73053 IF(NP.GE.16) NPCO=9
73054 IF(NP.GE.26) NPCO=10
73055 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
73056 MSTU(62)=NP
73057
73058C...Write statistics on initial parton state.
73059 ELSEIF(MTABU.EQ.12) THEN
73060 FAC=1D0/MAX(1,NEVIS)
73061 WRITE(MSTU(11),5000) NEVIS
73062 DO 170 I=1,NKFIS
73063 KFMN=KFIS(I,1)
73064 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73065 KFM1=(KFMN+1)/2
73066 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73067 CALL PYNAME(KFM1,CHAU)
73068 CHIS(1)=CHAU(1:12)
73069 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
73070 KFMX=KFIS(I,2)
73071 IF(KFIS(I,1).EQ.0) KFMX=0
73072 KFM2=(KFMX+1)/2
73073 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73074 CALL PYNAME(KFM2,CHAU)
73075 CHIS(2)=CHAU(1:12)
73076 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
73077 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
73078 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
73079 170 CONTINUE
73080
73081C...Copy statistics on initial parton state into /PYJETS/.
73082 ELSEIF(MTABU.EQ.13) THEN
73083 FAC=1D0/MAX(1,NEVIS)
73084 DO 190 I=1,NKFIS
73085 KFMN=KFIS(I,1)
73086 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73087 KFM1=(KFMN+1)/2
73088 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73089 KFMX=KFIS(I,2)
73090 IF(KFIS(I,1).EQ.0) KFMX=0
73091 KFM2=(KFMX+1)/2
73092 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73093 K(I,1)=32
73094 K(I,2)=99
73095 K(I,3)=KFM1
73096 K(I,4)=KFM2
73097 K(I,5)=NPIS(I,0)
73098 DO 180 J=1,5
73099 P(I,J)=FAC*NPIS(I,J)
73100 V(I,J)=FAC*NPIS(I,J+5)
73101 180 CONTINUE
73102 190 CONTINUE
73103 N=NKFIS
73104 DO 200 J=1,5
73105 K(N+1,J)=0
73106 P(N+1,J)=0D0
73107 V(N+1,J)=0D0
73108 200 CONTINUE
73109 K(N+1,1)=32
73110 K(N+1,2)=99
73111 K(N+1,5)=NEVIS
73112 MSTU(3)=1
73113
73114C...Reset statistics on number of particles/partons.
73115 ELSEIF(MTABU.EQ.20) THEN
73116 NEVFS=0
73117 NPRFS=0
73118 NFIFS=0
73119 NCHFS=0
73120 NKFFS=0
73121
73122C...Identify whether particle/parton is primary or not.
73123 ELSEIF(MTABU.EQ.21) THEN
73124 NEVFS=NEVFS+1
73125 MSTU(62)=0
73126 DO 260 I=1,N
73127 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
73128 MSTU(62)=MSTU(62)+1
73129 KC=PYCOMP(K(I,2))
73130 MPRI=0
73131 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
73132 MPRI=1
73133 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
73134 MPRI=1
73135 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
73136 MPRI=1
73137 ELSEIF(KC.EQ.0) THEN
73138 ELSEIF(K(K(I,3),1).EQ.13) THEN
73139 IM=K(K(I,3),3)
73140 IF(IM.LE.0.OR.IM.GT.N) THEN
73141 MPRI=1
73142 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73143 MPRI=1
73144 ENDIF
73145 ELSEIF(KCHG(KC,2).EQ.0) THEN
73146 KCM=PYCOMP(K(K(I,3),2))
73147 IF(KCM.NE.0) THEN
73148 IF(KCHG(KCM,2).NE.0) MPRI=1
73149 ENDIF
73150 ENDIF
73151 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
73152 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
73153 ENDIF
73154 IF(K(I,1).LE.10) THEN
73155 NFIFS=NFIFS+1
73156 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
73157 ENDIF
73158
73159C...Fill statistics on number of particles/partons in event.
73160 KFA=IABS(K(I,2))
73161 KFS=3-ISIGN(1,K(I,2))-MPRI
73162 DO 210 IP=1,NKFFS
73163 IF(KFA.EQ.KFFS(IP)) THEN
73164 IKFFS=-IP
73165 GOTO 220
73166 ELSEIF(KFA.LT.KFFS(IP)) THEN
73167 IKFFS=IP
73168 GOTO 220
73169 ENDIF
73170 210 CONTINUE
73171 IKFFS=NKFFS+1
73172 220 IF(IKFFS.LT.0) THEN
73173 IKFFS=-IKFFS
73174 ELSE
73175 IF(NKFFS.GE.400) RETURN
73176 DO 240 IP=NKFFS,IKFFS,-1
73177 KFFS(IP+1)=KFFS(IP)
73178 DO 230 J=1,4
73179 NPFS(IP+1,J)=NPFS(IP,J)
73180 230 CONTINUE
73181 240 CONTINUE
73182 NKFFS=NKFFS+1
73183 KFFS(IKFFS)=KFA
73184 DO 250 J=1,4
73185 NPFS(IKFFS,J)=0
73186 250 CONTINUE
73187 ENDIF
73188 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
73189 260 CONTINUE
73190
73191C...Write statistics on particle/parton composition of events.
73192 ELSEIF(MTABU.EQ.22) THEN
73193 FAC=1D0/MAX(1,NEVFS)
73194 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
73195 DO 270 I=1,NKFFS
73196 CALL PYNAME(KFFS(I),CHAU)
73197 KC=PYCOMP(KFFS(I))
73198 MDCYF=0
73199 IF(KC.NE.0) MDCYF=MDCY(KC,1)
73200 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
73201 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
73202 270 CONTINUE
73203
73204C...Copy particle/parton composition information into /PYJETS/.
73205 ELSEIF(MTABU.EQ.23) THEN
73206 FAC=1D0/MAX(1,NEVFS)
73207 DO 290 I=1,NKFFS
73208 K(I,1)=32
73209 K(I,2)=99
73210 K(I,3)=KFFS(I)
73211 K(I,4)=0
73212 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
73213 DO 280 J=1,4
73214 P(I,J)=FAC*NPFS(I,J)
73215 V(I,J)=0D0
73216 280 CONTINUE
73217 P(I,5)=FAC*K(I,5)
73218 V(I,5)=0D0
73219 290 CONTINUE
73220 N=NKFFS
73221 DO 300 J=1,5
73222 K(N+1,J)=0
73223 P(N+1,J)=0D0
73224 V(N+1,J)=0D0
73225 300 CONTINUE
73226 K(N+1,1)=32
73227 K(N+1,2)=99
73228 K(N+1,5)=NEVFS
73229 P(N+1,1)=FAC*NPRFS
73230 P(N+1,2)=FAC*NFIFS
73231 P(N+1,3)=FAC*NCHFS
73232 MSTU(3)=1
73233
73234C...Reset factorial moments statistics.
73235 ELSEIF(MTABU.EQ.30) THEN
73236 NEVFM=0
73237 NMUFM=0
73238 DO 330 IM=1,3
73239 DO 320 IB=1,10
73240 DO 310 IP=1,4
73241 FM1FM(IM,IB,IP)=0D0
73242 FM2FM(IM,IB,IP)=0D0
73243 310 CONTINUE
73244 320 CONTINUE
73245 330 CONTINUE
73246
73247C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
73248 ELSEIF(MTABU.EQ.31) THEN
73249 NEVFM=NEVFM+1
73250 NLOW=N+MSTU(3)
73251 NUPP=NLOW
73252 DO 410 I=1,N
73253 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
73254 IF(MSTU(41).GE.2) THEN
73255 KC=PYCOMP(K(I,2))
73256 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73257 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73258 & K(I,2).EQ.KSUSY1+39) GOTO 410
73259 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73260 & PYCHGE(K(I,2)).EQ.0) GOTO 410
73261 ENDIF
73262 PMR=0D0
73263 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73264 IF(MSTU(42).GE.2) PMR=P(I,5)
73265 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
73266 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
73267 & 1D20)),P(I,3))
73268 IF(ABS(YETA).GT.PARU(57)) GOTO 410
73269 PHI=PYANGL(P(I,1),P(I,2))
73270 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
73271 IYETA=MAX(0,MIN(511,IYETA))
73272 IPHI=512D0*(PHI+PARU(1))/PARU(2)
73273 IPHI=MAX(0,MIN(511,IPHI))
73274 IYEP=0
73275 DO 340 IB=0,9
73276 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
73277 340 CONTINUE
73278
73279C...Order particles in (pseudo)rapidity and/or azimuth.
73280 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73281 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73282 RETURN
73283 ENDIF
73284 NUPP=NUPP+1
73285 IF(NUPP.EQ.NLOW+1) THEN
73286 K(NUPP,1)=IYETA
73287 K(NUPP,2)=IPHI
73288 K(NUPP,3)=IYEP
73289 ELSE
73290 DO 350 I1=NUPP-1,NLOW+1,-1
73291 IF(IYETA.GE.K(I1,1)) GOTO 360
73292 K(I1+1,1)=K(I1,1)
73293 350 CONTINUE
73294 360 K(I1+1,1)=IYETA
73295 DO 370 I1=NUPP-1,NLOW+1,-1
73296 IF(IPHI.GE.K(I1,2)) GOTO 380
73297 K(I1+1,2)=K(I1,2)
73298 370 CONTINUE
73299 380 K(I1+1,2)=IPHI
73300 DO 390 I1=NUPP-1,NLOW+1,-1
73301 IF(IYEP.GE.K(I1,3)) GOTO 400
73302 K(I1+1,3)=K(I1,3)
73303 390 CONTINUE
73304 400 K(I1+1,3)=IYEP
73305 ENDIF
73306 410 CONTINUE
73307 K(NUPP+1,1)=2**10
73308 K(NUPP+1,2)=2**10
73309 K(NUPP+1,3)=4**10
73310
73311C...Calculate sum of factorial moments in event.
73312 DO 480 IM=1,3
73313 DO 430 IB=1,10
73314 DO 420 IP=1,4
73315 FEVFM(IB,IP)=0D0
73316 420 CONTINUE
73317 430 CONTINUE
73318 DO 450 IB=1,10
73319 IF(IM.LE.2) IBIN=2**(10-IB)
73320 IF(IM.EQ.3) IBIN=4**(10-IB)
73321 IAGR=K(NLOW+1,IM)/IBIN
73322 NAGR=1
73323 DO 440 I=NLOW+2,NUPP+1
73324 ICUT=K(I,IM)/IBIN
73325 IF(ICUT.EQ.IAGR) THEN
73326 NAGR=NAGR+1
73327 ELSE
73328 IF(NAGR.EQ.1) THEN
73329 ELSEIF(NAGR.EQ.2) THEN
73330 FEVFM(IB,1)=FEVFM(IB,1)+2D0
73331 ELSEIF(NAGR.EQ.3) THEN
73332 FEVFM(IB,1)=FEVFM(IB,1)+6D0
73333 FEVFM(IB,2)=FEVFM(IB,2)+6D0
73334 ELSEIF(NAGR.EQ.4) THEN
73335 FEVFM(IB,1)=FEVFM(IB,1)+12D0
73336 FEVFM(IB,2)=FEVFM(IB,2)+24D0
73337 FEVFM(IB,3)=FEVFM(IB,3)+24D0
73338 ELSE
73339 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
73340 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
73341 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73342 & (NAGR-3D0)
73343 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73344 & (NAGR-3D0)*(NAGR-4D0)
73345 ENDIF
73346 IAGR=ICUT
73347 NAGR=1
73348 ENDIF
73349 440 CONTINUE
73350 450 CONTINUE
73351
73352C...Add results to total statistics.
73353 DO 470 IB=10,1,-1
73354 DO 460 IP=1,4
73355 IF(FEVFM(1,IP).LT.0.5D0) THEN
73356 FEVFM(IB,IP)=0D0
73357 ELSEIF(IM.LE.2) THEN
73358 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73359 ELSE
73360 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73361 ENDIF
73362 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
73363 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
73364 460 CONTINUE
73365 470 CONTINUE
73366 480 CONTINUE
73367 NMUFM=NMUFM+(NUPP-NLOW)
73368 MSTU(62)=NUPP-NLOW
73369
73370C...Write accumulated statistics on factorial moments.
73371 ELSEIF(MTABU.EQ.32) THEN
73372 FAC=1D0/MAX(1,NEVFM)
73373 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
73374 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
73375 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
73376 DO 510 IM=1,3
73377 WRITE(MSTU(11),5500)
73378 DO 500 IB=1,10
73379 BYETA=2D0*PARU(57)
73380 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
73381 BPHI=PARU(2)
73382 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
73383 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
73384 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
73385 DO 490 IP=1,4
73386 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
73387 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73388 & FMOMA(IP)**2)))
73389 490 CONTINUE
73390 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
73391 & IP=1,4)
73392 500 CONTINUE
73393 510 CONTINUE
73394
73395C...Copy statistics on factorial moments into /PYJETS/.
73396 ELSEIF(MTABU.EQ.33) THEN
73397 FAC=1D0/MAX(1,NEVFM)
73398 DO 540 IM=1,3
73399 DO 530 IB=1,10
73400 I=10*(IM-1)+IB
73401 K(I,1)=32
73402 K(I,2)=99
73403 K(I,3)=1
73404 IF(IM.NE.2) K(I,3)=2**(IB-1)
73405 K(I,4)=1
73406 IF(IM.NE.1) K(I,4)=2**(IB-1)
73407 K(I,5)=0
73408 P(I,1)=2D0*PARU(57)/K(I,3)
73409 V(I,1)=PARU(2)/K(I,4)
73410 DO 520 IP=1,4
73411 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
73412 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73413 & P(I,IP+1)**2)))
73414 520 CONTINUE
73415 530 CONTINUE
73416 540 CONTINUE
73417 N=30
73418 DO 550 J=1,5
73419 K(N+1,J)=0
73420 P(N+1,J)=0D0
73421 V(N+1,J)=0D0
73422 550 CONTINUE
73423 K(N+1,1)=32
73424 K(N+1,2)=99
73425 K(N+1,5)=NEVFM
73426 MSTU(3)=1
73427
73428C...Reset statistics on Energy-Energy Correlation.
73429 ELSEIF(MTABU.EQ.40) THEN
73430 NEVEE=0
73431 DO 560 J=1,25
73432 FE1EC(J)=0D0
73433 FE2EC(J)=0D0
73434 FE1EC(51-J)=0D0
73435 FE2EC(51-J)=0D0
73436 FE1EA(J)=0D0
73437 FE2EA(J)=0D0
73438 560 CONTINUE
73439
73440C...Find particles to include, with proper assumed mass.
73441 ELSEIF(MTABU.EQ.41) THEN
73442 NEVEE=NEVEE+1
73443 NLOW=N+MSTU(3)
73444 NUPP=NLOW
73445 ECM=0D0
73446 DO 570 I=1,N
73447 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
73448 IF(MSTU(41).GE.2) THEN
73449 KC=PYCOMP(K(I,2))
73450 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73451 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73452 & K(I,2).EQ.KSUSY1+39) GOTO 570
73453 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73454 & PYCHGE(K(I,2)).EQ.0) GOTO 570
73455 ENDIF
73456 PMR=0D0
73457 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73458 IF(MSTU(42).GE.2) PMR=P(I,5)
73459 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73460 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73461 RETURN
73462 ENDIF
73463 NUPP=NUPP+1
73464 P(NUPP,1)=P(I,1)
73465 P(NUPP,2)=P(I,2)
73466 P(NUPP,3)=P(I,3)
73467 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73468 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
73469 ECM=ECM+P(NUPP,4)
73470 570 CONTINUE
73471 IF(NUPP.EQ.NLOW) RETURN
73472
73473C...Analyze Energy-Energy Correlation in event.
73474 FAC=(2D0/ECM**2)*50D0/PARU(1)
73475 DO 580 J=1,50
73476 FEVEE(J)=0D0
73477 580 CONTINUE
73478 DO 600 I1=NLOW+2,NUPP
73479 DO 590 I2=NLOW+1,I1-1
73480 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
73481 & (P(I1,5)*P(I2,5))
73482 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
73483 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
73484 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
73485 590 CONTINUE
73486 600 CONTINUE
73487 DO 610 J=1,25
73488 FE1EC(J)=FE1EC(J)+FEVEE(J)
73489 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
73490 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
73491 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
73492 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
73493 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
73494 610 CONTINUE
73495 MSTU(62)=NUPP-NLOW
73496
73497C...Write statistics on Energy-Energy Correlation.
73498 ELSEIF(MTABU.EQ.42) THEN
73499 FAC=1D0/MAX(1,NEVEE)
73500 WRITE(MSTU(11),5700) NEVEE
73501 DO 620 J=1,25
73502 FEEC1=FAC*FE1EC(J)
73503 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
73504 FEEC2=FAC*FE1EC(51-J)
73505 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
73506 FEECA=FAC*FE1EA(J)
73507 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
73508 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
73509 & FEEC2,FEES2,FEECA,FEESA
73510 620 CONTINUE
73511
73512C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
73513 ELSEIF(MTABU.EQ.43) THEN
73514 FAC=1D0/MAX(1,NEVEE)
73515 DO 630 I=1,25
73516 K(I,1)=32
73517 K(I,2)=99
73518 K(I,3)=0
73519 K(I,4)=0
73520 K(I,5)=0
73521 P(I,1)=FAC*FE1EC(I)
73522 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
73523 P(I,2)=FAC*FE1EC(51-I)
73524 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
73525 P(I,3)=FAC*FE1EA(I)
73526 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
73527 P(I,4)=PARU(1)*(I-1)/50D0
73528 P(I,5)=PARU(1)*I/50D0
73529 V(I,4)=3.6D0*(I-1)
73530 V(I,5)=3.6D0*I
73531 630 CONTINUE
73532 N=25
73533 DO 640 J=1,5
73534 K(N+1,J)=0
73535 P(N+1,J)=0D0
73536 V(N+1,J)=0D0
73537 640 CONTINUE
73538 K(N+1,1)=32
73539 K(N+1,2)=99
73540 K(N+1,5)=NEVEE
73541 MSTU(3)=1
73542
73543C...Reset statistics on decay channels.
73544 ELSEIF(MTABU.EQ.50) THEN
73545 NEVDC=0
73546 NKFDC=0
73547 NREDC=0
73548
73549C...Identify and order flavour content of final state.
73550 ELSEIF(MTABU.EQ.51) THEN
73551 NEVDC=NEVDC+1
73552 NDS=0
73553 DO 670 I=1,N
73554 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
73555 NDS=NDS+1
73556 IF(NDS.GT.8) THEN
73557 NREDC=NREDC+1
73558 RETURN
73559 ENDIF
73560 KFM=2*IABS(K(I,2))
73561 IF(K(I,2).LT.0) KFM=KFM-1
73562 DO 650 IDS=NDS-1,1,-1
73563 IIN=IDS+1
73564 IF(KFM.LT.KFDM(IDS)) GOTO 660
73565 KFDM(IDS+1)=KFDM(IDS)
73566 650 CONTINUE
73567 IIN=1
73568 660 KFDM(IIN)=KFM
73569 670 CONTINUE
73570
73571C...Find whether old or new final state.
73572 DO 690 IDC=1,NKFDC
73573 IF(NDS.LT.KFDC(IDC,0)) THEN
73574 IKFDC=IDC
73575 GOTO 700
73576 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
73577 DO 680 I=1,NDS
73578 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
73579 IKFDC=IDC
73580 GOTO 700
73581 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
73582 GOTO 690
73583 ENDIF
73584 680 CONTINUE
73585 IKFDC=-IDC
73586 GOTO 700
73587 ENDIF
73588 690 CONTINUE
73589 IKFDC=NKFDC+1
73590 700 IF(IKFDC.LT.0) THEN
73591 IKFDC=-IKFDC
73592 ELSEIF(NKFDC.GE.200) THEN
73593 NREDC=NREDC+1
73594 RETURN
73595 ELSE
73596 DO 720 IDC=NKFDC,IKFDC,-1
73597 NPDC(IDC+1)=NPDC(IDC)
73598 DO 710 I=0,8
73599 KFDC(IDC+1,I)=KFDC(IDC,I)
73600 710 CONTINUE
73601 720 CONTINUE
73602 NKFDC=NKFDC+1
73603 KFDC(IKFDC,0)=NDS
73604 DO 730 I=1,NDS
73605 KFDC(IKFDC,I)=KFDM(I)
73606 730 CONTINUE
73607 NPDC(IKFDC)=0
73608 ENDIF
73609 NPDC(IKFDC)=NPDC(IKFDC)+1
73610
73611C...Write statistics on decay channels.
73612 ELSEIF(MTABU.EQ.52) THEN
73613 FAC=1D0/MAX(1,NEVDC)
73614 WRITE(MSTU(11),5900) NEVDC
73615 DO 750 IDC=1,NKFDC
73616 DO 740 I=1,KFDC(IDC,0)
73617 KFM=KFDC(IDC,I)
73618 KF=(KFM+1)/2
73619 IF(2*KF.NE.KFM) KF=-KF
73620 CALL PYNAME(KF,CHAU)
73621 CHDC(I)=CHAU(1:12)
73622 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
73623 740 CONTINUE
73624 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
73625 750 CONTINUE
73626 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
73627
73628C...Copy statistics on decay channels into /PYJETS/.
73629 ELSEIF(MTABU.EQ.53) THEN
73630 FAC=1D0/MAX(1,NEVDC)
73631 DO 780 IDC=1,NKFDC
73632 K(IDC,1)=32
73633 K(IDC,2)=99
73634 K(IDC,3)=0
73635 K(IDC,4)=0
73636 K(IDC,5)=KFDC(IDC,0)
73637 DO 760 J=1,5
73638 P(IDC,J)=0D0
73639 V(IDC,J)=0D0
73640 760 CONTINUE
73641 DO 770 I=1,KFDC(IDC,0)
73642 KFM=KFDC(IDC,I)
73643 KF=(KFM+1)/2
73644 IF(2*KF.NE.KFM) KF=-KF
73645 IF(I.LE.5) P(IDC,I)=KF
73646 IF(I.GE.6) V(IDC,I-5)=KF
73647 770 CONTINUE
73648 V(IDC,5)=FAC*NPDC(IDC)
73649 780 CONTINUE
73650 N=NKFDC
73651 DO 790 J=1,5
73652 K(N+1,J)=0
73653 P(N+1,J)=0D0
73654 V(N+1,J)=0D0
73655 790 CONTINUE
73656 K(N+1,1)=32
73657 K(N+1,2)=99
73658 K(N+1,5)=NEVDC
73659 V(N+1,5)=FAC*NREDC
73660 MSTU(3)=1
73661 ENDIF
73662
73663C...Format statements for output on unit MSTU(11) (default 6).
73664 5000 FORMAT(///20X,'Event statistics - initial state'/
73665 &20X,'based on an analysis of ',I6,' events'//
73666 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
73667 &'according to fragmenting system multiplicity'/
73668 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
73669 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
73670 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
73671 5200 FORMAT(///20X,'Event statistics - final state'/
73672 &20X,'based on an analysis of ',I7,' events'//
73673 &5X,'Mean primary multiplicity =',F10.4/
73674 &5X,'Mean final multiplicity =',F10.4/
73675 &5X,'Mean charged multiplicity =',F10.4//
73676 &5X,'Number of particles produced per event (directly and via ',
73677 &'decays/branchings)'/
73678 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
73679 &8X,'Total'/35X,'prim seco prim seco'/)
73680 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
73681 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
73682 &20X,'based on an analysis of ',I6,' events'//
73683 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
73684 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
73685 5500 FORMAT(10X)
73686 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
73687 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
73688 &20X,'based on an analysis of ',I6,' events'//
73689 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
73690 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
73691 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
73692 5900 FORMAT(///20X,'Decay channel analysis - final state'/
73693 &20X,'based on an analysis of ',I6,' events'//
73694 &2X,'Probability',10X,'Complete final state'/)
73695 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
73696 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
73697 &'or table overflow)')
73698
73699 RETURN
73700 END
73701
73702C*********************************************************************
73703
73704C...PYEEVT
73705C...Handles the generation of an e+e- annihilation jet event.
73706
73707 SUBROUTINE PYEEVT(KFL,ECM)
73708
73709C...Double precision and integer declarations.
73710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73711 IMPLICIT INTEGER(I-N)
73712 INTEGER PYK,PYCHGE,PYCOMP
73713C...Commonblocks.
73714 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73715 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73716 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73717 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73718
73719C...Check input parameters.
73720 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73721 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73722 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
73723 IF(MSTU(21).GE.1) RETURN
73724 ENDIF
73725 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
73726 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
73727 IF(ECM.LT.ECMMIN) THEN
73728 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
73729 IF(MSTU(21).GE.1) RETURN
73730 ENDIF
73731
73732C...Check consistency of MSTJ options set.
73733 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
73734 CALL PYERRM(6,
73735 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
73736 MSTJ(110)=1
73737 ENDIF
73738 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
73739 CALL PYERRM(6,
73740 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
73741 MSTJ(111)=0
73742 ENDIF
73743
73744C...Initialize alpha_strong and total cross-section.
73745 MSTU(111)=MSTJ(108)
73746 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73747 &MSTU(111)=1
73748 PARU(112)=PARJ(121)
73749 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73750 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
73751 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
73752 &XTOT)
73753 IF(MSTJ(116).GE.3) MSTJ(116)=1
73754 PARJ(171)=0D0
73755
73756C...Add initial e+e- to event record (documentation only).
73757 NTRY=0
73758 100 NTRY=NTRY+1
73759 IF(NTRY.GT.100) THEN
73760 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
73761 RETURN
73762 ENDIF
73763 MSTU(24)=0
73764 NC=0
73765 IF(MSTJ(115).GE.2) THEN
73766 NC=NC+2
73767 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73768 K(NC-1,1)=21
73769 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73770 K(NC,1)=21
73771 ENDIF
73772
73773C...Radiative photon (in initial state).
73774 MK=0
73775 ECMC=ECM
73776 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
73777 &THEK,PHIK,ALPK)
73778 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
73779 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
73780 NC=NC+1
73781 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
73782 K(NC,3)=MIN(MSTJ(115)/2,1)
73783 ENDIF
73784
73785C...Virtual exchange boson (gamma or Z0).
73786 IF(MSTJ(115).GE.3) THEN
73787 NC=NC+1
73788 KF=22
73789 IF(MSTJ(102).EQ.2) KF=23
73790 MSTU10=MSTU(10)
73791 MSTU(10)=1
73792 P(NC,5)=ECMC
73793 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
73794 K(NC,1)=21
73795 K(NC,3)=1
73796 MSTU(10)=MSTU10
73797 ENDIF
73798
73799C...Choice of flavour and jet configuration.
73800 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
73801 IF(KFLC.EQ.0) GOTO 100
73802 CALL PYXJET(ECMC,NJET,CUT)
73803 KFLN=21
73804 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
73805 &X12,X14)
73806 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
73807 IF(NJET.EQ.2) MSTJ(120)=1
73808
73809C...Fill jet configuration and origin.
73810 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
73811 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
73812 &ECMC)
73813 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
73814 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
73815 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73816 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
73817 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73818 IF(MSTU(24).NE.0) GOTO 100
73819 DO 110 IP=NC+1,N
73820 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
73821 110 CONTINUE
73822
73823C...Angular orientation according to matrix element.
73824 IF(MSTJ(106).EQ.1) THEN
73825 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
73826 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73827 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73828 ENDIF
73829
73830C...Rotation and boost from radiative photon.
73831 IF(MK.EQ.1) THEN
73832 DBEK=-PAK/(ECM-PAK)
73833 NMIN=NC+1-MSTJ(115)/3
73834 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
73835 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
73836 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
73837 ENDIF
73838
73839C...Generate parton shower. Rearrange along strings and check.
73840 IF(MSTJ(101).EQ.5) THEN
73841 if(parj(200).ne.1.) CALL PYSHOW(N-1,N,ECMC)
73842 if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,ECMC)
73843 MSTJ14=MSTJ(14)
73844 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73845 IF(MSTJ(105).GE.0) MSTU(28)=0
73846 CALL PYPREP(0)
73847 MSTJ(14)=MSTJ14
73848 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73849 ENDIF
73850
73851C...Fragmentation/decay generation. Information for PYTABU.
73852 IF(MSTJ(105).EQ.1) CALL PYEXEC
73853 MSTU(161)=KFLC
73854 MSTU(162)=-KFLC
73855
73856 RETURN
73857 END
73858
73859C*********************************************************************
73860
73861C...PYXTEE
73862C...Calculates total cross-section, including initial state
73863C...radiation effects.
73864
73865 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
73866
73867C...Double precision and integer declarations.
73868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73869 IMPLICIT INTEGER(I-N)
73870 INTEGER PYK,PYCHGE,PYCOMP
73871C...Commonblocks.
73872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73874 SAVE /PYDAT1/,/PYDAT2/
73875
73876C...Status, (optimized) Q^2 scale, alpha_strong.
73877 PARJ(151)=ECM
73878 MSTJ(119)=10*MSTJ(102)+KFL
73879 IF(MSTJ(111).EQ.0) THEN
73880 Q2R=ECM**2
73881 ELSEIF(MSTU(111).EQ.0) THEN
73882 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
73883 & ((33D0-2D0*MSTU(112))*PARU(111)))))
73884 Q2R=PARJ(168)*ECM**2
73885 ELSE
73886 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
73887 & (2D0*PARU(112)/ECM)**2))
73888 Q2R=PARJ(168)*ECM**2
73889 ENDIF
73890 ALSPI=PYALPS(Q2R)/PARU(1)
73891
73892C...QCD corrections factor in R.
73893 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
73894 RQCD=1D0
73895 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
73896 RQCD=1D0+ALSPI
73897 ELSEIF(MSTJ(109).EQ.0) THEN
73898 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
73899 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
73900 & LOG(PARJ(168))*ALSPI**2)
73901 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
73902 RQCD=1D0+(3D0/4D0)*ALSPI
73903 ELSE
73904 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
73905 ENDIF
73906
73907C...Calculate Z0 width if default value not acceptable.
73908 IF(MSTJ(102).GE.3) THEN
73909 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
73910 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
73911 DO 100 KFLC=5,6
73912 VQ=1D0
73913 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
73914 & (2D0*PYMASS(KFLC)/ ECM)**2))
73915 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
73916 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
73917 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
73918 100 CONTINUE
73919 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
73920 & (1D0-PARU(102)))
73921 ENDIF
73922
73923C...Calculate propagator and related constants for QFD case.
73924 POLL=1D0-PARJ(131)*PARJ(132)
73925 IF(MSTJ(102).GE.2) THEN
73926 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73927 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73928 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73929 VE=4D0*PARU(102)-1D0
73930 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
73931 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
73932 HF1I=SFI*SF1I
73933 HF1W=SFW*SF1W
73934 ENDIF
73935
73936C...Loop over different flavours: charge, velocity.
73937 RTOT=0D0
73938 RQQ=0D0
73939 RQV=0D0
73940 RVA=0D0
73941 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
73942 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
73943 MSTJ(93)=1
73944 PMQ=PYMASS(KFLC)
73945 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
73946 QF=KCHG(KFLC,1)/3D0
73947 VQ=1D0
73948 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
73949
73950C...Calculate R and sum of charges for QED or QFD case.
73951 RQQ=RQQ+3D0*QF**2*POLL
73952 IF(MSTJ(102).LE.1) THEN
73953 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
73954 ELSE
73955 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
73956 RQV=RQV-6D0*QF*VF*SF1I
73957 RVA=RVA+3D0*(VF**2+1D0)*SF1W
73958 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
73959 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
73960 ENDIF
73961 110 CONTINUE
73962 RSUM=RQQ
73963 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
73964
73965C...Calculate cross-section, including QCD corrections.
73966 PARJ(141)=RQQ
73967 PARJ(142)=RTOT
73968 PARJ(143)=RTOT*RQCD
73969 PARJ(144)=PARJ(143)
73970 PARJ(145)=PARJ(141)*86.8D0/ECM**2
73971 PARJ(146)=PARJ(142)*86.8D0/ECM**2
73972 PARJ(147)=PARJ(143)*86.8D0/ECM**2
73973 PARJ(148)=PARJ(147)
73974 PARJ(157)=RSUM*RQCD
73975 PARJ(158)=0D0
73976 PARJ(159)=0D0
73977 XTOT=PARJ(147)
73978 IF(MSTJ(107).LE.0) RETURN
73979
73980C...Virtual cross-section.
73981 XKL=PARJ(135)
73982 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
73983 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
73984 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
73985 &1.526D0*LOG(ECM**2/0.932D0)
73986
73987C...Soft and hard radiative cross-section in QED case.
73988 IF(MSTJ(102).LE.1) THEN
73989 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
73990 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
73991 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
73992
73993C...Soft and hard radiative cross-section in QFD case.
73994 ELSE
73995 SZM=1D0-(PARJ(123)/ECM)**2
73996 SZW=PARJ(123)*PARJ(124)/ECM**2
73997 PARJ(161)=-RQQ/RSUM
73998 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
73999 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
74000 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
74001 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
74002 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
74003 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
74004 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
74005 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
74006 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
74007 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
74008 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
74009 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
74010 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
74011 ENDIF
74012
74013C...Total cross-section and fraction of hard photon events.
74014 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
74015 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
74016 PARJ(144)=PARJ(157)
74017 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74018 XTOT=PARJ(148)
74019
74020 RETURN
74021 END
74022
74023C*********************************************************************
74024
74025C...PYRADK
74026C...Generates initial state photon radiation.
74027
74028 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
74029
74030C...Double precision and integer declarations.
74031 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74032 IMPLICIT INTEGER(I-N)
74033 INTEGER PYK,PYCHGE,PYCOMP
74034C...Commonblocks.
74035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74036 SAVE /PYDAT1/
74037
74038C...Function: cumulative hard photon spectrum in QFD case.
74039 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
74040 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
74041
74042C...Determine whether radiative photon or not.
74043 MK=0
74044 PAK=0D0
74045 IF(PARJ(160).LT.PYR(0)) RETURN
74046 MK=1
74047
74048C...Photon energy range. Find photon momentum in QED case.
74049 XKL=PARJ(135)
74050 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
74051 IF(MSTJ(102).LE.1) THEN
74052 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
74053 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
74054
74055C...Ditto in QFD case, by numerical inversion of integrated spectrum.
74056 ELSE
74057 SZM=1D0-(PARJ(123)/ECM)**2
74058 SZW=PARJ(123)*PARJ(124)/ECM**2
74059 FXKL=FXK(XKL)
74060 FXKU=FXK(XKU)
74061 FXKD=1D-4*(FXKU-FXKL)
74062 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
74063 NXK=0
74064 110 NXK=NXK+1
74065 XK=0.5D0*(XKL+XKU)
74066 FXKV=FXK(XK)
74067 IF(FXKV.GT.FXKR) THEN
74068 XKU=XK
74069 FXKU=FXKV
74070 ELSE
74071 XKL=XK
74072 FXKL=FXKV
74073 ENDIF
74074 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
74075 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
74076 ENDIF
74077 PAK=0.5D0*ECM*XK
74078
74079C...Photon polar and azimuthal angle.
74080 PME=2D0*(PYMASS(11)/ECM)**2
74081 120 CTHM=PME*(2D0/PME)**PYR(0)
74082 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
74083 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
74084 CTHE=1D0-CTHM
74085 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
74086 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
74087 THEK=PYANGL(CTHE,STHE)
74088 PHIK=PARU(2)*PYR(0)
74089
74090C...Rotation angle for hadronic system.
74091 SGN=1D0
74092 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
74093 &PYR(0)) SGN=-1D0
74094 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
74095 &(2D0-XK*(1D0-SGN*CTHE)))
74096
74097 RETURN
74098 END
74099
74100C*********************************************************************
74101
74102C...PYXKFL
74103C...Selects flavour for produced qqbar pair.
74104
74105 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
74106
74107C...Double precision and integer declarations.
74108 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74109 IMPLICIT INTEGER(I-N)
74110 INTEGER PYK,PYCHGE,PYCOMP
74111C...Commonblocks.
74112 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74113 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74114 SAVE /PYDAT1/,/PYDAT2/
74115
74116C...Calculate maximum weight in QED or QFD case.
74117 IF(MSTJ(102).LE.1) THEN
74118 RFMAX=4D0/9D0
74119 ELSE
74120 POLL=1D0-PARJ(131)*PARJ(132)
74121 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74122 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74123 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
74124 VE=4D0*PARU(102)-1D0
74125 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
74126 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
74127 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
74128 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
74129 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
74130 & 1D0)*HF1W)
74131 ENDIF
74132
74133C...Choose flavour. Gives charge and velocity.
74134 NTRY=0
74135 100 NTRY=NTRY+1
74136 IF(NTRY.GT.100) THEN
74137 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
74138 KFLC=0
74139 RETURN
74140 ENDIF
74141 KFLC=KFL
74142 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
74143 MSTJ(93)=1
74144 PMQ=PYMASS(KFLC)
74145 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
74146 QF=KCHG(KFLC,1)/3D0
74147 VQ=1D0
74148 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
74149
74150C...Calculate weight in QED or QFD case.
74151 IF(MSTJ(102).LE.1) THEN
74152 RF=QF**2
74153 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
74154 ELSE
74155 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
74156 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
74157 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
74158 & VQ**3*HF1W
74159 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
74160 ENDIF
74161
74162C...Weighting or new event (radiative photon). Cross-section update.
74163 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
74164 PARJ(158)=PARJ(158)+1D0
74165 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
74166 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
74167 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
74168 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
74169 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74170
74171 RETURN
74172 END
74173
74174C*********************************************************************
74175
74176C...PYXJET
74177C...Selects number of jets in matrix element approach.
74178
74179 SUBROUTINE PYXJET(ECM,NJET,CUT)
74180
74181C...Double precision and integer declarations.
74182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74183 IMPLICIT INTEGER(I-N)
74184 INTEGER PYK,PYCHGE,PYCOMP
74185C...Commonblocks.
74186 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74187 SAVE /PYDAT1/
74188C...Local array and data.
74189 DIMENSION ZHUT(5)
74190 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
74191
74192C...Trivial result for two-jets only, including parton shower.
74193 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74194 CUT=0D0
74195
74196C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
74197 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
74198 CF=4D0/3D0
74199 IF(MSTJ(109).EQ.2) CF=1D0
74200 IF(MSTJ(111).EQ.0) THEN
74201 Q2=ECM**2
74202 Q2R=ECM**2
74203 ELSEIF(MSTU(111).EQ.0) THEN
74204 PARJ(169)=MIN(1D0,PARJ(129))
74205 Q2=PARJ(169)*ECM**2
74206 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
74207 & ((33D0-2D0*MSTU(112))*PARU(111)))))
74208 Q2R=PARJ(168)*ECM**2
74209 ELSE
74210 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
74211 Q2=PARJ(169)*ECM**2
74212 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
74213 & (2D0*PARU(112)/ECM)**2))
74214 Q2R=PARJ(168)*ECM**2
74215 ENDIF
74216
74217C...alpha_strong for R and R itself.
74218 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
74219 IF(IABS(MSTJ(101)).EQ.1) THEN
74220 RQCD=1D0+ALSPI
74221 ELSEIF(MSTJ(109).EQ.0) THEN
74222 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
74223 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
74224 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
74225 ELSE
74226 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
74227 ENDIF
74228
74229C...alpha_strong for jet rate. Initial value for y cut.
74230 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74231 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
74232 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
74233 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
74234 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74235
74236C...Parametrization of first order three-jet cross-section.
74237 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
74238 PARJ(152)=0D0
74239 ELSE
74240 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
74241 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
74242 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
74243 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
74244 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
74245 & PARJ(152)=0D0
74246 ENDIF
74247
74248C...Parametrization of second order three-jet cross-section.
74249 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
74250 & CUT.GE.0.25D0) THEN
74251 PARJ(153)=0D0
74252 ELSEIF(MSTJ(110).LE.1) THEN
74253 CT=LOG(1D0/CUT-2D0)
74254 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
74255 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
74256
74257C...Interpolation in second/first order ratio for Zhu parametrization.
74258 ELSEIF(MSTJ(110).EQ.2) THEN
74259 IZA=0
74260 DO 110 IY=1,5
74261 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74262 110 CONTINUE
74263 IF(IZA.NE.0) THEN
74264 ZHURAT=ZHUT(IZA)
74265 ELSE
74266 IZ=100D0*CUT
74267 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
74268 ENDIF
74269 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
74270 ENDIF
74271
74272C...Shift in second order three-jet cross-section with optimized Q^2.
74273 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
74274 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
74275 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
74276
74277C...Parametrization of second order four-jet cross-section.
74278 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
74279 PARJ(154)=0D0
74280 ELSE
74281 CT=LOG(1D0/CUT-5D0)
74282 IF(CUT.LE.0.018D0) THEN
74283 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
74284 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
74285 & 0.4059D0*CT**2)
74286 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
74287 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74288 ELSE
74289 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
74290 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
74291 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
74292 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
74293 & 0.002093D0*CT**3)
74294 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74295 ENDIF
74296 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
74297 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
74298 ENDIF
74299
74300C...If negative three-jet rate, change y' optimization parameter.
74301 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
74302 & PARJ(169).LT.0.99D0) THEN
74303 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74304 Q2=PARJ(169)*ECM**2
74305 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74306 GOTO 100
74307 ENDIF
74308
74309C...If too high cross-section, use harder cuts, or fail.
74310 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
74311 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
74312 & PARJ(169).LT.0.99D0) THEN
74313 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74314 Q2=PARJ(169)*ECM**2
74315 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74316 GOTO 100
74317 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
74318 CALL PYERRM(26,
74319 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
74320 ENDIF
74321 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
74322 & PARJ(154))**(-1D0/3D0)
74323 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74324 GOTO 100
74325 ENDIF
74326
74327C...Scalar gluon (first order only).
74328 ELSE
74329 ALSPI=PYALPS(ECM**2)/PARU(1)
74330 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
74331 PARJ(152)=0D0
74332 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
74333 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
74334 PARJ(153)=0D0
74335 PARJ(154)=0D0
74336 ENDIF
74337
74338C...Select number of jets.
74339 PARJ(150)=CUT
74340 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74341 NJET=2
74342 ELSEIF(MSTJ(101).LE.0) THEN
74343 NJET=MIN(4,2-MSTJ(101))
74344 ELSE
74345 RNJ=PYR(0)
74346 NJET=2
74347 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
74348 IF(PARJ(154).GT.RNJ) NJET=4
74349 ENDIF
74350
74351 RETURN
74352 END
74353
74354C*********************************************************************
74355
74356C...PYX3JT
74357C...Selects the kinematical variables of three-jet events.
74358
74359 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
74360
74361C...Double precision and integer declarations.
74362 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74363 IMPLICIT INTEGER(I-N)
74364 INTEGER PYK,PYCHGE,PYCOMP
74365C...Commonblocks.
74366 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74367 SAVE /PYDAT1/
74368C...Local array.
74369 DIMENSION ZHUP(5,12)
74370
74371C...Coefficients of Zhu second order parametrization.
74372 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
74373 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
74374 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
74375 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
74376 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
74377 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
74378 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
74379 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
74380 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
74381 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
74382 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
74383
74384C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
74385 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
74386 &X**7/49D0
74387
74388C...Event type. Mass effect factors and other common constants.
74389 MSTJ(120)=2
74390 MSTJ(121)=0
74391 PMQ=PYMASS(KFL)
74392 QME=(2D0*PMQ/ECM)**2
74393 IF(MSTJ(109).NE.1) THEN
74394 CUTL=LOG(CUT)
74395 CUTD=LOG(1D0/CUT-2D0)
74396 IF(MSTJ(109).EQ.0) THEN
74397 CF=4D0/3D0
74398 CN=3D0
74399 TR=2D0
74400 WTMX=MIN(20D0,37D0-6D0*CUTD)
74401 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
74402 ELSE
74403 CF=1D0
74404 CN=0D0
74405 TR=12D0
74406 WTMX=0D0
74407 ENDIF
74408
74409C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
74410 ALS2PI=PARU(118)/PARU(2)
74411 WTOPT=0D0
74412 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
74413 & LOG(PARJ(169))*ALS2PI
74414 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
74415
74416C...Choose three-jet events in allowed region.
74417 100 NJET=3
74418 110 Y13L=CUTL+CUTD*PYR(0)
74419 Y23L=CUTL+CUTD*PYR(0)
74420 Y13=EXP(Y13L)
74421 Y23=EXP(Y23L)
74422 Y12=1D0-Y13-Y23
74423 IF(Y12.LE.CUT) GOTO 110
74424 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
74425
74426C...Second order corrections.
74427 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
74428 Y12L=LOG(Y12)
74429 Y13M=LOG(1D0-Y13)
74430 Y23M=LOG(1D0-Y23)
74431 Y12M=LOG(1D0-Y12)
74432 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
74433 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
74434 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
74435 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
74436 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
74437 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
74438 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
74439 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
74440 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
74441 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
74442 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
74443 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
74444 & TR*(2D0*CUTL/3D0-10D0/9D0)+
74445 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
74446 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
74447 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
74448 & Y13*Y23)/(Y12+Y13)**2)/WT1+
74449 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
74450 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
74451 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
74452 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
74453 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
74454 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
74455 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
74456 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74457 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74458 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
74459
74460 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
74461C...Second order corrections; Zhu parametrization of ERT.
74462 ZX=(Y23-Y13)**2
74463 ZY=1D0-Y12
74464 IZA=0
74465 DO 120 IY=1,5
74466 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74467 120 CONTINUE
74468 IF(IZA.NE.0) THEN
74469 IZ=IZA
74470 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74471 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74472 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74473 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74474 ELSE
74475 IZ=100D0*CUT
74476 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74477 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74478 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74479 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74480 IZ=IZ+1
74481 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74482 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74483 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74484 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74485 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
74486 ENDIF
74487 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74488 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74489 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
74490 ENDIF
74491
74492C...Impose mass cuts (gives two jets). For fixed jet number new try.
74493 X1=1D0-Y23
74494 X2=1D0-Y13
74495 X3=1D0-Y12
74496 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
74497 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
74498 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
74499 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
74500 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
74501
74502C...Scalar gluon model (first order only, no mass effects).
74503 ELSE
74504 130 NJET=3
74505 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
74506 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
74507 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
74508 X1=1D0-0.5D0*(X3+YD)
74509 X2=1D0-0.5D0*(X3-YD)
74510 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
74511 IF(MSTJ(102).GE.2) THEN
74512 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
74513 & X3**2*PYR(0)) NJET=2
74514 ENDIF
74515 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
74516 ENDIF
74517
74518 RETURN
74519 END
74520
74521C*********************************************************************
74522
74523C...PYX4JT
74524C...Selects the kinematical variables of four-jet events.
74525
74526 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
74527
74528C...Double precision and integer declarations.
74529 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74530 IMPLICIT INTEGER(I-N)
74531 INTEGER PYK,PYCHGE,PYCOMP
74532C...Commonblocks.
74533 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74534 SAVE /PYDAT1/
74535C...Local arrays.
74536 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
74537
74538C...Common constants. Colour factors for QCD and Abelian gluon theory.
74539 PMQ=PYMASS(KFL)
74540 QME=(2D0*PMQ/ECM)**2
74541 CT=LOG(1D0/CUT-5D0)
74542 IF(MSTJ(109).EQ.0) THEN
74543 CF=4D0/3D0
74544 CN=3D0
74545 TR=2.5D0
74546 ELSE
74547 CF=1D0
74548 CN=0D0
74549 TR=15D0
74550 ENDIF
74551
74552C...Choice of process (qqbargg or qqbarqqbar).
74553 100 NJET=4
74554 IT=1
74555 IF(PARJ(155).GT.PYR(0)) IT=2
74556 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
74557 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
74558 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
74559 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
74560 ID=1
74561
74562C...Sample the five kinematical variables (for qqgg preweighted in y34).
74563 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74564 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74565 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
74566 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
74567 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
74568 VT=PYR(0)
74569 CP=COS(PARU(1)*PYR(0))
74570 Y14=(Y134-Y34)*VT
74571 Y13=Y134-Y14-Y34
74572 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
74573 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
74574 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
74575 Y23=Y234-Y34-Y24
74576 Y12=1D0-Y134-Y23-Y24
74577 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
74578 Y123=Y12+Y13+Y23
74579 Y124=Y12+Y14+Y24
74580
74581C...Calculate matrix elements for qqgg or qqqq process.
74582 IC=0
74583 WTTOT=0D0
74584 120 IC=IC+1
74585 IF(IT.EQ.1) THEN
74586 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
74587 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
74588 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
74589 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
74590 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
74591 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
74592 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
74593 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
74594 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
74595 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
74596 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
74597 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
74598 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
74599 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
74600 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
74601 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
74602 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
74603 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
74604 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
74605 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
74606 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
74607 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
74608 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
74609 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
74610 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
74611 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
74612 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
74613 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
74614 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
74615 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
74616 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
74617 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
74618 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
74619 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
74620 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
74621 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
74622 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
74623 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
74624 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
74625 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
74626 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
74627 & CN*WTC(IC))/8D0
74628 ELSE
74629 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
74630 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
74631 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
74632 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
74633 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
74634 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
74635 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
74636 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
74637 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
74638 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
74639 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
74640 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
74641 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
74642 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
74643 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
74644 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
74645 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
74646 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
74647 ENDIF
74648
74649C...Permutations of momenta in matrix element. Weighting.
74650 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
74651 YSAV=Y13
74652 Y13=Y14
74653 Y14=YSAV
74654 YSAV=Y23
74655 Y23=Y24
74656 Y24=YSAV
74657 YSAV=Y123
74658 Y123=Y124
74659 Y124=YSAV
74660 ENDIF
74661 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
74662 YSAV=Y13
74663 Y13=Y23
74664 Y23=YSAV
74665 YSAV=Y14
74666 Y14=Y24
74667 Y24=YSAV
74668 YSAV=Y134
74669 Y134=Y234
74670 Y234=YSAV
74671 ENDIF
74672 IF(IC.LE.3) GOTO 120
74673 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
74674 IC=5
74675
74676C...qqgg events: string configuration and event type.
74677 IF(IT.EQ.1) THEN
74678 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
74679 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
74680 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
74681 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
74682 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
74683 IF(ID.EQ.2) GOTO 130
74684 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
74685 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
74686 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
74687 IF(ID.EQ.2) GOTO 130
74688 ENDIF
74689 MSTJ(120)=3
74690 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
74691 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
74692 KFLN=21
74693
74694C...Mass cuts. Kinematical variables out.
74695 IF(Y12.LE.CUT+QME) NJET=2
74696 IF(NJET.EQ.2) GOTO 150
74697 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
74698 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
74699 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
74700 X2=1D0-Y124
74701 X12=(1D0-Q12)*Y13+Q12*Y23
74702 X14=Y12-0.5D0*QME
74703 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74704
74705C...qqbarqqbar events: string configuration, choose new flavour.
74706 ELSE
74707 IF(ID.EQ.1) THEN
74708 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
74709 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
74710 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
74711 IF(WTR.LT.WTD(4)) ID=4
74712 IF(ID.GE.2) GOTO 130
74713 ENDIF
74714 MSTJ(120)=5
74715 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
74716 140 KFLN=1+INT(5D0*PYR(0))
74717 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
74718 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
74719 IF(KFLN.GT.MSTJ(104)) NJET=2
74720 PMQN=PYMASS(KFLN)
74721 QMEN=(2D0*PMQN/ECM)**2
74722
74723C...Mass cuts. Kinematical variables out.
74724 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
74725 IF(NJET.EQ.2) GOTO 150
74726 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
74727 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
74728 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
74729 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
74730 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
74731 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
74732 & Q13*Y23)
74733 X14=Y24-0.5D0*QME
74734 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
74735 & Q13*Y14)
74736 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
74737 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
74738 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74739 ENDIF
74740 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
74741
74742 RETURN
74743 END
74744
74745C*********************************************************************
74746
74747C...PYXDIF
74748C...Gives the angular orientation of events.
74749
74750 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
74751
74752C...Double precision and integer declarations.
74753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74754 IMPLICIT INTEGER(I-N)
74755 INTEGER PYK,PYCHGE,PYCOMP
74756C...Commonblocks.
74757 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74758 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74759 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74760 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74761
74762C...Charge. Factors depending on polarization for QED case.
74763 QF=KCHG(KFL,1)/3D0
74764 POLL=1D0-PARJ(131)*PARJ(132)
74765 POLD=PARJ(132)-PARJ(131)
74766 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
74767 HF1=POLL
74768 HF2=0D0
74769 HF3=PARJ(133)**2
74770 HF4=0D0
74771
74772C...Factors depending on flavour, energy and polarization for QFD case.
74773 ELSE
74774 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74775 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74776 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
74777 AE=-1D0
74778 VE=4D0*PARU(102)-1D0
74779 AF=SIGN(1D0,QF)
74780 VF=AF-4D0*QF*PARU(102)
74781 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
74782 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
74783 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
74784 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
74785 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
74786 & SFW*SFF**2*(VE**2-AE**2))
74787 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
74788 & SFF*AE
74789 ENDIF
74790
74791C...Mass factor. Differential cross-sections for two-jet events.
74792 SQ2=SQRT(2D0)
74793 QME=0D0
74794 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
74795 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
74796 IF(NJET.EQ.2) THEN
74797 SIGU=4D0*SQRT(1D0-QME)
74798 SIGL=2D0*QME*SQRT(1D0-QME)
74799 SIGT=0D0
74800 SIGI=0D0
74801 SIGA=0D0
74802 SIGP=4D0
74803
74804C...Kinematical variables. Reduce four-jet event to three-jet one.
74805 ELSE
74806 IF(NJET.EQ.3) THEN
74807 X1=2D0*P(NC+1,4)/ECM
74808 X2=2D0*P(NC+3,4)/ECM
74809 ELSE
74810 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
74811 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
74812 X1=2D0*P(NC+1,4)/ECMR
74813 X2=2D0*P(NC+4,4)/ECMR
74814 ENDIF
74815
74816C...Differential cross-sections for three-jet (or reduced four-jet).
74817 XQ=(1D0-X1)/(1D0-X2)
74818 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
74819 ST12=SQRT(1D0-CT12**2)
74820 IF(MSTJ(109).NE.1) THEN
74821 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
74822 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
74823 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
74824 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
74825 & X2)*XQ
74826 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
74827 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
74828 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
74829 SIGA=X2**2*ST12/SQ2
74830 SIGP=2D0*(X1**2-X2**2*CT12)
74831
74832C...Differential cross-sect for scalar gluons (no mass effects).
74833 ELSE
74834 X3=2D0-X1-X2
74835 XT=X2*ST12
74836 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
74837 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
74838 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
74839 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
74840 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
74841 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
74842 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
74843 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
74844 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
74845 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
74846 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
74847 ENDIF
74848 ENDIF
74849
74850C...Upper bounds for differential cross-section.
74851 HF1A=ABS(HF1)
74852 HF2A=ABS(HF2)
74853 HF3A=ABS(HF3)
74854 HF4A=ABS(HF4)
74855 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
74856 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
74857 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
74858 &2D0*HF2A*ABS(SIGP)
74859
74860C...Generate angular orientation according to differential cross-sect.
74861 100 CHI=PARU(2)*PYR(0)
74862 CTHE=2D0*PYR(0)-1D0
74863 PHI=PARU(2)*PYR(0)
74864 CCHI=COS(CHI)
74865 SCHI=SIN(CHI)
74866 C2CHI=COS(2D0*CHI)
74867 S2CHI=SIN(2D0*CHI)
74868 THE=ACOS(CTHE)
74869 STHE=SIN(THE)
74870 C2PHI=COS(2D0*(PHI-PARJ(134)))
74871 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74872 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
74873 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
74874 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
74875 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
74876 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
74877 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
74878 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
74879 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
74880
74881 RETURN
74882 END
74883
74884C*********************************************************************
74885
74886C...PYONIA
74887C...Generates Upsilon and toponium decays into three gluons
74888C...or two gluons and a photon.
74889
74890 SUBROUTINE PYONIA(KFL,ECM)
74891
74892C...Double precision and integer declarations.
74893 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74894 IMPLICIT INTEGER(I-N)
74895 INTEGER PYK,PYCHGE,PYCOMP
74896C...Commonblocks.
74897 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74898 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74899 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74901
74902C...Printout. Check input parameters.
74903 IF(MSTU(12).NE.12345) CALL PYLIST(0)
74904 IF(KFL.LT.0.OR.KFL.GT.8) THEN
74905 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
74906 IF(MSTU(21).GE.1) RETURN
74907 ENDIF
74908 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
74909 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
74910 IF(MSTU(21).GE.1) RETURN
74911 ENDIF
74912
74913C...Initial e+e- and onium state (optional).
74914 NC=0
74915 IF(MSTJ(115).GE.2) THEN
74916 NC=NC+2
74917 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
74918 K(NC-1,1)=21
74919 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
74920 K(NC,1)=21
74921 ENDIF
74922 KFLC=IABS(KFL)
74923 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
74924 NC=NC+1
74925 KF=110*KFLC+3
74926 MSTU10=MSTU(10)
74927 MSTU(10)=1
74928 P(NC,5)=ECM
74929 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
74930 K(NC,1)=21
74931 K(NC,3)=1
74932 MSTU(10)=MSTU10
74933 ENDIF
74934
74935C...Choose x1 and x2 according to matrix element.
74936 NTRY=0
74937 100 X1=PYR(0)
74938 X2=PYR(0)
74939 X3=2D0-X1-X2
74940 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
74941 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
74942 NTRY=NTRY+1
74943 NJET=3
74944 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
74945 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
74946
74947C...Photon-gluon-gluon events. Small system modifications. Jet origin.
74948 MSTU(111)=MSTJ(108)
74949 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
74950 &MSTU(111)=1
74951 PARU(112)=PARJ(121)
74952 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
74953 QF=0D0
74954 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
74955 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
74956 MK=0
74957 ECMC=ECM
74958 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
74959 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
74960 & NJET=2
74961 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
74962 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
74963 ELSE
74964 MK=1
74965 ECMC=SQRT(1D0-X1)*ECM
74966 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
74967 K(NC+1,1)=1
74968 K(NC+1,2)=22
74969 K(NC+1,4)=0
74970 K(NC+1,5)=0
74971 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
74972 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
74973 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
74974 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
74975 NJET=2
74976 IF(ECMC.LT.4D0*PARJ(127)) THEN
74977 MSTU10=MSTU(10)
74978 MSTU(10)=1
74979 P(NC+2,5)=ECMC
74980 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
74981 MSTU(10)=MSTU10
74982 NJET=0
74983 ENDIF
74984 ENDIF
74985 DO 110 IP=NC+1,N
74986 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
74987 110 CONTINUE
74988
74989C...Differential cross-sections. Upper limit for cross-section.
74990 IF(MSTJ(106).EQ.1) THEN
74991 SQ2=SQRT(2D0)
74992 HF1=1D0-PARJ(131)*PARJ(132)
74993 HF3=PARJ(133)**2
74994 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
74995 ST13=SQRT(1D0-CT13**2)
74996 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
74997 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
74998 SIGT=0.5D0*SIGL
74999 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
75000 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
75001 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
75002
75003C...Angular orientation of event.
75004 120 CHI=PARU(2)*PYR(0)
75005 CTHE=2D0*PYR(0)-1D0
75006 PHI=PARU(2)*PYR(0)
75007 CCHI=COS(CHI)
75008 SCHI=SIN(CHI)
75009 C2CHI=COS(2D0*CHI)
75010 S2CHI=SIN(2D0*CHI)
75011 THE=ACOS(CTHE)
75012 STHE=SIN(THE)
75013 C2PHI=COS(2D0*(PHI-PARJ(134)))
75014 S2PHI=SIN(2D0*(PHI-PARJ(134)))
75015 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
75016 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
75017 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
75018 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
75019 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
75020 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
75021 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
75022 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
75023 ENDIF
75024
75025C...Generate parton shower. Rearrange along strings and check.
75026 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
75027 if(parj(200).ne.1.) CALL PYSHOW(NC+MK+1,-NJET,ECMC)
75028 if(parj(200).eq.1.) CALL PYSHOWQ(NC+MK+1,-NJET,ECMC)
75029 MSTJ14=MSTJ(14)
75030 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
75031 IF(MSTJ(105).GE.0) MSTU(28)=0
75032 CALL PYPREP(0)
75033 MSTJ(14)=MSTJ14
75034 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
75035 ENDIF
75036
75037C...Generate fragmentation. Information for PYTABU:
75038 IF(MSTJ(105).EQ.1) CALL PYEXEC
75039 MSTU(161)=110*KFLC+3
75040 MSTU(162)=0
75041
75042 RETURN
75043 END
75044
75045C*********************************************************************
75046
75047C...PYBOOK
75048C...Books a histogram.
75049
75050 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
75051
75052C...Double precision declaration.
75053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75054 IMPLICIT INTEGER(I-N)
75055C...Commonblock.
75056 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75057 SAVE /PYBINS/
75058C...Local character variables.
75059 CHARACTER TITLE*(*), TITFX*60
75060
75061C...Check that input is sensible. Find initial address in memory.
75062 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75063 &'(PYBOOK:) not allowed histogram number')
75064 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
75065 &'(PYBOOK:) not allowed number of bins')
75066 IF(XL.GE.XU) CALL PYERRM(28,
75067 &'(PYBOOK:) x limits in wrong order')
75068 INDX(ID)=IHIST(4)
75069 IHIST(4)=IHIST(4)+28+NX
75070 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
75071 &'(PYBOOK:) out of histogram space')
75072 IS=INDX(ID)
75073
75074C...Store histogram size and reset contents.
75075 BIN(IS+1)=NX
75076 BIN(IS+2)=XL
75077 BIN(IS+3)=XU
75078 BIN(IS+4)=(XU-XL)/NX
75079 CALL PYNULL(ID)
75080
75081C...Store title by conversion to integer to double precision.
75082 TITFX=TITLE//' '
75083 DO 100 IT=1,20
75084 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
75085 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
75086 100 CONTINUE
75087
75088 RETURN
75089 END
75090
75091C*********************************************************************
75092
75093C...PYFILL
75094C...Fills entry in histogram.
75095
75096 SUBROUTINE PYFILL(ID,X,W)
75097
75098C...Double precision declaration.
75099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75100 IMPLICIT INTEGER(I-N)
75101C...Commonblock.
75102 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75103 SAVE /PYBINS/
75104
75105C...Find initial address in memory. Increase number of entries.
75106 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75107 &'(PYFILL:) not allowed histogram number')
75108 IS=INDX(ID)
75109 IF(IS.EQ.0) CALL PYERRM(28,
75110 &'(PYFILL:) filling unbooked histogram')
75111 BIN(IS+5)=BIN(IS+5)+1D0
75112
75113C...Find bin in x, including under/overflow, and fill.
75114 IF(X.LT.BIN(IS+2)) THEN
75115 BIN(IS+6)=BIN(IS+6)+W
75116 ELSEIF(X.GE.BIN(IS+3)) THEN
75117 BIN(IS+8)=BIN(IS+8)+W
75118 ELSE
75119 BIN(IS+7)=BIN(IS+7)+W
75120 IX=(X-BIN(IS+2))/BIN(IS+4)
75121 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
75122 BIN(IS+9+IX)=BIN(IS+9+IX)+W
75123 ENDIF
75124
75125 RETURN
75126 END
75127
75128C*********************************************************************
75129
75130C...PYFACT
75131C...Multiplies histogram contents by factor.
75132
75133 SUBROUTINE PYFACT(ID,F)
75134
75135C...Double precision declaration.
75136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75137 IMPLICIT INTEGER(I-N)
75138C...Commonblock.
75139 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75140 SAVE /PYBINS/
75141
75142C...Find initial address in memory. Multiply all contents bins.
75143 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75144 &'(PYFACT:) not allowed histogram number')
75145 IS=INDX(ID)
75146 IF(IS.EQ.0) CALL PYERRM(28,
75147 &'(PYFACT:) scaling unbooked histogram')
75148 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
75149 BIN(IX)=F*BIN(IX)
75150 100 CONTINUE
75151
75152 RETURN
75153 END
75154
75155C*********************************************************************
75156
75157C...PYOPER
75158C...Performs operations between histograms.
75159
75160 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
75161
75162C...Double precision declaration.
75163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75164 IMPLICIT INTEGER(I-N)
75165C...Commonblock.
75166 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75167 SAVE /PYBINS/
75168C...Character variable.
75169 CHARACTER OPER*(*)
75170
75171C...Find initial addresses in memory, and histogram size.
75172 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
75173 &'(PYFACT:) not allowed histogram number')
75174 IS1=INDX(ID1)
75175 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
75176 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
75177 NX=NINT(BIN(IS3+1))
75178 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
75179
75180C...Update info on number of histogram entries.
75181 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
75182 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
75183 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
75184 BIN(IS3+5)=BIN(IS1+5)
75185 ENDIF
75186
75187C...Operations on pair of histograms: addition, subtraction,
75188C...multiplication, division.
75189 IF(OPER.EQ.'+') THEN
75190 DO 100 IX=6,8+NX
75191 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
75192 100 CONTINUE
75193 ELSEIF(OPER.EQ.'-') THEN
75194 DO 110 IX=6,8+NX
75195 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
75196 110 CONTINUE
75197 ELSEIF(OPER.EQ.'*') THEN
75198 DO 120 IX=6,8+NX
75199 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
75200 120 CONTINUE
75201 ELSEIF(OPER.EQ.'/') THEN
75202 DO 130 IX=6,8+NX
75203 FA2=F2*BIN(IS2+IX)
75204 IF(ABS(FA2).LE.1D-20) THEN
75205 BIN(IS3+IX)=0D0
75206 ELSE
75207 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
75208 ENDIF
75209 130 CONTINUE
75210
75211C...Operations on single histogram: multiplication+addition,
75212C...square root+addition, logarithm+addition.
75213 ELSEIF(OPER.EQ.'A') THEN
75214 DO 140 IX=6,8+NX
75215 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
75216 140 CONTINUE
75217 ELSEIF(OPER.EQ.'S') THEN
75218 DO 150 IX=6,8+NX
75219 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
75220 150 CONTINUE
75221 ELSEIF(OPER.EQ.'L') THEN
75222 ZMIN=1D20
75223 DO 160 IX=9,8+NX
75224 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
75225 & ZMIN=0.8D0*BIN(IS1+IX)
75226 160 CONTINUE
75227 DO 170 IX=6,8+NX
75228 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
75229 170 CONTINUE
75230
75231C...Operation on two or three histograms: average and
75232C...standard deviation.
75233 ELSEIF(OPER.EQ.'M') THEN
75234 DO 180 IX=6,8+NX
75235 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75236 BIN(IS2+IX)=0D0
75237 ELSE
75238 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
75239 ENDIF
75240 IF(ID3.NE.0) THEN
75241 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75242 BIN(IS3+IX)=0D0
75243 ELSE
75244 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
75245 & BIN(IS2+IX)**2))
75246 ENDIF
75247 ENDIF
75248 BIN(IS1+IX)=F1*BIN(IS1+IX)
75249 180 CONTINUE
75250 ENDIF
75251
75252 RETURN
75253 END
75254
75255C*********************************************************************
75256
75257C...PYHIST
75258C...Prints and resets all histograms.
75259
75260 SUBROUTINE PYHIST
75261
75262C...Double precision declaration.
75263 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75264 IMPLICIT INTEGER(I-N)
75265C...Commonblock.
75266 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75267 SAVE /PYBINS/
75268
75269C...Loop over histograms, print and reset used ones.
75270 DO 100 ID=1,IHIST(1)
75271 IS=INDX(ID)
75272 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
75273 CALL PYPLOT(ID)
75274 CALL PYNULL(ID)
75275 ENDIF
75276 100 CONTINUE
75277
75278 RETURN
75279 END
75280
75281C*********************************************************************
75282
75283C...PYPLOT
75284C...Prints a histogram (but does not reset it).
75285
75286 SUBROUTINE PYPLOT(ID)
75287
75288C...Double precision declaration.
75289 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75290 IMPLICIT INTEGER(I-N)
75291C...Commonblocks.
75292 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75293 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75294 SAVE /PYDAT1/,/PYBINS/
75295C...Local arrays and character variables.
75296 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
75297 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
75298
75299C...Steps in histogram scale. Character sequence.
75300 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
75301 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
75302
75303C...Find initial address in memory; skip if empty histogram.
75304 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75305 IS=INDX(ID)
75306 IF(IS.EQ.0) RETURN
75307 IF(NINT(BIN(IS+5)).LE.0) THEN
75308 WRITE(MSTU(11),5000) ID
75309 RETURN
75310 ENDIF
75311
75312C...Number of histogram lines and x bins.
75313 LIN=IHIST(3)-18
75314 NX=NINT(BIN(IS+1))
75315
75316C...Extract title by conversion from double precision via integer.
75317 DO 100 IT=1,20
75318 IEQ=NINT(BIN(IS+8+NX+IT))
75319 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
75320 & //CHAR(MOD(IEQ,256))
75321 100 CONTINUE
75322
75323C...Find time; print title.
75324 CALL PYTIME(IDATI)
75325 IF(IDATI(1).GT.0) THEN
75326 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
75327 ELSE
75328 WRITE(MSTU(11),5200) ID, TITLE
75329 ENDIF
75330
75331C...Find minimum and maximum bin content.
75332 YMIN=BIN(IS+9)
75333 YMAX=BIN(IS+9)
75334 DO 110 IX=IS+10,IS+8+NX
75335 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
75336 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
75337 110 CONTINUE
75338
75339C...Determine scale and step size for y axis.
75340 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
75341 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
75342 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
75343 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
75344 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
75345 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
75346 DELY=DYAC(1)
75347 DO 120 IDEL=1,9
75348 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
75349 120 CONTINUE
75350 DY=DELY*10D0**IPOT
75351
75352C...Convert bin contents to integer form; fractional fill in top row.
75353 DO 130 IX=1,NX
75354 CTA=ABS(BIN(IS+8+IX))/DY
75355 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
75356 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
75357 130 CONTINUE
75358 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
75359 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
75360
75361C...Print histogram row by row.
75362 DO 150 IR=IRMA,IRMI,-1
75363 IF(IR.EQ.0) GOTO 150
75364 OUT=' '
75365 DO 140 IX=1,NX
75366 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
75367 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
75368 140 CONTINUE
75369 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
75370 150 CONTINUE
75371
75372C...Print sign and value of bin contents.
75373 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
75374 OUT=' '
75375 DO 160 IX=1,NX
75376 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
75377 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
75378 160 CONTINUE
75379 WRITE(MSTU(11),5400) OUT
75380 DO 180 IR=4,1,-1
75381 DO 170 IX=1,NX
75382 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75383 170 CONTINUE
75384 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
75385 180 CONTINUE
75386
75387C...Print sign and value of lower bin edge.
75388 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
75389 & 10.0001D0)-10
75390 OUT=' '
75391 DO 190 IX=1,NX
75392 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
75393 & OUT(IX:IX)=CHA(11)
75394 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
75395 190 CONTINUE
75396 WRITE(MSTU(11),5600) OUT
75397 DO 210 IR=3,1,-1
75398 DO 200 IX=1,NX
75399 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75400 200 CONTINUE
75401 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
75402 210 CONTINUE
75403 ENDIF
75404
75405C...Calculate and print statistics.
75406 CSUM=0D0
75407 CXSUM=0D0
75408 CXXSUM=0D0
75409 DO 220 IX=1,NX
75410 CTA=ABS(BIN(IS+8+IX))
75411 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
75412 CSUM=CSUM+CTA
75413 CXSUM=CXSUM+CTA*X
75414 CXXSUM=CXXSUM+CTA*X**2
75415 220 CONTINUE
75416 XMEAN=CXSUM/MAX(CSUM,1D-20)
75417 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
75418 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
75419 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
75420
75421C...Formats for output.
75422 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
75423 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
75424 &I2,':',I2/)
75425 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
75426 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
75427 5400 FORMAT(/8X,'Contents',3X,A100)
75428 5500 FORMAT(9X,'*10**',I2,3X,A100)
75429 5600 FORMAT(/8X,'Low edge',3X,A100)
75430 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
75431 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
75432 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
75433
75434 RETURN
75435 END
75436
75437C*********************************************************************
75438
75439C...PYNULL
75440C...Resets bin contents of a histogram.
75441
75442 SUBROUTINE PYNULL(ID)
75443
75444C...Double precision declaration.
75445 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75446 IMPLICIT INTEGER(I-N)
75447C...Commonblock.
75448 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75449 SAVE /PYBINS/
75450
75451 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75452 IS=INDX(ID)
75453 IF(IS.EQ.0) RETURN
75454 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
75455 BIN(IX)=0D0
75456 100 CONTINUE
75457
75458 RETURN
75459 END
75460
75461C*********************************************************************
75462
75463C...PYDUMP
75464C...Dumps histogram contents on file for reading by other program.
75465C...Can also read back own dump.
75466
75467 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
75468
75469C...Double precision declaration.
75470 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75471 IMPLICIT INTEGER(I-N)
75472C...Commonblock.
75473 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75474 SAVE /PYBINS/
75475C...Local arrays and character variables.
75476 DIMENSION IHI(*),ISS(100),VAL(5)
75477 CHARACTER TITLE*60,FORMAT*13
75478
75479C...Dump all histograms that have been booked,
75480C...including titles and ranges, one after the other.
75481 IF(MDUMP.EQ.1) THEN
75482
75483C...Loop over histograms and find which are wanted and booked.
75484 IF(NHI.LE.0) THEN
75485 NW=IHIST(1)
75486 ELSE
75487 NW=NHI
75488 ENDIF
75489 DO 130 IW=1,NW
75490 IF(NHI.EQ.0) THEN
75491 ID=IW
75492 ELSE
75493 ID=IHI(IW)
75494 ENDIF
75495 IS=INDX(ID)
75496 IF(IS.NE.0) THEN
75497
75498C...Write title, histogram size, filling statistics.
75499 NX=NINT(BIN(IS+1))
75500 DO 100 IT=1,20
75501 IEQ=NINT(BIN(IS+8+NX+IT))
75502 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
75503 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
75504 100 CONTINUE
75505 WRITE(LFN,5100) ID,TITLE
75506 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
75507 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
75508 & BIN(IS+8)
75509
75510
75511C...Write histogram contents, in groups of five.
75512 DO 120 IXG=1,(NX+4)/5
75513 DO 110 IXV=1,5
75514 IX=5*IXG+IXV-5
75515 IF(IX.LE.NX) THEN
75516 VAL(IXV)=BIN(IS+8+IX)
75517 ELSE
75518 VAL(IXV)=0D0
75519 ENDIF
75520 110 CONTINUE
75521 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
75522 120 CONTINUE
75523
75524C...Go to next histogram; finish.
75525 ELSEIF(NHI.GT.0) THEN
75526 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75527 ENDIF
75528 130 CONTINUE
75529
75530C...Read back in histograms dumped MDUMP=1.
75531 ELSEIF(MDUMP.EQ.2) THEN
75532
75533C...Read histogram number, title and range, and book.
75534 140 READ(LFN,5100,END=170) ID,TITLE
75535 READ(LFN,5200) NX,XL,XU
75536 CALL PYBOOK(ID,TITLE,NX,XL,XU)
75537 IS=INDX(ID)
75538
75539C...Read filling statistics.
75540 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
75541 BIN(IS+5)=DBLE(NENTRY)
75542
75543C...Read histogram contents, in groups of five.
75544 DO 160 IXG=1,(NX+4)/5
75545 READ(LFN,5400) (VAL(IXV),IXV=1,5)
75546 DO 150 IXV=1,5
75547 IX=5*IXG+IXV-5
75548 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
75549 150 CONTINUE
75550 160 CONTINUE
75551
75552C...Go to next histogram; finish.
75553 GOTO 140
75554 170 CONTINUE
75555
75556C...Write histogram contents in column format,
75557C...convenient e.g. for GNUPLOT input.
75558 ELSEIF(MDUMP.EQ.3) THEN
75559
75560C...Find addresses to wanted histograms.
75561 NSS=0
75562 IF(NHI.LE.0) THEN
75563 NW=IHIST(1)
75564 ELSE
75565 NW=NHI
75566 ENDIF
75567 DO 180 IW=1,NW
75568 IF(NHI.EQ.0) THEN
75569 ID=IW
75570 ELSE
75571 ID=IHI(IW)
75572 ENDIF
75573 IS=INDX(ID)
75574 IF(IS.NE.0.AND.NSS.LT.100) THEN
75575 NSS=NSS+1
75576 ISS(NSS)=IS
75577 ELSEIF(NSS.GE.100) THEN
75578 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
75579 ELSEIF(NHI.GT.0) THEN
75580 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75581 ENDIF
75582 180 CONTINUE
75583
75584C...Check that they have common number of x bins. Fix format.
75585 NX=NINT(BIN(ISS(1)+1))
75586 DO 190 IW=2,NSS
75587 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
75588 CALL PYERRM(8,'(PYDUMP:) different number of bins')
75589 RETURN
75590 ENDIF
75591 190 CONTINUE
75592 FORMAT='(1P,000E12.4)'
75593 WRITE(FORMAT(5:7),'(I3)') NSS+1
75594
75595C...Write histogram contents; first column x values.
75596 DO 200 IX=1,NX
75597 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
75598 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
75599 200 CONTINUE
75600
75601 ENDIF
75602
75603C...Formats for output.
75604 5100 FORMAT(I5,5X,A60)
75605 5200 FORMAT(I5,1P,2D12.4)
75606 5300 FORMAT(I12,1P,3D12.4)
75607 5400 FORMAT(1P,5D12.4)
75608
75609 RETURN
75610 END
75611
75612C*********************************************************************
75613
75614C...PYSTOP
75615C...Allows users to handle STOP statemens
75616
75617 SUBROUTINE PYSTOP(MCOD)
75618
75619C...Double precision and integer declarations.
75620 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75621 IMPLICIT INTEGER(I-N)
75622 INTEGER PYK,PYCHGE,PYCOMP
75623C...Commonblocks.
75624 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75625 SAVE /PYDAT1/
75626
75627
75628C...Write message, then stop
75629 WRITE(MSTU(11),5000) MCOD
75630 STOP
75631
75632
75633C...Formats for output.
75634 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
75635 RETURN
75636 END
75637
75638C*********************************************************************
75639
75640C...PYKCUT
75641C...Dummy routine, which the user can replace in order to make cuts on
75642C...the kinematics on the parton level before the matrix elements are
75643C...evaluated and the event is generated. The cross-section estimates
75644C...will automatically take these cuts into account, so the given
75645C...values are for the allowed phase space region only. MCUT=0 means
75646C...that the event has passed the cuts, MCUT=1 that it has failed.
75647
75648 SUBROUTINE PYKCUT(MCUT)
75649
75650C...Double precision and integer declarations.
75651 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75652 IMPLICIT INTEGER(I-N)
75653 INTEGER PYK,PYCHGE,PYCOMP
75654C...Commonblocks.
75655 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75656 COMMON/PYINT1/MINT(400),VINT(400)
75657 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75658 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75659
75660C...Set default value (accepting event) for MCUT.
75661 MCUT=0
75662
75663C...Read out subprocess number.
75664 ISUB=MINT(1)
75665 ISTSB=ISET(ISUB)
75666
75667C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75668 TAU=VINT(21)
75669 YST=VINT(22)
75670 CTH=0D0
75671 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75672 TAUP=0D0
75673 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75674
75675C...Calculate x_1, x_2, x_F.
75676 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
75677 X1=SQRT(TAU)*EXP(YST)
75678 X2=SQRT(TAU)*EXP(-YST)
75679 ELSE
75680 X1=SQRT(TAUP)*EXP(YST)
75681 X2=SQRT(TAUP)*EXP(-YST)
75682 ENDIF
75683 XF=X1-X2
75684
75685C...Calculate shat, that, uhat, p_T^2.
75686 SHAT=TAU*VINT(2)
75687 SQM3=VINT(63)
75688 SQM4=VINT(64)
75689 RM3=SQM3/SHAT
75690 RM4=SQM4/SHAT
75691 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
75692 RPTS=4D0*VINT(71)**2/SHAT
75693 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
75694 RM34=2D0*RM3*RM4
75695 RSQM=1D0+RM34
75696 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
75697 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
75698 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
75699 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
75700
75701C...Decisions by user to be put here.
75702
75703C...Stop program if this routine is ever called.
75704C...You should not copy these lines to your own routine.
75705 WRITE(MSTU(11),5000)
75706 CALL PYSTOP(6)
75707
75708C...Format for error printout.
75709 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
75710 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75711 &1X,'Execution stopped!')
75712
75713 RETURN
75714 END
75715
75716C*********************************************************************
75717
75718C...PYEVWT
75719C...Dummy routine, which the user can replace in order to multiply the
75720C...standard PYTHIA differential cross-section by a process- and
75721C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
75722C...to generation of weighted events, with weight 1/WTXS, while for
75723C...MSTP(142)=2 it corresponds to a modification of the underlying
75724C...physics.
75725
75726 SUBROUTINE PYEVWT(WTXS)
75727
75728C...Double precision and integer declarations.
75729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75730 IMPLICIT INTEGER(I-N)
75731 INTEGER PYK,PYCHGE,PYCOMP
75732C...Commonblocks.
75733 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75734 COMMON/PYINT1/MINT(400),VINT(400)
75735 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75736 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75737
75738C...Set default weight for WTXS.
75739 WTXS=1D0
75740
75741C...Read out subprocess number.
75742 ISUB=MINT(1)
75743 ISTSB=ISET(ISUB)
75744
75745C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75746 TAU=VINT(21)
75747 YST=VINT(22)
75748 CTH=0D0
75749 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75750 TAUP=0D0
75751 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75752
75753C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
75754 X1=VINT(41)
75755 X2=VINT(42)
75756 XF=X1-X2
75757 SHAT=VINT(44)
75758 THAT=VINT(45)
75759 UHAT=VINT(46)
75760 PT2=VINT(48)
75761
75762C...Modifications by user to be put here.
75763
75764C...Stop program if this routine is ever called.
75765C...You should not copy these lines to your own routine.
75766 WRITE(MSTU(11),5000)
75767 CALL PYSTOP(4)
75768
75769C...Format for error printout.
75770 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
75771 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75772 &1X,'Execution stopped!')
75773
75774 RETURN
75775 END
75776
75777C*********************************************************************
75778
75779C...UPINIT
75780C...Dummy routine, to be replaced by a user implementing external
75781C...processes. Is supposed to fill the HEPRUP commonblock with info
75782C...on incoming beams and allowed processes.
75783
75784C...New example: handles a standard Les Houches Events File.
75785
75786 SUBROUTINE UPINIT
75787
75788C...Double precision and integer declarations.
75789 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75790 IMPLICIT INTEGER(I-N)
75791
75792C...PYTHIA commonblock: only used to provide read unit MSTP(161).
75793 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75794 SAVE /PYPARS/
75795
75796C...User process initialization commonblock.
75797 INTEGER MAXPUP
75798 PARAMETER (MAXPUP=100)
75799 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75800 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75801 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75802 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75803 &LPRUP(MAXPUP)
75804 SAVE /HEPRUP/
75805
75806C...Lines to read in assumed never longer than 200 characters.
75807 PARAMETER (MAXLEN=200)
75808 CHARACTER*(MAXLEN) STRING
75809
75810C...Format for reading lines.
75811 CHARACTER*6 STRFMT
75812 STRFMT='(A000)'
75813 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75814
75815C...Loop until finds line beginning with "<init>" or "<init ".
75816 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
75817 IBEG=0
75818 110 IBEG=IBEG+1
75819C...Allow indentation.
75820 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
75821 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
75822 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
75823
75824C...Read first line of initialization info.
75825 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
75826 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75827
75828C...Read NPRUP subsequent lines with information on each process.
75829 DO 120 IPR=1,NPRUP
75830 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
75831 & XMAXUP(IPR),LPRUP(IPR)
75832 120 CONTINUE
75833 RETURN
75834
75835C...Error exit: give up if initalization does not work.
75836 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
75837 WRITE(*,*) ' Event generation will be stopped.'
75838 CALL PYSTOP(12)
75839
75840 RETURN
75841 END
75842
75843C...Old example: handles a simple Pythia 6.4 initialization file.
75844
75845c SUBROUTINE UPINIT
75846
75847C...Double precision and integer declarations.
75848c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75849c IMPLICIT INTEGER(I-N)
75850
75851C...Commonblocks.
75852c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75853c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75854c SAVE /PYDAT1/,/PYPARS/
75855
75856C...User process initialization commonblock.
75857c INTEGER MAXPUP
75858c PARAMETER (MAXPUP=100)
75859c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75860c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75861c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75862c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75863c &LPRUP(MAXPUP)
75864c SAVE /HEPRUP/
75865
75866C...Read info from file.
75867c IF(MSTP(161).GT.0) THEN
75868c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
75869c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75870c DO 100 IPR=1,NPRUP
75871c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
75872c & XMAXUP(IPR),LPRUP(IPR)
75873c 100 CONTINUE
75874c RETURN
75875C...Error or prematurely reached end of file.
75876c 110 WRITE(MSTU(11),5000)
75877c STOP
75878
75879C...Else not implemented.
75880c ELSE
75881c WRITE(MSTU(11),5100)
75882c STOP
75883c ENDIF
75884
75885C...Format for error printout.
75886c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
75887c &1X,'Execution stopped!')
75888c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
75889c &1X,'Dummy routine in PYTHIA file called instead.'/
75890c &1X,'Execution stopped!')
75891
75892c RETURN
75893c END
75894
75895C*********************************************************************
75896
75897C...UPEVNT
75898C...Dummy routine, to be replaced by a user implementing external
75899C...processes. Depending on cross section model chosen, it either has
75900C...to generate a process of the type IDPRUP requested, or pick a type
75901C...itself and generate this event. The event is to be stored in the
75902C...HEPEUP commonblock, including (often) an event weight.
75903
75904C...New example: handles a standard Les Houches Events File.
75905
75906 SUBROUTINE UPEVNT
75907
75908C...Double precision and integer declarations.
75909 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75910 IMPLICIT INTEGER(I-N)
75911
75912C...PYTHIA commonblock: only used to provide read unit MSTP(162).
75913 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75914 SAVE /PYPARS/
75915
75916C...User process event common block.
75917 INTEGER MAXNUP
75918 PARAMETER (MAXNUP=500)
75919 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75920 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75921 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75922 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75923 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75924 SAVE /HEPEUP/
75925
75926C...Lines to read in assumed never longer than 200 characters.
75927 PARAMETER (MAXLEN=200)
75928 CHARACTER*(MAXLEN) STRING
75929
75930C...Format for reading lines.
75931 CHARACTER*6 STRFMT
75932 STRFMT='(A000)'
75933 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75934
75935C...Loop until finds line beginning with "<event>" or "<event ".
75936 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
75937 IBEG=0
75938 110 IBEG=IBEG+1
75939C...Allow indentation.
75940 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
75941 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
75942 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
75943
75944C...Read first line of event info.
75945 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
75946 &AQEDUP,AQCDUP
75947
75948C...Read NUP subsequent lines with information on each particle.
75949 DO 120 I=1,NUP
75950 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
75951 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75952 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75953 120 CONTINUE
75954 RETURN
75955
75956C...Error exit, typically when no more events.
75957 130 WRITE(*,*) ' Failed to read LHEF event information.'
75958 WRITE(*,*) ' Will assume end of file has been reached.'
75959 NUP=0
75960 MSTI(51)=1
75961
75962 RETURN
75963 END
75964
75965C...Old example: handles a simple Pythia 6.4 event file.
75966
75967c SUBROUTINE UPEVNT
75968
75969C...Double precision and integer declarations.
75970c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75971c IMPLICIT INTEGER(I-N)
75972
75973C...Commonblocks.
75974c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75975c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75976c SAVE /PYDAT1/,/PYPARS/
75977
75978C...User process event common block.
75979c INTEGER MAXNUP
75980c PARAMETER (MAXNUP=500)
75981c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75982c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75983c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75984c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75985c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75986c SAVE /HEPEUP/
75987
75988C...Read info from file.
75989c IF(MSTP(162).GT.0) THEN
75990c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
75991c & AQEDUP,AQCDUP
75992c DO 100 I=1,NUP
75993c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
75994c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75995c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75996c 100 CONTINUE
75997c RETURN
75998C...Special when reached end of file or other error.
75999c 110 NUP=0
76000
76001C...Else not implemented.
76002c ELSE
76003c WRITE(MSTU(11),5000)
76004c STOP
76005c ENDIF
76006
76007C...Format for error printout.
76008c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
76009c &1X,'Dummy routine in PYTHIA file called instead.'/
76010c &1X,'Execution stopped!')
76011
76012c RETURN
76013c END
76014
76015C*********************************************************************
76016
76017C...UPVETO
76018C...Dummy routine, to be replaced by user, to veto event generation
76019C...on the parton level, after parton showers but before multiple
76020C...interactions, beam remnants and hadronization is added.
76021C...If resonances like W, Z, top, Higgs and SUSY particles are handed
76022C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
76023C...be undecayed at this stage; if decayed their decay products will
76024C...have been allowed to shower.
76025
76026C...All partons at the end of the shower phase are stored in the
76027C...HEPEVT commonblock. The interesting information is
76028C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
76029C...IDHEP(I) = the particle ID code according to PDG conventions,
76030C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
76031C...All ISTHEP entries are 1, while the rest is zeroed.
76032
76033C...The user decision is to be conveyed by the IVETO value.
76034C...IVETO = 0 : retain current event and generate in full;
76035C... = 1 : abort generation of current event and move to next.
76036
76037 SUBROUTINE UPVETO(IVETO)
76038
76039C...HEPEVT commonblock.
76040 PARAMETER (NMXHEP=4000)
76041 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
76042 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
76043 DOUBLE PRECISION PHEP,VHEP
76044 SAVE /HEPEVT/
76045
76046C...Next few lines allow you to see what info PYVETO extracted from
76047C...the full event record for the first two events.
76048C...Delete if you don't want it.
76049 DATA NLIST/0/
76050 SAVE NLIST
76051 IF(NLIST.LE.2) THEN
76052 WRITE(*,*) ' Full event record at time of UPVETO call:'
76053 CALL PYLIST(1)
76054 WRITE(*,*) ' Part of event record made available to UPVETO:'
76055 CALL PYLIST(5)
76056 NLIST=NLIST+1
76057 ENDIF
76058
76059C...Make decision here.
76060 IVETO = 0
76061
76062 RETURN
76063 END
76064
76065C*********************************************************************
76066
76067C*********************************************************************
76068
76069C...SUGRA
76070C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
76071
76072 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
76073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76074 IMPLICIT INTEGER(I-N)
76075 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
76076 INTEGER IMODL
76077C...Commonblocks.
76078 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76079 SAVE /PYDAT1/
76080
76081C...Stop program if this routine is ever called.
76082 WRITE(MSTU(11),5000)
76083 CALL PYSTOP(110)
76084
76085C...Format for error printout.
76086 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76087 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
76088 &1X,'Execution stopped!')
76089
76090 RETURN
76091 END
76092
76093C*********************************************************************
76094
76095C...VISAJE
76096C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76097
76098 FUNCTION VISAJE()
76099 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76100 IMPLICIT INTEGER(I-N)
76101 CHARACTER*40 VISAJE
76102
76103C...Commonblocks.
76104 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76105 SAVE /PYDAT1/
76106
76107C...Assign default value.
76108 VISAJE='Undefined'
76109
76110C...Stop program if this routine is ever called.
76111 WRITE(MSTU(11),5000)
76112 CALL PYSTOP(110)
76113
76114C...Format for error printout.
76115 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76116 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
76117 &1X,'Execution stopped!')
76118
76119 RETURN
76120 END
76121
76122C*********************************************************************
76123
76124C...SSMSSM
76125C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76126
76127 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
76128 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
76129 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
76130 &IDUM1,IDUM2)
76131 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76132 IMPLICIT INTEGER(I-N)
76133 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
76134 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
76135 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
76136C...Commonblocks.
76137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76138 SAVE /PYDAT1/
76139
76140C...Stop program if this routine is ever called.
76141 WRITE(MSTU(11),5000)
76142 CALL PYSTOP(110)
76143
76144C...Format for error printout.
76145 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76146 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
76147 &1X,'Execution stopped!')
76148 RETURN
76149 END
76150
76151C*********************************************************************
76152
76153C...FHSETFLAGS
76154C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76155
76156 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
76157 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76158 IMPLICIT INTEGER(I-N)
76159Cmssmpart = 4 # full MSSM [recommended]
76160Cfieldren = 0 # MSbar field ren. [strongly recommended]
76161Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
76162Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
76163Cp2approx = 0 # no approximation [recommended]
76164Clooplevel= 2 # include 2-loop corrections
76165Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
76166Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
76167
76168C...Commonblocks.
76169 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76170 SAVE /PYDAT1/
76171
76172C...Stop program if this routine is ever called.
76173 WRITE(MSTU(11),5000)
76174 CALL PYSTOP(103)
76175
76176C...Format for error printout.
76177 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76178 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
76179 &1X,'Execution stopped!')
76180 RETURN
76181 END
76182
76183C*********************************************************************
76184
76185C...FHSETPARA
76186C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76187
76188 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
76189 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
76190 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
76191 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
76192 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76193 IMPLICIT INTEGER(I-N)
76194
76195 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76196 DOUBLE COMPLEX DMU,
76197 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76198 & DM1, DM2, DM3
76199
76200C...Commonblocks.
76201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76202 SAVE /PYDAT1/
76203
76204C...Stop program if this routine is ever called.
76205 WRITE(MSTU(11),5000)
76206 CALL PYSTOP(103)
76207
76208C...Format for error printout.
76209 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76210 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76211 &1X,'Execution stopped!')
76212 RETURN
76213 END
76214
76215C*********************************************************************
76216
76217C...FHHIGGSCORR
76218C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76219
76220 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
76221 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76222 IMPLICIT INTEGER(I-N)
76223
76224C...FeynHiggs variables
76225 DOUBLE PRECISION RMHIGG(4)
76226 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76227 DOUBLE COMPLEX DMU,
76228 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76229 & DM1, DM2, DM3
76230
76231C...Commonblocks.
76232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76233 SAVE /PYDAT1/
76234
76235C...Stop program if this routine is ever called.
76236 WRITE(MSTU(11),5000)
76237 CALL PYSTOP(103)
76238
76239C...Format for error printout.
76240 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76241 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76242 &1X,'Execution stopped!')
76243 RETURN
76244 END
76245
76246C*********************************************************************
76247
76248C...PYTAUD
76249C...Dummy routine, to be replaced by user, to handle the decay of a
76250C...polarized tau lepton.
76251C...Input:
76252C...ITAU is the position where the decaying tau is stored in /PYJETS/.
76253C...IORIG is the position where the mother of the tau is stored;
76254C... is 0 when the mother is not stored.
76255C...KFORIG is the flavour of the mother of the tau;
76256C... is 0 when the mother is not known.
76257C...Note that IORIG=0 does not necessarily imply KFORIG=0;
76258C... e.g. in B hadron semileptonic decays the W propagator
76259C... is not explicitly stored but the W code is still unambiguous.
76260C...Output:
76261C...NDECAY is the number of decay products in the current tau decay.
76262C...These decay products should be added to the /PYJETS/ common block,
76263C...in positions N+1 through N+NDECAY. For each product I you must
76264C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
76265C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
76266
76267 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
76268
76269C...Double precision and integer declarations.
76270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76271 IMPLICIT INTEGER(I-N)
76272 INTEGER PYK,PYCHGE,PYCOMP
76273C...Commonblocks.
76274 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76276 SAVE /PYJETS/,/PYDAT1/
76277
76278C...Stop program if this routine is ever called.
76279C...You should not copy these lines to your own routine.
76280 NDECAY=ITAU+IORIG+KFORIG
76281 WRITE(MSTU(11),5000)
76282 CALL PYSTOP(10)
76283
76284C...Format for error printout.
76285 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
76286 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
76287 &1X,'Execution stopped!')
76288
76289 RETURN
76290 END
76291
76292C*********************************************************************
76293
76294C...PYTIME
76295C...Finds current date and time.
76296C...Since this task is not standardized in Fortran 77, the routine
76297C...is dummy, to be replaced by the user. Examples are given for
76298C...the Fortran 90 routine and DEC Fortran 77, and what to do if
76299C...you do not have access to suitable routines.
76300
76301 SUBROUTINE PYTIME(IDATI)
76302
76303C...Double precision and integer declarations.
76304 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76305 IMPLICIT INTEGER(I-N)
76306 INTEGER PYK,PYCHGE,PYCOMP
76307 CHARACTER*8 ATIME
76308C...Local array.
76309 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
76310
76311C...Example 0: if you do not have suitable routines.
76312 DO 100 J=1,6
76313 IDATI(J)=0
76314 100 CONTINUE
76315
76316C...Example 1: Fortran 90 routine.
76317C CALL DATE_AND_TIME(VALUES=IVAL)
76318C IDATI(1)=IVAL(1)
76319C IDATI(2)=IVAL(2)
76320C IDATI(3)=IVAL(3)
76321C IDATI(4)=IVAL(5)
76322C IDATI(5)=IVAL(6)
76323C IDATI(6)=IVAL(7)
76324
76325C...Example 2: DEC Fortran 77. AIX.
76326C CALL IDATE(IMON,IDAY,IYEAR)
76327C IDATI(1)=IYEAR
76328C IDATI(2)=IMON
76329C IDATI(3)=IDAY
76330C CALL ITIME(IHOUR,IMIN,ISEC)
76331C IDATI(4)=IHOUR
76332C IDATI(5)=IMIN
76333C IDATI(6)=ISEC
76334
76335C...Example 3: DEC Fortran, IRIX, IRIX64.
76336C CALL IDATE(IMON,IDAY,IYEAR)
76337C IDATI(1)=IYEAR
76338C IDATI(2)=IMON
76339C IDATI(3)=IDAY
76340C CALL TIME(ATIME)
76341C IHOUR=0
76342C IMIN=0
76343C ISEC=0
76344C READ(ATIME(1:2),'(I2)') IHOUR
76345C READ(ATIME(4:5),'(I2)') IMIN
76346C READ(ATIME(7:8),'(I2)') ISEC
76347C IDATI(4)=IHOUR
76348C IDATI(5)=IMIN
76349C IDATI(6)=ISEC
76350
76351C...Example 4: GNU LINUX libU77, SunOS.
76352C CALL IDATE(IDTEMP)
76353C IDATI(1)=IDTEMP(3)
76354C IDATI(2)=IDTEMP(2)
76355C IDATI(3)=IDTEMP(1)
76356C CALL ITIME(IDTEMP)
76357C IDATI(4)=IDTEMP(1)
76358C IDATI(5)=IDTEMP(2)
76359C IDATI(6)=IDTEMP(3)
76360
76361C...Common code to ensure right century.
76362 IDATI(1)=2000+MOD(IDATI(1),100)
76363
76364 RETURN
76365 END
76366
257b7092 76367C... ALICE interface to PDFLIB with possibility to select nuclear structure
76368C... functions.
76369C...
76370C... The MSTP array in the PYPARS common block is used to enable and
76371C... select the nuclear structure functions.
76372C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
76373C... =1: internal PYTHIA acording to MSTP(51)
76374C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
76375C... MSTP( 51) = 1000xNPGROUP+NPSET
76376C... MSTP(151) = 1000xNAGROUP+NASET
76377C... MSTP(192) : Mass number of nucleus side 1
76378C... MSTP(193) : Mass number of nucleus side 2
76379C...
76380C...
76381C... MINT(124) : side (1 or 2)
76382
76383
76384 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
76385C...
76386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76387 IMPLICIT INTEGER(I-N)
76388C...Interface to PDFLIB.
76389 COMMON/LW50512/QCDL4,QCDL5
76390 SAVE /LW50512/
76391 DOUBLE PRECISION QCDL4,QCDL5
76392 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
76393 SAVE /LW50513/
76394 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
76395C...
76396 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76397 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
76398 DOUBLE PRECISION VALUE(20)
76399 CHARACTER*20 PARM(20)
76400 write(6,*) MSTP(52)
76401 write(6,*) PARM
76402 write(6,*) VALUE
76403
76404 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
76405 PARM(5)='NATYPE'
76406 VALUE(5)=4
76407 PARM(6)='NAGROUP'
76408 VALUE(6)=MSTP(191)/1000
76409 PARM(7)='NASET'
76410 VALUE(7)=MOD(MSTP(191),1000)
76411 CALL PDFSET(PARM,VALUE,
76412 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
76413 > QCDL4,QCDL5,
76414 > XMIN,XMAX,Q2MIN,Q2MAX)
76415 IF (MSTP(194) .EQ. 0) THEN
76416 CALL SETLHAPARM("EKS98")
76417 ELSE
76418 CALL SETLHAPARM("EPS08")
76419 ENDIF
76420 ELSE
76421 write(6,*) "-> pdfset"
76422 CALL PDFSET(PARM,VALUE,
76423 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
76424 > QCDL4,QCDL5,
76425 > XMIN,XMAX,Q2MIN,Q2MAX)
76426 ENDIF
76427 write(6,*) "done"
76428 END
76429
76430
76431
76432 SUBROUTINE STRUCTM_ALICE
76433 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
76434C...
76435 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76436 IMPLICIT INTEGER(I-N)
76437 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
76438 COMMON/PYINT1/MINT(400),VINT(400)
76439C write(6,*) "structm_alice->"
76440 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
76441 A=MSTP(191+MINT(124))
76442C write(6,*) mint(124), "-> structa ", A
76443 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
76444 ELSE
76445C write(6,*) mint(124), "-> structm "
76446 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
76447 ENDIF
76448 END
76449
76450
b527e4b2 76451
76452
76453