]> git.uio.no Git - u/mrichter/AliRoot.git/blame - TUHKMgen/PYQUEN/pythia-6.4.11.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
drawCorrelation macro adapted for Toy Model (MW)
[u/mrichter/AliRoot.git] / TUHKMgen / PYQUEN / pythia-6.4.11.f
CommitLineData
b1c2e580 1C*********************************************************************
2C*********************************************************************
3C* **
4C* March 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* phone + 1 - 630 - 840 - 2270 **
34C* E-mail skands@fnal.gov **
35C* **
36C* Several parts are written by Hans-Uno Bengtsson **
37C* PYSHOW is written together with Mats Bengtsson **
38C* PYMAEL is written by Emanuel Norrbin **
39C* advanced popcorn baryon production written by Patrik Eden **
40C* code for virtual photons mainly written by Christer Friberg **
41C* code for low-mass strings mainly written by Emanuel Norrbin **
42C* Bose-Einstein code mainly written by Leif Lonnblad **
43C* CTEQ parton distributions are by the CTEQ collaboration **
44C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
45C* SaS photon parton distributions together with Gerhard Schuler **
46C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
47C* MSSM Higgs mass calculation code by M. Carena, **
48C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
49C* PYGAUS adapted from CERN library (K.S. Kolbig) **
50C* NRQCD/colour octet production of onium by S. Wolf **
51C* **
52C* The latest program version and documentation is found on WWW **
53C* http://www.thep.lu.se/~torbjorn/Pythia.html **
54C* **
55C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2007 **
56C* **
57C*********************************************************************
58C*********************************************************************
59C *
60C List of subprograms in order of appearance, with main purpose *
61C (S = subroutine, F = function, B = block data) *
62C *
63C B PYDATA to contain all default values *
64C S PYCKBD to check that BLOCK DATA has been correctly loaded *
65C S PYTEST to test the proper functioning of the package *
66C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
67C *
68C S PYINIT to administer the initialization procedure *
69C S PYEVNT to administer the generation of an event *
70C S PYEVNW ditto, for new multiple interactions scenario *
71C S PYSTAT to print cross-section and other information *
72C S PYUPEV to administer the generation of an LHA hard process *
73C S PYUPIN to provide initialization needed for LHA input *
74C S PYLHEF to produce a Les Houches Event File from run *
75C S PYINRE to initialize treatment of resonances *
76C S PYINBM to read in beam, target and frame choices *
77C S PYINKI to initialize kinematics of incoming particles *
78C S PYINPR to set up the selection of included processes *
79C S PYXTOT to give total, elastic and diffractive cross-sect. *
80C S PYMAXI to find differential cross-section maxima *
81C S PYPILE to select multiplicity of pileup events *
82C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
83C S PYGAGA to handle lepton -> lepton + gamma branchings *
84C S PYRAND to select subprocess and kinematics for event *
85C S PYSCAT to set up kinematics and colour flow of event *
86C S PYEVOL handler for pT-ordered ISR and multiple interactions *
87C S PYSSPA to simulate initial state spacelike showers *
88C S PYPTIS to do pT-ordered initial state spacelike showers *
89C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
90C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
91C S PYPTMI to do pT-ordered multiple interactions *
92C F PYFCMP to give companion quark x*f distribution *
93C F PYPCMP to calculate momentum integral for companion quarks *
94C S PYUPRE to rearranges contents of the HEPEUP commonblock *
95C S PYADSH to administrate sequential final-state showers *
96C S PYVETO to allow the generation of an event to be aborted *
97C S PYRESD to perform resonance decays *
98C S PYMULT to generate multiple interactions - old scheme *
99C S PYREMN to add on target remnants - old scheme *
100C S PYMIGN to generate multiple interactions - new scheme *
101C S PYMIHK to connect colours in mult. int. - new scheme *
102C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
103C S PYMIHG to collapse two pairs of LHA1 colour tags. *
104C S PYMIRM to add on target remnants in mult. int.- new scheme *
105C S PYFSCR to perform final state colour reconnections - -"- *
106C S PYDIFF to set up kinematics for diffractive events *
107C S PYDISG to set up kinematics, remnant and showers for DIS *
108C S PYDOCU to compute cross-sections and handle documentation *
109C S PYFRAM to perform boosts between different frames *
110C S PYWIDT to calculate full and partial widths of resonances *
111C S PYOFSH to calculate partial width into off-shell channels *
112C S PYRECO to handle colour reconnection in W+W- events *
113C S PYKLIM to calculate borders of allowed kinematical region *
114C S PYKMAP to construct value of kinematical variable *
115C S PYSIGH to calculate differential cross-sections *
116C S PYSGQC auxiliary to PYSIGH for QCD processes *
117C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
118C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
119C S PYSGHG auxiliary to PYSIGH for Higgs processes *
120C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
121C S PYSGTC auxiliary to PYSIGH for technicolor processes *
122C S PYSGEX auxiliary to PYSIGH for various exotic processes *
123C S PYPDFU to evaluate parton distributions *
124C S PYPDFL to evaluate parton distributions at low x and Q^2 *
125C S PYPDEL to evaluate electron parton distributions *
126C S PYPDGA to evaluate photon parton distributions (generic) *
127C S PYGGAM to evaluate photon parton distributions (SaS sets) *
128C S PYGVMD to evaluate VMD part of photon parton distributions *
129C S PYGANO to evaluate anomalous part of photon PDFs *
130C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
131C S PYGDIR to evaluate direct contribution to photon PDFs *
132C S PYPDPI to evaluate pion parton distributions *
133C S PYPDPR to evaluate proton parton distributions *
134C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
135C S PYGRVL to evaluate the GRV 94L proton parton distributions *
136C S PYGRVM to evaluate the GRV 94M proton parton distributions *
137C S PYGRVD to evaluate the GRV 94D proton parton distributions *
138C F PYGRVV auxiliary to the PYGRV* routines *
139C F PYGRVW auxiliary to the PYGRV* routines *
140C F PYGRVS auxiliary to the PYGRV* routines *
141C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
142C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
143C S PYPDPO to evaluate old proton parton distributions *
144C F PYHFTH to evaluate threshold factor for heavy flavour *
145C S PYSPLI to find flavours left in hadron when one removed *
146C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
147C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
148C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
149C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
150C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
151C S PYSTBH to evaluate matrix element for t + b + H processes *
152C S PYTBHB auxiliary to PYSTBH *
153C S PYTBHG auxiliary to PYSTBH *
154C S PYTBHQ auxiliary to PYSTBH *
155C F PYTBHS auxiliary to PYSTBH *
156C *
157C S PYMSIN to initialize the supersymmetry simulation *
158C S PYSLHA to interface to SUSY spectrum and decay calculators *
159C S PYAPPS to determine MSSM parameters from SUGRA input *
160C S PYSUGI to determine MSSM parameters using ISASUSY *
161C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
162C F PYRNMQ to determine running squark masses *
163C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
164C S PYINOM to calculate neutralino/chargino mass eigenstates *
165C F PYRNM3 to determine running M3, gluino mass *
166C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
167C S PYHGGM to determine Higgs mass spectrum *
168C S PYSUBH to determine Higgs masses in the MSSM *
169C S PYPOLE to determine Higgs masses in the MSSM *
170C S PYRGHM auxiliary to PYPOLE *
171C S PYGFXX auxiliary to PYRGHM *
172C F PYFINT auxiliary to PYPOLE *
173C F PYFISB auxiliary to PYFINT *
174C S PYSFDC to calculate sfermion decay partial widths *
175C S PYGLUI to calculate gluino decay partial widths *
176C S PYTBBN to calculate 3-body decay of gluino to neutralino *
177C S PYTBBC to calculate 3-body decay of gluino to chargino *
178C S PYNJDC to calculate neutralino decay partial widths *
179C S PYCJDC to calculate chargino decay partial widths *
180C F PYXXZ6 auxiliary for ino 3-body decays *
181C F PYXXGA auxiliary for ino -> ino + gamma decay *
182C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
183C F PYX2XH auxiliary for ino -> ino + Higgs decay *
184C S PYHEXT to calculate non-SM Higgs decay partial widths *
185C F PYH2XX auxiliary for H -> ino + ino decay *
186C F PYGAUS to perform Gaussian integration *
187C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
188C F PYSIMP to perform Simpson integration *
189C F PYLAMF to evaluate the lambda kinematics function *
190C S PYTBDY to perform 3-body decay of gauginos *
191C S PYTECM to calculate techni_rho/omega masses *
192C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
193C S PYCMQR auxiliary to PYEICG *
194C S PYCMQ2 auxiliary to PYEICG *
195C S PYCDIV auxiliary to PYCMQR *
196C S PYCSRT auxiliary to PYCMQR *
197C S PYTHAG auxiliary to PYCMQR *
198C S PYCBAL auxiliary to PYEICG *
199C S PYCBA2 auxiliary to PYEICG *
200C S PYCRTH auxiliary to PYEICG *
201C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
202C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
203C S PYWIDX to calculate decay widths from within PYWIDT *
204C S PYRVSF to calculate R-violating sfermion decay widths *
205C S PYRVNE to calculate R-violating neutralino decay widths *
206C S PYRVCH to calculate R-violating chargino decay widths *
207C S PYRVGL to calculate R-violating gluino decay widths *
208C F PYRVSB auxiliary to PYRVSF *
209C S PYRVGW to calculate R-Violating 3-body widths *
210C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
211C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
212C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
213C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
214C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
215C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
216C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
217C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
218C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
219C *
220C S PY1ENT to fill one entry (= parton or particle) *
221C S PY2ENT to fill two entries *
222C S PY3ENT to fill three entries *
223C S PY4ENT to fill four entries *
224C S PY2FRM to interface to generic two-fermion generator *
225C S PY4FRM to interface to generic four-fermion generator *
226C S PY6FRM to interface to generic six-fermion generator *
227C S PY4JET to generate a shower from a given 4-parton config *
228C S PY4JTW to evaluate the weight od a shower history for above *
229C S PY4JTS to set up the parton configuration for above *
230C S PYJOIN to connect entries with colour flow information *
231C S PYGIVE to fill (or query) commonblock variables *
232C S PYONOF to allow easy control of particle decay modes *
233C S PYTUNE to select a predefined 'tune' for min-bias and UE *
234C S PYEXEC to administrate fragmentation and decay chain *
235C S PYPREP to rearrange showered partons along strings *
236C S PYSTRF to do string fragmentation of jet system *
237C S PYJURF to find boost to string junction rest frame *
238C S PYINDF to do independent fragmentation of one or many jets *
239C S PYDECY to do the decay of a particle *
240C S PYDCYK to select parton and hadron flavours in decays *
241C S PYKFDI to select parton and hadron flavours in fragm *
242C S PYNMES to select number of popcorn mesons *
243C S PYKFIN to calculate falvour prod. ratios from input params. *
244C S PYPTDI to select transverse momenta in fragm *
245C S PYZDIS to select longitudinal scaling variable in fragm *
246C S PYSHOW to do m-ordered timelike parton shower evolution *
247C S PYPTFS to do pT-ordered timelike parton shower evolution *
248C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
249C S PYBOEI to include Bose-Einstein effects (crudely) *
250C S PYBESQ auxiliary to PYBOEI *
251C F PYMASS to give the mass of a particle or parton *
252C F PYMRUN to give the running MSbar mass of a quark *
253C S PYNAME to give the name of a particle or parton *
254C F PYCHGE to give three times the electric charge *
255C F PYCOMP to compress standard KF flavour code to internal KC *
256C S PYERRM to write error messages and abort faulty run *
257C F PYALEM to give the alpha_electromagnetic value *
258C F PYALPS to give the alpha_strong value *
259C F PYANGL to give the angle from known x and y components *
260C F PYR to provide a random number generator *
261C S PYRGET to save the state of the random number generator *
262C S PYRSET to set the state of the random number generator *
263C S PYROBO to rotate and/or boost an event *
264C S PYEDIT to remove unwanted entries from record *
265C S PYLIST to list event record or particle data *
266C S PYLOGO to write a logo *
267C S PYUPDA to update particle data *
268C F PYK to provide integer-valued event information *
269C F PYP to provide real-valued event information *
270C S PYSPHE to perform sphericity analysis *
271C S PYTHRU to perform thrust analysis *
272C S PYCLUS to perform three-dimensional cluster analysis *
273C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
274C S PYJMAS to give high and low jet mass of event *
275C S PYFOWO to give Fox-Wolfram moments *
276C S PYTABU to analyze events, with tabular output *
277C *
278C S PYEEVT to administrate the generation of an e+e- event *
279C S PYXTEE to give the total cross-section at given CM energy *
280C S PYRADK to generate initial state photon radiation *
281C S PYXKFL to select flavour of primary qqbar pair *
282C S PYXJET to select (matrix element) jet multiplicity *
283C S PYX3JT to select kinematics of three-jet event *
284C S PYX4JT to select kinematics of four-jet event *
285C S PYXDIF to select angular orientation of event *
286C S PYONIA to perform generation of onium decay to gluons *
287C *
288C S PYBOOK to book a histogram *
289C S PYFILL to fill an entry in a histogram *
290C S PYFACT to multiply histogram contents by a factor *
291C S PYOPER to perform operations between histograms *
292C S PYHIST to print and reset all histograms *
293C S PYPLOT to print a single histogram *
294C S PYNULL to reset contents of a single histogram *
295C S PYDUMP to dump histogram contents onto a file *
296C *
297C S PYKCUT dummy routine for user kinematical cuts *
298C S PYEVWT dummy routine for weighting events *
299C S UPINIT dummy routine to initialize user processes *
300C S UPEVNT dummy routine to generate a user process event *
301C S UPVETO dummy routine to abort event at parton level *
302C S PDFSET dummy routine to be removed when using PDFLIB *
303C S STRUCTM dummy routine to be removed when using PDFLIB *
304C S STRUCTP dummy routine to be removed when using PDFLIB *
305C S SUGRA dummy routine to be removed when linking with ISAJET *
306C F VISAJE dummy functn. to be removed when linking with ISAJET *
307C S SSMSSM dummy routine to be removed when linking with ISAJET *
308C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
309C S FHSETPARA dummy routine -"- FEYNHIGGS *
310C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
311C S PYTAUD dummy routine for interface to tau decay libraries *
312C S PYTIME dummy routine for giving date and time *
313C *
314C*********************************************************************
315
316C...PYDATA
317C...Default values for switches and parameters,
318C...and particle, decay and process data.
319
320 BLOCK DATA PYDATA
321
322C...Double precision and integer declarations.
323 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
324 IMPLICIT INTEGER(I-N)
325 INTEGER PYK,PYCHGE,PYCOMP
326C...Commonblocks.
327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
329 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
330 COMMON/PYDAT4/CHAF(500,2)
331 CHARACTER CHAF*16
332 COMMON/PYDATR/MRPY(6),RRPY(100)
333 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
334 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
335 COMMON/PYINT1/MINT(400),VINT(400)
336 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
337 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
338 COMMON/PYINT4/MWID(500),WIDS(500,5)
339 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
340 COMMON/PYINT6/PROC(0:500)
341 CHARACTER PROC*28
342 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
343 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
344 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
345 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
346 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
347 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
348 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
349 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
350 & AU(3,3),AD(3,3),AE(3,3)
351 COMMON/PYLH3C/CPRO(2),CVER(2)
352 CHARACTER CPRO*12,CVER*12
353 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
354 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
355 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,
356 &/PYBINS/,/PYLH3P/,/PYLH3C/
357
358C...PYDAT1, containing status codes and most parameters.
359 DATA MSTU/
360 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
361 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
362 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
363 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
364 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
365 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
366 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
367 7 30*0,
368 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
369 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
370 & 80*0/
371 DATA (PARU(I),I=1,100)/
372 & 3.141592653589793D0, 6.283185307179586D0,
373 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
374 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
375 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
376 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
377 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
378 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
379 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
380 6 40*0D0/
381 DATA (PARU(I),I=101,200)/
382 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
383 & 0D0, 0D0, 0D0, 0D0, 0D0,
384 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
385 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
386 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
387 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
388 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
389 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
390 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
391 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
392 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
393 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
394 DATA MSTJ/
395 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
396 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
397 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
398 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
399 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
400 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
401 6 40*0,
402 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
403 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
404 2 80*0/
405 DATA PARJ/
406 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
407 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
408 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
409 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
410 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
411 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
412 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
413 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
414 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
415 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
416 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
417 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
418 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
419 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
420 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
421 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
422 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
423 4 10*0D0,
424 5 10*0D0,
425 6 10*0D0,
426 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
427 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
428 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
429 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
430 9 5*0D0/
431
432C...PYDAT2, with particle data and flavour treatment parameters.
433 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
434 &-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,
435 &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,
436 &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,
437 &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,
438 &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,
439 &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,
440 &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,
441 &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,
442 &139*0/
443 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
444 &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,
445 &-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,
446 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,133*0/
447 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
448 &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,
449 &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,
450 &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,139*0/
451 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
452 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
453 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
454 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
455 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
456 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
457 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
458 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
459 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
460 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
461 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
462 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
463 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
464 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
465 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
466 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
467 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
468 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
469 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
470 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
471 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
472 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
473 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
474 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
475 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
476 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
477 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
478 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
479 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
480 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
481 &133*0/
482 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
483 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
484 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
485 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
486 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
487 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
488 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
489 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
490 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
491 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
492 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
493 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
494 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
495 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
496 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
497 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
498 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
499 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
500 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
501 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
502 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
503 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
504 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
505 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
506 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
507 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
508 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
509 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
510 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
511 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
512 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
513 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
514 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
515 &3*9.5D0,133*0D0/
516 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
517 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
518 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
519 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
520 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
521 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
522 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
523 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
524 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
525 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
526 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
527 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
528 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
529 &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
530 &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
531 &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
532 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
533 &7*0D0,6*0.01D0,133*0D0/
534 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
535 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
536 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
537 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
538 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
539 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
540 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
541 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
542 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
543 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
544 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
545 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
546 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
547 &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
548 &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
549 &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
550 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
551 &8.80013D0,13*0D0,133*0D0/
552 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
553 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
554 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
555 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
556 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
557 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
558 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
559 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,118*0D0,133*0D0/
560 DATA PARF/
561 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
562 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
563 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
564 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
565 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
566 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
567 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
568 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
569 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
570 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
571 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
572 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
573 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
574 3 60*0D0,
575 4 0.2D0, 0.5D0, 8*0D0,
576 5 1800*0D0/
577 DATA ((VCKM(I,J),J=1,4),I=1,4)/
578 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
579 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
580 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
581 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
582
583C...PYDAT3, with particle decay parameters and data.
584
585 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
586 &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,
587 &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,
588 &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,6*1,133*0/
589 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
590 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
591 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
592 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
593 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
594 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
595 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
596 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
597 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
598 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
599 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
600 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
601 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
602 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
603 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
604 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
605 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
606 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
607 &3924,0,3960,0,3996,4004,4012,4020,4023,4047,4073,4097,4103,4110,
608 &4117,4124,4130,4136,4145,4149,4153,4156,4158,4178,4200,4222,4244/
609 DATA (MDCY(I,2),I= 352, 500)/4259,4271,4278,7*0,4285,4286,4287,
610 &4288,4289,4290,133*0/
611 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
612 &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,
613 &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,
614 &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,
615 &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,
616 &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,
617 &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,
618 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
619 &28,49,28,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,20,
620 &3*22,15,12,2*7,7*0,6*1,133*0/
621 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
622 &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,
623 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,85*1,
624 &2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,200*1,2*-1,2*1,-1,
625 &1249*1,2*-1,377*1,2*-1,1868*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,
626 &5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,67*1,2*-1,6*1,2*-1,117*1,3710*0/
627 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
628 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
629 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
630 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
631 &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,
632 &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,
633 &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,
634 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
635 &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,
636 &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,
637 &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,
638 &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,
639 &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,
640 &3*0,6*32,3*0,4*32,3*0,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0,
641 &46*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,9*32,17*0,6*51,3710*0/
642 DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0,
643 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
644 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
645 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
646 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
647 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
648 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
649 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
650 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
651 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
652 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
653 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
654 &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0,
655 &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
656 &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0,
657 &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0,
658 &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0,
659 &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0,
660 &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0,
661 &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
662 DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
663 &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
664 &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
665 &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
666 &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0,
667 &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,
668 &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
669 &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0,
670 &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0,
671 &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0,
672 &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0,
673 &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0,
674 &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0,
675 &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0,
676 &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0,
677 &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0,
678 &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0,
679 &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0,
680 &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0,
681 &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/
682 DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
683 &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0,
684 &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0,
685 &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0,
686 &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0,
687 &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0,
688 &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0,
689 &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0,
690 &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0,
691 &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0,
692 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0,
693 &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0,
694 &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0,
695 &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0,
696 &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0,
697 &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0,
698 &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0,
699 &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0,
700 &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0,
701 &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/
702 DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
703 &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0,
704 &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0,
705 &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0,
706 &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,
707 &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
708 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
709 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
710 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
711 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
712 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
713 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
714 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,
715 &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,
716 &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,
717 &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,
718 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,
719 &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,
720 &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0,
721 &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/
722 DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0,
723 &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,
724 &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,
725 &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,
726 &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,
727 &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,
728 &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0,
729 &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0,
730 &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0,
731 &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0,
732 &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0,
733 &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0,
734 &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0,
735 &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0,
736 &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,
737 &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,
738 &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,
739 &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0,
740 &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0,
741 &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/
742 DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0,
743 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,
744 &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,
745 &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0,
746 &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
747 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
748 &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,
749 &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
750 &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,
751 &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
752 &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
753 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
754 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
755 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
756 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
757 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
758 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
759 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
760 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
761 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/
762 DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0,
763 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
764 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
765 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
766 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
767 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
768 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
769 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
770 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,
771 &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,
772 &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,
773 &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,
774 &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,
775 &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0,
776 &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,
777 &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,
778 &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,
779 &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,
780 &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,
781 &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/
782 DATA (BRAT(I) ,I=1581,4149)/0.008D0,0.024D0,0.008D0,0.024D0,
783 &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,
784 &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
785 &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
786 &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
787 &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
788 &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
789 &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
790 &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
791 &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
792 &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
793 &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
794 &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
795 &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
796 &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
797 &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
798 &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
799 &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
800 &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
801 &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
802 DATA (BRAT(I) ,I=4150,4280)/0.021617D0,0.030018D0,0.098466D0,
803 &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0,
804 &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0,
805 &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0.19874D0,0.010204D0,
806 &0.000003D0,0.010205D0,0.198356D0,0.000151D0,0.000006D0,
807 &0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,0.010205D0,
808 &0.198356D0,0.000151D0,0.000006D0,0.000367D0,0.081967D0,4*0D0,
809 &0.198776D0,0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,
810 &0.000006D0,0.000367D0,0.081893D0,0.198776D0,0.010206D0,
811 &0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,0.000367D0,
812 &0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0,
813 &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,
814 &0.199344D0,0.010234D0,0.000003D0,0.010236D0,0.198928D0,
815 &0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0,0.184738D0,
816 &0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0,0.022902D0,
817 &0.008429D0,0.015602D0,0.022902D0,0.008429D0,0.015602D0,
818 &0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0,0.000008D0,
819 &0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0,0.27911D0,
820 &2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,
821 &0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0/
822 DATA (BRAT(I) ,I=4281,8000)/0.090428D0,0.001808D0,0.81372D0,0D0,
823 &6*1D0,3710*0D0/
824 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
825 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
826 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
827 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
828 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
829 &-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,
830 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
831 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
832 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
833 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
834 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
835 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
836 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
837 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
838 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
839 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
840 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
841 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
842 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
843 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
844 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
845 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
846 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
847 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
848 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
849 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
850 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
851 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
852 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
853 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
854 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
855 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
856 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
857 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
858 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
859 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
860 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
861 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
862 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
863 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
864 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
865 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
866 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
867 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
868 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
869 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
870 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
871 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
872 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
873 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
874 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
875 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
876 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
877 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
878 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
879 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
880 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
881 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
882 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
883 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
884 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
885 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
886 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
887 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
888 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
889 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
890 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
891 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
892 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
893 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
894 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
895 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
896 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
897 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
898 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
899 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
900 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
901 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
902 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
903 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
904 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
905 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
906 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
907 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
908 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
909 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
910 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
911 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
912 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
913 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
914 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
915 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
916 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
917 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
918 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
919 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
920 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
921 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
922 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
923 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
924 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
925 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
926 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
927 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
928 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
929 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
930 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
931 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
932 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
933 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
934 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
935 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
936 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
937 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
938 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
939 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
940 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
941 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
942 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
943 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
944 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
945 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
946 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
947 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
948 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
949 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
950 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
951 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
952 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
953 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
954 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
955 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
956 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
957 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
958 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
959 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
960 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
961 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
962 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
963 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
964 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
965 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
966 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
967 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
968 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
969 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
970 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
971 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
972 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
973 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
974 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
975 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
976 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
977 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
978 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
979 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
980 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
981 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
982 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
983 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
984 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
985 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
986 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
987 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
988 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
989 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
990 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
991 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
992 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
993 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
994 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
995 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
996 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
997 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
998 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
999 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1000 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1001 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1002 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1003 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1004 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1005 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1006 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1007 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1008 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1009 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1010 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1011 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1012 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1013 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1014 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1015 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1016 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1017 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1018 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1019 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1020 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1021 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1022 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1023 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1024 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1025 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1026 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1027 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1028 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1029 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1030 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1031 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1032 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1033 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1034 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1035 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1036 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1037 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1038 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1039 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1040 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1041 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1042 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1043 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1044 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1045 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1046 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1047 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1048 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1049 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1050 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1051 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1052 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1053 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1054 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1055 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1056 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1057 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1058 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1059 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1060 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1061 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1062 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1063 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1064 DATA (KFDP(I,1),I=3783,4127)/1000039,1000024,1000037,1000022,
1065 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1066 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1067 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1068 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1069 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1070 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1071 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1072 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1073 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1074 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1075 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1076 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1077 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1078 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1079 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1080 &2*24,2*3000211,2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1081 &2*24,3*3000211,24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,22,
1082 &23,24,3000211,24,3000211,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1083 &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/
1084 DATA (KFDP(I,1),I=4128,8000)/5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,
1085 &3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2,3,4,
1086 &5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,9*11,9*-11,2*11,
1087 &2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5,6,11,
1088 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,
1089 &-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,
1090 &3710*0/
1091 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,
1092 &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,
1093 &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,
1094 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1095 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1096 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1097 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1098 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1099 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1100 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1101 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1102 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1103 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1104 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1105 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1106 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1107 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1108 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1109 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1110 &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/
1111 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1112 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1113 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1114 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1115 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1116 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1117 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1118 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1119 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1120 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1121 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1122 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1123 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1124 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1125 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1126 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1127 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1128 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1129 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1130 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1131 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1132 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1133 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1134 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1135 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1136 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1137 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1138 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1139 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1140 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1141 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1142 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1143 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1144 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1145 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1146 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1147 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1148 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1149 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1150 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1151 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1152 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1153 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1154 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1155 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1156 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1157 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1158 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1159 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1160 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1161 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1162 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1163 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1164 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1165 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1166 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1167 &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,
1168 &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,
1169 &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,
1170 &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/
1171 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1172 &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,
1173 &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,
1174 &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,
1175 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1176 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1177 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1178 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1179 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1180 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1181 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1182 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1183 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1184 &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,
1185 &-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,
1186 &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,
1187 &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,
1188 &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,
1189 &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,
1190 &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/
1191 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1192 &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,
1193 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1194 &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,
1195 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1196 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1197 &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,
1198 &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,
1199 &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,
1200 &-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,
1201 &-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,
1202 &-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,
1203 &-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,
1204 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1205 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1206 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1207 &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,
1208 &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,
1209 &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,
1210 &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/
1211 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1212 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1213 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1214 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1215 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1216 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1217 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1218 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1219 &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,
1220 &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,
1221 &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,
1222 &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,
1223 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1224 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1225 &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,
1226 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1227 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1228 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1229 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1230 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1231 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1232 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1233 &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,
1234 &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,
1235 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1236 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1237 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1238 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1239 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1240 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1241 &-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,
1242 &-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,
1243 &-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,
1244 &-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,
1245 &-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,
1246 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1247 &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,
1248 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1249 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1250 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1251 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1252 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1253 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1254 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1255 &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,
1256 &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,
1257 &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,
1258 &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,
1259 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1260 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1261 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1262 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1263 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1264 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1265 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1266 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1267 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1268 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1269 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1270 &-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/
1271 DATA (KFDP(I,2),I=3670,4136)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1272 &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,
1273 &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,
1274 &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,
1275 &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,
1276 &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,
1277 &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,
1278 &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,
1279 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1280 &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,
1281 &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,
1282 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1283 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1284 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-24,-3000211,-24,-3000211,
1285 &3000111,3000221,3000111,3000221,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
1286 &-13,-14,-15,-16,-17,-18,23,3000111,23,3000111,22,3000221,2,4,6,8,
1287 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,
1288 &2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1289 &-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,
1290 &21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,-1/
1291 DATA (KFDP(I,2),I=4137,8000)/-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1292 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1293 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1294 &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,
1295 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16,
1296 &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15,
1297 &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,6*21,3710*0/
1298 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1299 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1300 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1301 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1302 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1303 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1304 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1305 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1306 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1307 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1308 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1309 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1310 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1311 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1312 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1313 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1314 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1315 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1316 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1317 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1318 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1319 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1320 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1321 &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,
1322 &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,
1323 &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,
1324 &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,
1325 &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,
1326 &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,
1327 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1328 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1329 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1330 &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,
1331 &-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,
1332 &-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,
1333 &-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,
1334 &-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,
1335 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1336 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1337 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1338 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1339 &-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,
1340 &-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,
1341 &-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,
1342 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1343 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1344 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1345 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1346 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1347 &-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,
1348 &-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,
1349 &-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,
1350 &-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,
1351 &-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,
1352 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1353 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1354 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1355 &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,
1356 &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,
1357 &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/
1358 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1359 &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,
1360 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1361 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1362 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1363 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1364 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1365 &-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,
1366 &-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,
1367 &-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,
1368 &-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,
1369 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1370 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1371 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1372 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1373 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1374 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1375 &-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,
1376 &-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,
1377 &-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/
1378 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1379 &-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,
1380 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1381 &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,
1382 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1383 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1384 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1385 &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,
1386 &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,
1387 &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,
1388 &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,
1389 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,169*0,2,4,6,2,
1390 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,
1391 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,
1392 &4,6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3757*0/
1393 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1394 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1395 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1396 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1397 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1398 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1399 &-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,
1400 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1401 &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,
1402 &162*81,31*0,-211,111,6516*0/
1403 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1404 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1405 &3*111,-211,111,7193*0/
1406
1407C...PYDAT4, with particle names (character strings).
1408
1409 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1410 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1411 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1412 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1413 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1414 &'junction',' ','system','cluster','string','indep.','CMshower',
1415 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1416 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1417 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1418 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1419 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1420 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1421 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1422 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1423 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1424 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1425 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1426 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1427 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1428 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1429 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1430 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1431 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1432 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1433 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1434 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1435 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1436 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1437 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1438 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1439 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1440 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1441 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1442 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1443 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1444 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1445 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1446 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1447 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1448 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1449 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1450 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1451 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1452 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1453 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1454 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1455 &'bb~[3S18]','bb~[1S08]','bb~[3P08]',133*' '/
1456 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1457 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1458 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1459 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1460 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1461 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1462 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1463 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1464 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1465 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1466 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1467 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1468 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1469 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1470 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1471 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1472 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1473 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1474 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1475 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1476 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1477 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1478 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1479 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1480 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1481 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1482 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1483 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1484 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1485 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1486 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1487 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1488 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1489 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1490 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1491 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1492 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1493 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1494 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1495 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1496 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1497 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1498 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1499 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/
1500
1501C...PYDATR, with initial values for the random number generator.
1502 DATA MRPY/19780503,0,0,97,33,0/
1503
1504C...Default values for allowed processes and kinematics constraints.
1505 DATA MSEL/1/
1506 DATA MSUB/500*0/
1507 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1508 &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,
1509 &6*1,4*0,4*1,16*0/
1510 DATA CKIN/
1511 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1512 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1513 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1514 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1515 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1516 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1517 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1518 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1519 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1520 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1521 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1522 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1523 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1524 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1525 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1526 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1527 8 120*0D0/
1528
1529C...Default values for main switches and parameters. Reset information.
1530 DATA (MSTP(I),I=1,100)/
1531 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1532 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1533 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1534 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1535 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1536 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1537 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1538 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1539 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1540 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1541 DATA (MSTP(I),I=101,200)/
1542 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1543 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1544 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1545 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1546 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1547 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1548 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1549 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1550 8 6, 411, 2007, 03, 30, 0, 0, 0, 0, 0,
1551 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1552 DATA (PARP(I),I=1,100)/
1553 & 0.25D0, 10D0, 8*0D0,
1554 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1555 2 10*0D0,
1556 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1557 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1558 5 10*0D0,
1559 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1560 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1561 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1562 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
1563 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1564 DATA (PARP(I),I=101,200)/
1565 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1566 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1567 2 1.0D0, 0.4D0, 8*0D0,
1568 3 0.01D0, 9*0D0,
1569 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1570 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1571 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1572 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1573 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1574 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1575 8 0.3D0, 0.64D0,
1576 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1577 DATA MSTI/200*0/
1578 DATA PARI/200*0D0/
1579 DATA MINT/400*0/
1580 DATA VINT/400*0D0/
1581
1582C...Constants for the generation of the various processes.
1583 DATA (ISET(I),I=1,100)/
1584 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1585 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1586 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1587 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1588 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1589 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1590 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1591 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1592 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1593 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1594 DATA (ISET(I),I=101,200)/
1595 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1596 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1597 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1598 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1599 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1600 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1601 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1602 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1603 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1604 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1605 DATA (ISET(I),I=201,300)/
1606 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1607 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1608 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1609 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1610 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1611 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1612 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1613 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1614 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1615 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1616 DATA (ISET(I),I=301,500)/
1617 & 2, 39*-2,
1618 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1619 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1620 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1621 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1,
1622 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1623 9 1, 1, 2, 2, 2, 5*-2,
1624 & 5, 5, 18*-2,
1625 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1626 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1627 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1628 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1629 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1630 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1631 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1632 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1633 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1634 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1635 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1636 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1637 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1638 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1639 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1640 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1641 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1642 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1643 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1644 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1645 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1646 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1647 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1648 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1649 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1650 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1651 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1652 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1653 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1654 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1655 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1656 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1657 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1658 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1659 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1660 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1661 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1662 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1663 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1664 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1665 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1666 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1667 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1668 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1669 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1670 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1671 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1672 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1673 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1674 & 1000011, 1000011, 2000011, 2000011, 1000011,
1675 & 2000011, 1000013, 1000013, 2000013, 2000013,
1676 & 1000013, 2000013, 1000015, 1000015, 2000015,
1677 & 2000015, 1000015, 2000015, 1000011, 1000012,
1678 1 1000015, 1000016, 2000015, 1000016, 1000012,
1679 1 1000012, 1000016, 1000016, 0, 0,
1680 1 1000022, 1000022, 1000023, 1000023, 1000025,
1681 1 1000025, 1000035, 1000035, 1000022, 1000023,
1682 2 1000022, 1000025, 1000022, 1000035, 1000023,
1683 2 1000025, 1000023, 1000035, 1000025, 1000035,
1684 2 1000024, 1000024, 1000037, 1000037, 1000024,
1685 2 1000037, 1000022, 1000024, 1000023, 1000024,
1686 3 1000025, 1000024, 1000035, 1000024, 1000022,
1687 3 1000037, 1000023, 1000037, 1000025, 1000037,
1688 3 1000035, 1000037, 1000021, 1000022, 1000021,
1689 3 1000023, 1000021, 1000025, 1000021, 1000035/
1690 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1691 4 1000021, 1000024, 1000021, 1000037, 1000021,
1692 4 1000021, 1000021, 1000021, 0, 0,
1693 4 1000002, 1000022, 2000002, 1000022, 1000002,
1694 4 1000023, 2000002, 1000023, 1000002, 1000025,
1695 5 2000002, 1000025, 1000002, 1000035, 2000002,
1696 5 1000035, 1000001, 1000024, 2000005, 1000024,
1697 5 1000001, 1000037, 2000005, 1000037, 1000002,
1698 5 1000021, 2000002, 1000021, 0, 0,
1699 6 1000006, 1000006, 2000006, 2000006, 1000006,
1700 6 2000006, 1000006, 1000006, 2000006, 2000006,
1701 6 0, 0, 0, 0, 0,
1702 6 0, 0, 0, 0, 0,
1703 7 1000002, 1000002, 2000002, 2000002, 1000002,
1704 7 2000002, 1000002, 1000002, 2000002, 2000002,
1705 7 1000002, 2000002, 1000002, 1000002, 2000002,
1706 7 2000002, 1000002, 1000002, 2000002, 2000002/
1707 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1708 8 1000005, 1000002, 2000005, 2000002, 1000005,
1709 8 2000002, 1000005, 1000002, 2000005, 2000002,
1710 8 1000005, 2000002, 1000005, 1000005, 2000005,
1711 8 2000005, 1000005, 1000005, 2000005, 2000005,
1712 9 1000005, 1000005, 2000005, 2000005, 1000005,
1713 9 2000005, 1000005, 1000021, 2000005, 1000021,
1714 9 1000005, 2000005, 37, 25, 37,
1715 9 35, 36, 25, 36, 35,
1716 & 37, 37, 78*0,
1717 4 9900041, 0, 9900042, 0, 9900041,
1718 4 11, 9900042, 11, 9900041, 13,
1719 4 9900042, 13, 9900041, 15, 9900042,
1720 4 15, 9900041, 9900041, 9900042, 9900042/
1721 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1722 5 9900041, 0, 9900042, 0, 9900023,
1723 5 0, 9900024, 0, 0, 0,
1724 5 0, 0, 0, 0, 0,
1725 5 0, 0, 0, 0, 0,
1726 6 24, 24, 24, 3000211, 3000211,
1727 6 3000211, 22, 3000111, 22, 3000221,
1728 6 23, 3000111, 23, 3000221, 24,
1729 6 3000211, 0, 0, 24, 23,
1730 7 24, 3000111, 3000211, 23, 3000211,
1731 7 3000111, 22, 3000211, 23, 3000211,
1732 7 24, 3000111, 24, 3000221, 0,
1733 7 0, 0, 0, 0, 0,
1734 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1735 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1736 9 5000039, 0, 5000039, 0, 21,
1737 9 5000039, 0, 5000039, 21, 5000039,
1738 9 10*0/
1739 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1740 & 37, 6, 37, 6, 36*0,
1741 2 443, 21, 9900443, 21, 9900441,
1742 2 21, 9910441, 21, 0, 9900443,
1743 2 0, 9900441, 0, 9910441, 21,
1744 2 9900443, 21, 9900441, 21, 9910441,
1745 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1746 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1747 6 553, 21, 9900553, 21, 9900551,
1748 6 21, 9910551, 21, 0, 9900553,
1749 6 0, 9900551, 0, 9910551, 21,
1750 6 9900553, 21, 9900551, 21, 9910551,
1751 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1752 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1753 DATA COEF/10000*0D0/
1754 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1755 &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,
1756 &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,
1757 &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,
1758 &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,
1759 &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,
1760 &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,
1761 &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,
1762 &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,
1763 &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,
1764 &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/
1765
1766C...Treatment of resonances.
1767 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1768 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,133*0/
1769
1770C...Character constants: name of processes.
1771 DATA PROC(0)/ 'All included subprocesses '/
1772 DATA (PROC(I),I=1,20)/
1773 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1774 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1775 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1776 &' ', 'W+ + W- -> h0 ',
1777 &' ', 'f + f'' -> f + f'' (QFD) ',
1778 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1779 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1780 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1781 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1782 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1783 DATA (PROC(I),I=21,40)/
1784 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1785 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1786 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1787 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1788 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1789 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1790 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1791 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1792 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1793 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1794 DATA (PROC(I),I=41,60)/
1795 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1796 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1797 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1798 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1799 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1800 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1801 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1802 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1803 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1804 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1805 DATA (PROC(I),I=61,80)/
1806 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1807 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1808 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1809 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1810 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1811 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1812 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1813 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1814 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1815 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1816 DATA (PROC(I),I=81,100)/
1817 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1818 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1819 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1820 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1821 8'g + g -> chi_2c + g ', ' ',
1822 9'Elastic scattering ', 'Single diffractive (XB) ',
1823 9'Single diffractive (AX) ', 'Double diffractive ',
1824 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1825 9' ', ' ',
1826 9'q + gamma* -> q ', ' '/
1827 DATA (PROC(I),I=101,120)/
1828 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1829 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1830 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1831 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1832 &' ', 'f + fbar -> gamma + h0 ',
1833 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1834 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1835 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1836 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1837 1' ', ' '/
1838 DATA (PROC(I),I=121,140)/
1839 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1840 2'f + f'' -> f + f'' + h0 ',
1841 2'f + f'' -> f" + f"'' + h0 ',
1842 2' ', ' ',
1843 2' ', ' ',
1844 2' ', ' ',
1845 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1846 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1847 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1848 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1849 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1850 DATA (PROC(I),I=141,160)/
1851 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1852 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1853 4'q + l -> LQ ', 'e + gamma -> e* ',
1854 4'd + g -> d* ', 'u + g -> u* ',
1855 4'g + g -> eta_tc ', ' ',
1856 5'f + fbar -> H0 ', 'g + g -> H0 ',
1857 5'gamma + gamma -> H0 ', ' ',
1858 5' ', 'f + fbar -> A0 ',
1859 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1860 5' ', ' '/
1861 DATA (PROC(I),I=161,180)/
1862 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1863 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1864 6'f + fbar -> f'' + fbar'' (g/Z)',
1865 6'f +fbar'' -> f" + fbar"'' (W) ',
1866 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1867 6'q + qbar -> e + e* ', ' ',
1868 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1869 7'f + f'' -> f + f'' + H0 ',
1870 7'f + f'' -> f" + f"'' + H0 ',
1871 7' ', 'f + fbar -> Z0 + A0 ',
1872 7'f + fbar'' -> W+/- + A0 ',
1873 7'f + f'' -> f + f'' + A0 ',
1874 7'f + f'' -> f" + f"'' + A0 ',
1875 7' '/
1876 DATA (PROC(I),I=181,200)/
1877 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1878 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1879 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1880 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1881 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1882 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1883 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1884 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1885 9' ', ' ',
1886 9' ', ' '/
1887 DATA (PROC(I),I=201,220)/
1888 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1889 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1890 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1891 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1892 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1893 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1894 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1895 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1896 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1897 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1898 DATA (PROC(I),I=221,240)/
1899 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1900 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1901 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1902 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1903 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1904 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1905 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1906 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1907 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1908 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1909 DATA (PROC(I),I=241,260)/
1910 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1911 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1912 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1913 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1914 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1915 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1916 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1917 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1918 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1919 5'qj + g -> ~qj_R + ~g ', ' '/
1920 DATA (PROC(I),I=261,300)/
1921 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1922 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1923 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1924 6' ', ' ',
1925 6' ', ' ',
1926 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1927 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1928 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1929 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1930 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1931 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1932 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1933 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1934 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1935 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1936 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1937 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1938 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1939 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1940 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1941 DATA (PROC(I),I=301,340)/
1942 &'f + fbar -> H+ + H- ', 39*' '/
1943 DATA (PROC(I),I=341,380)/
1944 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1945 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1946 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1947 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1948 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1949 5'f + f -> f'' + f'' + H_L++/-- ',
1950 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1951 5'f + fbar'' -> W_R+/- ',5*' ',
1952 6' ', 'f + fbar -> W_L+ W_L- ',
1953 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1954 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1955 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1956 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1957 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1958 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1959 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1960 7'f + fbar'' -> W+/- pi_T0 ',
1961 7'f + fbar'' -> W+/- pi_T0'' ',
1962 7' ', ' ',
1963 7' '/
1964 DATA (PROC(I),I=381,420)/
1965 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1966 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1967 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1968 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1969 8' ', ' ',
1970 9'f + fbar -> G* ', 'g + g -> G* ',
1971 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1972 9'g + g -> g + G* ', ' ',
1973 9 4*' ',
1974 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
1975 & 18*' '/
1976 DATA (PROC(I),I=421,460)/
1977 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
1978 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
1979 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
1980 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
1981 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
1982 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
1983 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
1984 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
1985 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
1986 3'q + q~ -> g + cc~[3P2(1)] ',
1987 3 21 *' '/
1988 DATA (PROC(I),I=461,500)/
1989 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
1990 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
1991 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
1992 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
1993 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
1994 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
1995 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
1996 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
1997 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
1998 7'q + q~ -> g + bb~[3P2(1)] ',
1999 7 21 *' '/
2000
2001C...Cross sections and slope offsets.
2002 DATA SIGT/294*0D0/
2003
2004C...Supersymmetry switches and parameters.
2005 DATA IMSS/0,
2006 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2007 1 89*0/
2008 DATA RMSS/0D0,
2009 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2010 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2011 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2012 3 10*0D0,
2013 4 0D0,1D0,8*0D0,
2014 5 49*0D0/
2015C...Initial values for R-violating SUSY couplings.
2016C...Should not be changed here. See PYMSIN.
2017 DATA RVLAM/27*0D0/
2018 DATA RVLAMP/27*0D0/
2019 DATA RVLAMB/27*0D0/
2020
2021C...Technicolor switches and parameters
2022 DATA ITCM/0,
2023 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2024 1 89*0/
2025 DATA RTCM/0D0,
2026 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2027 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2028 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2029 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2030 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 4*0D0,
2031 4 49*0D0/
2032
2033C...Data for histogramming routines.
2034 DATA IHIST/1000,20000,55,1/
2035 DATA INDX/1000*0/
2036
2037C...Data for SUSY Les Houches Accord.
2038 DATA CPRO/'PYTHIA ','PYTHIA '/
2039 DATA CVER/'6.4 ','6.4 '/
2040 DATA MODSEL/200*0/
2041 DATA PARMIN/100*0D0/
2042 DATA RMSOFT/101*0D0/
2043 DATA AU/9*0D0/
2044 DATA AD/9*0D0/
2045 DATA AE/9*0D0/
2046
2047 END
2048
2049C*********************************************************************
2050
2051C...PYCKBD
2052C...Check that BLOCK DATA PYDATA has been loaded.
2053C...Should not be required, except that some compilers/linkers
2054C...are pretty buggy in this respect.
2055
2056 SUBROUTINE PYCKBD
2057
2058C...Double precision and integer declarations.
2059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2060 IMPLICIT INTEGER(I-N)
2061 INTEGER PYK,PYCHGE,PYCOMP
2062C...Commonblocks.
2063 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2064 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2065 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2066 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2067 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2068 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2069 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2070
2071C...Check a few variables to see they have been sensibly initialized.
2072 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2073 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2074 &MSTP(1).GT.5) THEN
2075C...If not, abort the run right away.
2076 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2077 WRITE(*,*) 'The program execution is stopped now!'
2078 STOP
2079 ENDIF
2080
2081 RETURN
2082 END
2083
2084C*********************************************************************
2085
2086C...PYTEST
2087C...A simple program (disguised as subroutine) to run at installation
2088C...as a check that the program works as intended.
2089
2090 SUBROUTINE PYTEST(MTEST)
2091
2092C...Double precision and integer declarations.
2093 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2094 IMPLICIT INTEGER(I-N)
2095 INTEGER PYK,PYCHGE,PYCOMP
2096C...Commonblocks.
2097 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2098 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2099 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2100 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2101 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2102 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2103 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2104C...Local arrays.
2105 DIMENSION PSUM(5),PINI(6),PFIN(6)
2106
2107C...Save defaults for values that are changed.
2108 MSTJ1=MSTJ(1)
2109 MSTJ3=MSTJ(3)
2110 MSTJ11=MSTJ(11)
2111 MSTJ42=MSTJ(42)
2112 MSTJ43=MSTJ(43)
2113 MSTJ44=MSTJ(44)
2114 PARJ17=PARJ(17)
2115 PARJ22=PARJ(22)
2116 PARJ43=PARJ(43)
2117 PARJ54=PARJ(54)
2118 MST101=MSTJ(101)
2119 MST104=MSTJ(104)
2120 MST105=MSTJ(105)
2121 MST107=MSTJ(107)
2122 MST116=MSTJ(116)
2123
2124C...First part: loop over simple events to be generated.
2125 IF(MTEST.GE.1) CALL PYTABU(20)
2126 NERR=0
2127 DO 180 IEV=1,500
2128
2129C...Reset parameter values. Switch on some nonstandard features.
2130 MSTJ(1)=1
2131 MSTJ(3)=0
2132 MSTJ(11)=1
2133 MSTJ(42)=2
2134 MSTJ(43)=4
2135 MSTJ(44)=2
2136 PARJ(17)=0.1D0
2137 PARJ(22)=1.5D0
2138 PARJ(43)=1D0
2139 PARJ(54)=-0.05D0
2140 MSTJ(101)=5
2141 MSTJ(104)=5
2142 MSTJ(105)=0
2143 MSTJ(107)=1
2144 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2145
2146C...Ten events each for some single jets configurations.
2147 IF(IEV.LE.50) THEN
2148 ITY=(IEV+9)/10
2149 MSTJ(3)=-1
2150 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2151 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2152 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2153 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2154 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2155 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2156
2157C...Ten events each for some simple jet systems; string fragmentation.
2158 ELSEIF(IEV.LE.130) THEN
2159 ITY=(IEV-41)/10
2160 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2161 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2162 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2163 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2164 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2165 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2166 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2167 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2168 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2169
2170C...Seventy events with independent fragmentation and momentum cons.
2171 ELSEIF(IEV.LE.200) THEN
2172 ITY=1+(IEV-131)/16
2173 MSTJ(2)=1+MOD(IEV-131,4)
2174 MSTJ(3)=1+MOD((IEV-131)/4,4)
2175 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2176 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2177 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2178 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2179 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2180 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2181
2182C...A hundred events with random jets (check invariant mass).
2183 ELSEIF(IEV.LE.300) THEN
2184 100 DO 110 J=1,5
2185 PSUM(J)=0D0
2186 110 CONTINUE
2187 NJET=2D0+6D0*PYR(0)
2188 DO 130 I=1,NJET
2189 KFL=21
2190 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2191 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2192 EJET=5D0+20D0*PYR(0)
2193 THETA=ACOS(2D0*PYR(0)-1D0)
2194 PHI=6.2832D0*PYR(0)
2195 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2196 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2197 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2198 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2199 DO 120 J=1,4
2200 PSUM(J)=PSUM(J)+P(I,J)
2201 120 CONTINUE
2202 130 CONTINUE
2203 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2204 & (PSUM(5)+PARJ(32))**2) GOTO 100
2205
2206C...Fifty e+e- continuum events with matrix elements.
2207 ELSEIF(IEV.LE.350) THEN
2208 MSTJ(101)=2
2209 CALL PYEEVT(0,40D0)
2210
2211C...Fifty e+e- continuum event with varying shower options.
2212 ELSEIF(IEV.LE.400) THEN
2213 MSTJ(42)=1+MOD(IEV,2)
2214 MSTJ(43)=1+MOD(IEV/2,4)
2215 MSTJ(44)=MOD(IEV/8,3)
2216 CALL PYEEVT(0,90D0)
2217
2218C...Fifty e+e- continuum events with coherent shower.
2219 ELSEIF(IEV.LE.450) THEN
2220 CALL PYEEVT(0,500D0)
2221
2222C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2223 ELSE
2224 CALL PYONIA(5,9.46D0)
2225 ENDIF
2226
2227C...Generate event. Find total momentum, energy and charge.
2228 DO 140 J=1,4
2229 PINI(J)=PYP(0,J)
2230 140 CONTINUE
2231 PINI(6)=PYP(0,6)
2232 CALL PYEXEC
2233 DO 150 J=1,4
2234 PFIN(J)=PYP(0,J)
2235 150 CONTINUE
2236 PFIN(6)=PYP(0,6)
2237
2238C...Check conservation of energy, momentum and charge;
2239C...usually exact, but only approximate for single jets.
2240 MERR=0
2241 IF(IEV.LE.50) THEN
2242 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2243 & MERR=MERR+1
2244 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2245 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2246 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2247 ELSE
2248 DO 160 J=1,4
2249 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2250 160 CONTINUE
2251 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2252 ENDIF
2253 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2254 & (PFIN(J),J=1,4),PFIN(6)
2255
2256C...Check that all KF codes are known ones, and that partons/particles
2257C...satisfy energy-momentum-mass relation. Store particle statistics.
2258 DO 170 I=1,N
2259 IF(K(I,1).GT.20) GOTO 170
2260 IF(PYCOMP(K(I,2)).EQ.0) THEN
2261 WRITE(MSTU(11),5100) I
2262 MERR=MERR+1
2263 ENDIF
2264 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2265 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2266 & THEN
2267 WRITE(MSTU(11),5200) I
2268 MERR=MERR+1
2269 ENDIF
2270 170 CONTINUE
2271 IF(MTEST.GE.1) CALL PYTABU(21)
2272
2273C...List all erroneous events and some normal ones.
2274 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2275 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2276 CALL PYLIST(2)
2277 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2278 CALL PYLIST(1)
2279 ENDIF
2280
2281C...Stop execution if too many errors.
2282 IF(MERR.NE.0) NERR=NERR+1
2283 IF(NERR.GE.10) THEN
2284 WRITE(MSTU(11),6300)
2285 CALL PYLIST(1)
2286 STOP
2287 ENDIF
2288 180 CONTINUE
2289
2290C...Summarize result of run.
2291 IF(MTEST.GE.1) CALL PYTABU(22)
2292
2293C...Reset commonblock variables changed during run.
2294 MSTJ(1)=MSTJ1
2295 MSTJ(3)=MSTJ3
2296 MSTJ(11)=MSTJ11
2297 MSTJ(42)=MSTJ42
2298 MSTJ(43)=MSTJ43
2299 MSTJ(44)=MSTJ44
2300 PARJ(17)=PARJ17
2301 PARJ(22)=PARJ22
2302 PARJ(43)=PARJ43
2303 PARJ(54)=PARJ54
2304 MSTJ(101)=MST101
2305 MSTJ(104)=MST104
2306 MSTJ(105)=MST105
2307 MSTJ(107)=MST107
2308 MSTJ(116)=MST116
2309
2310C...Second part: complete events of various kinds.
2311C...Common initial values. Loop over initiating conditions.
2312 MSTP(122)=MAX(0,MIN(2,MTEST))
2313 MDCY(PYCOMP(111),1)=0
2314 DO 230 IPROC=1,8
2315
2316C...Reset process type, kinematics cuts, and the flags used.
2317 MSEL=0
2318 DO 190 ISUB=1,500
2319 MSUB(ISUB)=0
2320 190 CONTINUE
2321 CKIN(1)=2D0
2322 CKIN(3)=0D0
2323 MSTP(2)=1
2324 MSTP(11)=0
2325 MSTP(33)=0
2326 MSTP(81)=1
2327 MSTP(82)=1
2328 MSTP(111)=1
2329 MSTP(131)=0
2330 MSTP(133)=0
2331 PARP(131)=0.01D0
2332
2333C...Prompt photon production at fixed target.
2334 IF(IPROC.EQ.1) THEN
2335 PZSUM=300D0
2336 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2337 PQSUM=2D0
2338 MSEL=10
2339 CKIN(3)=5D0
2340 CALL PYINIT('FIXT','pi+','p',PZSUM)
2341
2342C...QCD processes at ISR energies.
2343 ELSEIF(IPROC.EQ.2) THEN
2344 PESUM=63D0
2345 PZSUM=0D0
2346 PQSUM=2D0
2347 MSEL=1
2348 CKIN(3)=5D0
2349 CALL PYINIT('CMS','p','p',PESUM)
2350
2351C...W production + multiple interactions at CERN Collider.
2352 ELSEIF(IPROC.EQ.3) THEN
2353 PESUM=630D0
2354 PZSUM=0D0
2355 PQSUM=0D0
2356 MSEL=12
2357 CKIN(1)=20D0
2358 MSTP(82)=4
2359 MSTP(2)=2
2360 MSTP(33)=3
2361 CALL PYINIT('CMS','p','pbar',PESUM)
2362
2363C...W/Z gauge boson pairs + pileup events at the Tevatron.
2364 ELSEIF(IPROC.EQ.4) THEN
2365 PESUM=1800D0
2366 PZSUM=0D0
2367 PQSUM=0D0
2368 MSUB(22)=1
2369 MSUB(23)=1
2370 MSUB(25)=1
2371 CKIN(1)=200D0
2372 MSTP(111)=0
2373 MSTP(131)=1
2374 MSTP(133)=2
2375 PARP(131)=0.04D0
2376 CALL PYINIT('CMS','p','pbar',PESUM)
2377
2378C...Higgs production at LHC.
2379 ELSEIF(IPROC.EQ.5) THEN
2380 PESUM=15400D0
2381 PZSUM=0D0
2382 PQSUM=2D0
2383 MSUB(3)=1
2384 MSUB(102)=1
2385 MSUB(123)=1
2386 MSUB(124)=1
2387 PMAS(25,1)=300D0
2388 CKIN(1)=200D0
2389 MSTP(81)=0
2390 MSTP(111)=0
2391 CALL PYINIT('CMS','p','p',PESUM)
2392
2393C...Z' production at SSC.
2394 ELSEIF(IPROC.EQ.6) THEN
2395 PESUM=40000D0
2396 PZSUM=0D0
2397 PQSUM=2D0
2398 MSEL=21
2399 PMAS(32,1)=600D0
2400 CKIN(1)=400D0
2401 MSTP(81)=0
2402 MSTP(111)=0
2403 CALL PYINIT('CMS','p','p',PESUM)
2404
2405C...W pair production at 1 TeV e+e- collider.
2406 ELSEIF(IPROC.EQ.7) THEN
2407 PESUM=1000D0
2408 PZSUM=0D0
2409 PQSUM=0D0
2410 MSUB(25)=1
2411 MSUB(69)=1
2412 MSTP(11)=1
2413 CALL PYINIT('CMS','e+','e-',PESUM)
2414
2415C...Deep inelastic scattering at a LEP+LHC ep collider.
2416 ELSEIF(IPROC.EQ.8) THEN
2417 P(1,1)=0D0
2418 P(1,2)=0D0
2419 P(1,3)=8000D0
2420 P(2,1)=0D0
2421 P(2,2)=0D0
2422 P(2,3)=-80D0
2423 PESUM=8080D0
2424 PZSUM=7920D0
2425 PQSUM=0D0
2426 MSUB(10)=1
2427 CKIN(3)=50D0
2428 MSTP(111)=0
2429 CALL PYINIT('3MOM','p','e-',PESUM)
2430 ENDIF
2431
2432C...Generate 20 events of each required type.
2433 DO 220 IEV=1,20
2434 CALL PYEVNT
2435 PESUMM=PESUM
2436 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2437
2438C...Check conservation of energy/momentum/flavour.
2439 PINI(1)=0D0
2440 PINI(2)=0D0
2441 PINI(3)=PZSUM
2442 PINI(4)=PESUMM
2443 PINI(6)=PQSUM
2444 DO 200 J=1,4
2445 PFIN(J)=PYP(0,J)
2446 200 CONTINUE
2447 PFIN(6)=PYP(0,6)
2448 MERR=0
2449 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2450 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2451 DEVQ=ABS(PFIN(6)-PINI(6))
2452 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2453 & DEVQ.GT.0.1D0) MERR=1
2454 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2455 & (PFIN(J),J=1,4),PFIN(6)
2456
2457C...Check that all KF codes are known ones, and that partons/particles
2458C...satisfy energy-momentum-mass relation.
2459 DO 210 I=1,N
2460 IF(K(I,1).GT.20) GOTO 210
2461 IF(PYCOMP(K(I,2)).EQ.0) THEN
2462 WRITE(MSTU(11),5100) I
2463 MERR=MERR+1
2464 ENDIF
2465 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2466 & SIGN(1D0,P(I,5))
2467 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2468 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2469 WRITE(MSTU(11),5200) I
2470 MERR=MERR+1
2471 ENDIF
2472 210 CONTINUE
2473
2474C...Listing of erroneous events, and first event of each type.
2475 IF(MERR.GE.1) NERR=NERR+1
2476 IF(NERR.GE.10) THEN
2477 WRITE(MSTU(11),6300)
2478 CALL PYLIST(1)
2479 STOP
2480 ENDIF
2481 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2482 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2483 CALL PYLIST(1)
2484 ENDIF
2485 220 CONTINUE
2486
2487C...List statistics for each process type.
2488 IF(MTEST.GE.1) CALL PYSTAT(1)
2489 230 CONTINUE
2490
2491C...Summarize result of run.
2492 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2493 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2494
2495C...Format statements for output.
2496 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2497 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2498 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2499 &4(1X,F12.5),1X,F8.2)
2500 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2501 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2502 &'kinematics')
2503 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2504 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2505 6400 FORMAT(5X,'Faulty event follows:')
2506 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2507 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2508 &5X,'This should not have happened!')
2509
2510 RETURN
2511 END
2512
2513C*********************************************************************
2514
2515C...PYHEPC
2516C...Converts PYTHIA event record contents to or from
2517C...the standard event record commonblock.
2518
2519 SUBROUTINE PYHEPC(MCONV)
2520
2521C...Double precision and integer declarations.
2522 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2523 IMPLICIT INTEGER(I-N)
2524 INTEGER PYK,PYCHGE,PYCOMP
2525C...Commonblocks.
2526 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2529 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2530C...HEPEVT commonblock.
2531 PARAMETER (NMXHEP=4000)
2532 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2533 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2534 DOUBLE PRECISION PHEP,VHEP
2535 SAVE /HEPEVT/
2536
2537C...Store HEPEVT commonblock size (for interfacing issues).
2538 MSTU(8)=NMXHEP
2539
2540C...Conversion from PYTHIA to standard, the easy part.
2541 IF(MCONV.EQ.1) THEN
2542 NEVHEP=0
2543 IF(N.GT.NMXHEP) CALL PYERRM(8,
2544 & '(PYHEPC:) no more space in /HEPEVT/')
2545 NHEP=MIN(N,NMXHEP)
2546 DO 150 I=1,NHEP
2547 ISTHEP(I)=0
2548 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2549 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2550 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2551 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2552 IDHEP(I)=K(I,2)
2553 JMOHEP(1,I)=K(I,3)
2554 JMOHEP(2,I)=0
2555 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2556 JDAHEP(1,I)=K(I,4)
2557 JDAHEP(2,I)=K(I,5)
2558 ELSE
2559 JDAHEP(1,I)=0
2560 JDAHEP(2,I)=0
2561 ENDIF
2562 DO 100 J=1,5
2563 PHEP(J,I)=P(I,J)
2564 100 CONTINUE
2565 DO 110 J=1,4
2566 VHEP(J,I)=V(I,J)
2567 110 CONTINUE
2568
2569C...Check if new event (from pileup).
2570 IF(I.EQ.1) THEN
2571 INEW=1
2572 ELSE
2573 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2574 ENDIF
2575
2576C...Fill in missing mother information.
2577 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2578 IMO1=I-2
2579 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2580 & THEN
2581 IMO1=IMO1-1
2582 GOTO 120
2583 ENDIF
2584 JMOHEP(1,I)=IMO1
2585 JMOHEP(2,I)=IMO1+1
2586 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2587 I1=K(I,3)-1
2588 130 I1=I1+1
2589 IF(I1.GE.I) CALL PYERRM(8,
2590 & '(PYHEPC:) translation of inconsistent event history')
2591 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2592 KC=PYCOMP(K(I1,2))
2593 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2594 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2595 JMOHEP(2,I)=I1
2596 ELSEIF(K(I,2).EQ.94) THEN
2597 NJET=2
2598 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2599 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2600 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2601 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2602 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2603 ENDIF
2604
2605C...Fill in missing daughter information.
2606 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2607 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2608 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2609 JDAHEP(1,I2)=I
2610 140 CONTINUE
2611 ENDIF
2612 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2613 I1=JMOHEP(1,I)
2614 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2615 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2616 IF(JDAHEP(1,I1).EQ.0) THEN
2617 JDAHEP(1,I1)=I
2618 ELSE
2619 JDAHEP(2,I1)=I
2620 ENDIF
2621 150 CONTINUE
2622 DO 160 I=1,NHEP
2623 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2624 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2625 160 CONTINUE
2626
2627C...Conversion from standard to PYTHIA, the easy part.
2628 ELSE
2629 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2630 & '(PYHEPC:) no more space in /PYJETS/')
2631 N=MIN(NHEP,MSTU(4))
2632 NKQ=0
2633 KQSUM=0
2634 DO 190 I=1,N
2635 K(I,1)=0
2636 IF(ISTHEP(I).EQ.1) K(I,1)=1
2637 IF(ISTHEP(I).EQ.2) K(I,1)=11
2638 IF(ISTHEP(I).EQ.3) K(I,1)=21
2639 K(I,2)=IDHEP(I)
2640 K(I,3)=JMOHEP(1,I)
2641 K(I,4)=JDAHEP(1,I)
2642 K(I,5)=JDAHEP(2,I)
2643 DO 170 J=1,5
2644 P(I,J)=PHEP(J,I)
2645 170 CONTINUE
2646 DO 180 J=1,4
2647 V(I,J)=VHEP(J,I)
2648 180 CONTINUE
2649 V(I,5)=0D0
2650 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2651 I1=JDAHEP(1,I)
2652 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2653 & PHEP(5,I)/PHEP(4,I)
2654 ENDIF
2655
2656C...Fill in missing information on colour connection in jet systems.
2657 IF(ISTHEP(I).EQ.1) THEN
2658 KC=PYCOMP(K(I,2))
2659 KQ=0
2660 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2661 IF(KQ.NE.0) NKQ=NKQ+1
2662 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2663 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2664 K(I,1)=2
2665 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2666 IF(K(I+1,2).EQ.21) K(I,1)=2
2667 ENDIF
2668 ENDIF
2669 190 CONTINUE
2670 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2671 & '(PYHEPC:) input parton configuration not colour singlet')
2672 ENDIF
2673
2674 END
2675
2676C*********************************************************************
2677
2678C...PYINIT
2679C...Initializes the generation procedure; finds maxima of the
2680C...differential cross-sections to be used for weighting.
2681
2682 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2683
2684C...Double precision and integer declarations.
2685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2686 IMPLICIT INTEGER(I-N)
2687 INTEGER PYK,PYCHGE,PYCOMP
2688C...Commonblocks.
2689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2690 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2691 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2692 COMMON/PYDAT4/CHAF(500,2)
2693 CHARACTER CHAF*16
2694 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2695 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2696 COMMON/PYINT1/MINT(400),VINT(400)
2697 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2698 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2699 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2700 &/PYINT1/,/PYINT2/,/PYINT5/
2701C...Local arrays and character variables.
2702 DIMENSION ALAMIN(20),NFIN(20)
2703 CHARACTER*(*) FRAME,BEAM,TARGET
2704 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2705
2706C...Interface to PDFLIB.
2707 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
2708 COMMON/W50512/QCDL4,QCDL5
2709 SAVE /W50511/,/W50512/
2710 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2711 CHARACTER*20 PARM(20)
2712 DATA VALUE/20*0D0/,PARM/20*' '/
2713
2714C...Data:Lambda and n_f values for parton distributions..
2715 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2716 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2717 &NFIN/20*4/
2718 DATA CHLH/'lepton','hadron'/
2719
2720C...Check that BLOCK DATA PYDATA has been loaded.
2721 CALL PYCKBD
2722
2723C...Reset MINT and VINT arrays. Write headers.
2724 MSTI(53)=0
2725 DO 100 J=1,400
2726 MINT(J)=0
2727 VINT(J)=0D0
2728 100 CONTINUE
2729 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2730 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2731
2732C...Reset error counters.
2733 MSTU(23)=0
2734 MSTU(27)=0
2735 MSTU(30)=0
2736
2737C...Reset processes that should not be on.
2738 MSUB(96)=0
2739 MSUB(97)=0
2740
2741C...Call user process initialization routine.
2742 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2743 MSEL=0
2744 CALL UPINIT
2745 MSEL=0
2746 ENDIF
2747
2748C...Maximum 4 generations; set maximum number of allowed flavours.
2749 MSTP(1)=MIN(4,MSTP(1))
2750 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2751 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2752
2753C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2754 DO 120 I=-20,20
2755 VINT(180+I)=0D0
2756 IA=IABS(I)
2757 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2758 DO 110 J=1,MSTP(1)
2759 IB=2*J-1+MOD(IA,2)
2760 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2761 IPM=(5-ISIGN(1,I))/2
2762 IDC=J+MDCY(IA,2)+2
2763 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2764 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2765 110 CONTINUE
2766 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2767 VINT(180+I)=1D0
2768 ENDIF
2769 120 CONTINUE
2770
2771C...Initialize parton distributions: PDFLIB.
2772 IF(MSTP(52).EQ.2) THEN
2773 PARM(1)='NPTYPE'
2774 VALUE(1)=1
2775 PARM(2)='NGROUP'
2776 VALUE(2)=MSTP(51)/1000
2777 PARM(3)='NSET'
2778 VALUE(3)=MOD(MSTP(51),1000)
2779 PARM(4)='TMAS'
2780 VALUE(4)=PMAS(6,1)
2781 CALL PDFSET(PARM,VALUE)
2782 MINT(93)=1000000+MSTP(51)
2783 ENDIF
2784
2785C...Choose Lambda value to use in alpha-strong.
2786 MSTU(111)=MSTP(2)
2787 IF(MSTP(3).GE.2) THEN
2788 ALAM=0.2D0
2789 NF=4
2790 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2791 ALAM=ALAMIN(MSTP(51))
2792 NF=NFIN(MSTP(51))
2793 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2794 ALAM=QCDL5
2795 NF=5
2796 ELSEIF(MSTP(52).EQ.2) THEN
2797 ALAM=QCDL4
2798 NF=4
2799 ENDIF
2800 PARP(1)=ALAM
2801 PARP(61)=ALAM
2802 PARP(72)=ALAM
2803 PARU(112)=ALAM
2804 MSTU(112)=NF
2805 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2806 ENDIF
2807
2808C...Initialize the SUSY generation: couplings, masses,
2809C...decay modes, branching ratios, and so on.
2810 CALL PYMSIN
2811C...Initialize widths and partial widths for resonances.
2812 CALL PYINRE
2813C...Set Z0 mass and width for e+e- routines.
2814 PARJ(123)=PMAS(23,1)
2815 PARJ(124)=PMAS(23,2)
2816
2817C...Identify beam and target particles and frame of process.
2818 CHFRAM=FRAME//' '
2819 CHBEAM=BEAM//' '
2820 CHTARG=TARGET//' '
2821 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2822 IF(MINT(65).EQ.1) GOTO 170
2823
2824C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2825C...For e-gamma allow 2 alternatives.
2826 MINT(121)=1
2827 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2828 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2829 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2830 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2831 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2832 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2833 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2834 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2835 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2836 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2837 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2838 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2839 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2840 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2841 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2842 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2843 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2844 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2845 ENDIF
2846 MINT(123)=MSTP(14)
2847 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2848 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2849 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2850 IF(MSTP(14).EQ.11) MINT(123)=0
2851 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2852 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2853 IF(MSTP(14).EQ.15) MINT(123)=2
2854 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2855 IF(MSTP(14).EQ.19) MINT(123)=3
2856 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2857 IF(MSTP(14).EQ.21) MINT(123)=0
2858 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2859 IF(MSTP(14).EQ.24) MINT(123)=1
2860 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2861 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2862 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2863 ENDIF
2864
2865C...Set up kinematics of process.
2866 CALL PYINKI(0)
2867
2868C...Set up kinematics for photons inside leptons.
2869 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2870
2871C...Precalculate flavour selection weights.
2872 CALL PYKFIN
2873
2874C...Loop over gamma-p or gamma-gamma alternatives.
2875 CKIN3=CKIN(3)
2876 MSAV48=0
2877 DO 160 IGA=1,MINT(121)
2878 CKIN(3)=CKIN3
2879 MINT(122)=IGA
2880
2881C...Select partonic subprocesses to be included in the simulation.
2882 CALL PYINPR
2883 MINT(101)=1
2884 MINT(102)=1
2885 MINT(103)=MINT(11)
2886 MINT(104)=MINT(12)
2887
2888C...Count number of subprocesses on.
2889 MINT(48)=0
2890 DO 130 ISUB=1,500
2891 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2892 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2893 MSUB(ISUB)=0
2894 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2895 & MSUB(ISUB).EQ.1) THEN
2896 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2897 STOP
2898 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2899 WRITE(MSTU(11),5300) ISUB
2900 STOP
2901 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2902 WRITE(MSTU(11),5400) ISUB
2903 STOP
2904 ELSEIF(MSUB(ISUB).EQ.1) THEN
2905 MINT(48)=MINT(48)+1
2906 ENDIF
2907 130 CONTINUE
2908
2909C...Stop or raise warning flag if no subprocesses on.
2910 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2911 IF(MSTP(127).NE.1) THEN
2912 WRITE(MSTU(11),5500)
2913 STOP
2914 ELSE
2915 WRITE(MSTU(11),5700)
2916 MSTI(53)=1
2917 ENDIF
2918 ENDIF
2919 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2920 MSAV48=MSAV48+MINT(48)
2921
2922C...Reset variables for cross-section calculation.
2923 DO 150 I=0,500
2924 DO 140 J=1,3
2925 NGEN(I,J)=0
2926 XSEC(I,J)=0D0
2927 140 CONTINUE
2928 150 CONTINUE
2929
2930C...Find parametrized total cross-sections.
2931 CALL PYXTOT
2932 VINT(318)=VINT(317)
2933
2934C...Maxima of differential cross-sections.
2935 IF(MSTP(121).LE.1) CALL PYMAXI
2936
2937C...Initialize possibility of pileup events.
2938 IF(MINT(121).GT.1) MSTP(131)=0
2939 IF(MSTP(131).NE.0) CALL PYPILE(1)
2940
2941C...Initialize multiple interactions with variable impact parameter.
2942 IF(MINT(50).EQ.1) THEN
2943 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2944 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
2945 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
2946 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
2947 MINT(35)=1
2948 CALL PYMULT(1)
2949 MINT(35)=3
2950 CALL PYMIGN(1)
2951 ENDIF
2952 ENDIF
2953
2954C...Save results for gamma-p and gamma-gamma alternatives.
2955 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2956 160 CONTINUE
2957
2958C...Initialization finished.
2959 IF(MSAV48.EQ.0) THEN
2960 IF(MSTP(127).NE.1) THEN
2961 WRITE(MSTU(11),5500)
2962 STOP
2963 ELSE
2964 WRITE(MSTU(11),5700)
2965 MSTI(53)=1
2966 ENDIF
2967 ENDIF
2968 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2969
2970C...Formats for initialization information.
2971 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
2972 &'routines',1X,17('*'))
2973 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
2974 &'-',A6,' interactions.'/1X,'Execution stopped!')
2975 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
2976 &1X,'Execution stopped!')
2977 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
2978 &1X,'Execution stopped!')
2979 5500 FORMAT(1X,'Error: no subprocess switched on.'/
2980 &1X,'Execution stopped.')
2981 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
2982 &22('*'))
2983 5700 FORMAT(1X,'Error: no subprocess switched on.'/
2984 &1X,'Execution will stop if you try to generate events.')
2985
2986 RETURN
2987 END
2988
2989C*********************************************************************
2990
2991C...PYEVNT
2992C...Administers the generation of a high-pT event via calls to
2993C...a number of subroutines.
2994
2995 SUBROUTINE PYEVNT
2996
2997C...Double precision and integer declarations.
2998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2999 IMPLICIT INTEGER(I-N)
3000 INTEGER PYK,PYCHGE,PYCOMP
3001C...Commonblocks.
3002 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3004 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3005 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3006 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3007 COMMON/PYINT1/MINT(400),VINT(400)
3008 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3009 COMMON/PYINT4/MWID(500),WIDS(500,5)
3010 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3011 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,
3012 &/PYINT2/,/PYINT4/,/PYINT5/
3013C...Local array.
3014 DIMENSION VTX(4)
3015
3016C...Optionally let PYEVNW do the whole job.
3017 IF(MSTP(81).GE.20) THEN
3018 CALL PYEVNW
3019 RETURN
3020 ENDIF
3021
3022C...Stop if no subprocesses on.
3023 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3024 WRITE(MSTU(11),5100)
3025 STOP
3026 ENDIF
3027
3028C...Initial values for some counters.
3029 N=0
3030 MINT(5)=MINT(5)+1
3031 MINT(7)=0
3032 MINT(8)=0
3033 MINT(30)=0
3034 MINT(83)=0
3035 MINT(84)=MSTP(126)
3036 MSTU(24)=0
3037 MSTU70=0
3038 MSTJ14=MSTJ(14)
3039C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3040 NCT=0
3041 MINT(33)=0
3042
3043C...Let called routines know call is from PYEVNT (not PYEVNW).
3044 MINT(35)=1
3045 IF (MSTP(81).GE.10) MINT(35)=2
3046
3047C...If variable energies: redo incoming kinematics and cross-section.
3048 MSTI(61)=0
3049 IF(MSTP(171).EQ.1) THEN
3050 CALL PYINKI(1)
3051 IF(MSTI(61).EQ.1) THEN
3052 MINT(5)=MINT(5)-1
3053 RETURN
3054 ENDIF
3055 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3056 CALL PYXTOT
3057 ENDIF
3058
3059C...Loop over number of pileup events; check space left.
3060 IF(MSTP(131).LE.0) THEN
3061 NPILE=1
3062 ELSE
3063 CALL PYPILE(2)
3064 NPILE=MINT(81)
3065 ENDIF
3066 DO 270 IPILE=1,NPILE
3067 IF(MINT(84)+100.GE.MSTU(4)) THEN
3068 CALL PYERRM(11,
3069 & '(PYEVNT:) no more space in PYJETS for pileup events')
3070 IF(MSTU(21).GE.1) GOTO 280
3071 ENDIF
3072 MINT(82)=IPILE
3073
3074C...Generate variables of hard scattering.
3075 MINT(51)=0
3076 MSTI(52)=0
3077 100 CONTINUE
3078 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3079 MINT(31)=0
3080 MINT(39)=0
3081 MINT(51)=0
3082 MINT(57)=0
3083 CALL PYRAND
3084 IF(MSTI(61).EQ.1) THEN
3085 MINT(5)=MINT(5)-1
3086 RETURN
3087 ENDIF
3088 IF(MINT(51).EQ.2) RETURN
3089 ISUB=MINT(1)
3090 IF(MSTP(111).EQ.-1) GOTO 260
3091
3092C...Loopback point if PYPREP fails, especially for junction topologies.
3093 NPREP=0
3094 MNT31S=MINT(31)
3095 110 NPREP=NPREP+1
3096 MINT(31)=MNT31S
3097
3098 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3099C...Hard scattering (including low-pT):
3100C...reconstruct kinematics and colour flow of hard scattering.
3101 MINT31=MINT(31)
3102 120 MINT(31)=MINT31
3103 MINT(51)=0
3104 CALL PYSCAT
3105 IF(MINT(51).EQ.1) GOTO 100
3106 IPU1=MINT(84)+1
3107 IPU2=MINT(84)+2
3108 IF(ISUB.EQ.95) GOTO 140
3109
3110C...Reset statistics on activity in event.
3111 DO 130 J=351,359
3112 MINT(J)=0
3113 VINT(J)=0D0
3114 130 CONTINUE
3115
3116C...Showering of initial state partons (optional).
3117 NFIN=N
3118 ALAMSV=PARJ(81)
3119 PARJ(81)=PARP(72)
3120 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3121 & CALL PYSSPA(IPU1,IPU2)
3122 PARJ(81)=ALAMSV
3123 IF(MINT(51).EQ.1) GOTO 100
3124
3125C...Showering of final state partons (optional).
3126 ALAMSV=PARJ(81)
3127 PARJ(81)=PARP(72)
3128 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3129 & THEN
3130 IPU3=MINT(84)+3
3131 IPU4=MINT(84)+4
3132 IF(ISET(ISUB).EQ.5) IPU4=-3
3133 QMAX=VINT(55)
3134 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3135 CALL PYSHOW(IPU3,IPU4,QMAX)
3136 ELSEIF(ISET(ISUB).EQ.11) THEN
3137 CALL PYADSH(NFIN)
3138 ENDIF
3139 PARJ(81)=ALAMSV
3140
3141C...Allow possibility for user to abort event generation.
3142 IVETO=0
3143 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3144 IF(IVETO.EQ.1) GOTO 100
3145
3146C...Decay of final state resonances.
3147 MINT(32)=0
3148 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3149 IF(MINT(51).EQ.1) GOTO 100
3150 MINT(52)=N
3151
3152
3153C...Multiple interactions - PYTHIA 6.3 intermediate style.
3154 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3155 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3156 CALL PYMIGN(6)
3157 IF(MINT(51).EQ.1) GOTO 100
3158 MINT(53)=N
3159
3160C...Beam remnant flavour and colour assignments - new scheme.
3161 CALL PYMIHK
3162 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3163 & GOTO 120
3164 IF(MINT(51).EQ.1) GOTO 100
3165
3166C...Primordial kT and beam remnant momentum sharing - new scheme.
3167 CALL PYMIRM
3168 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3169 & GOTO 120
3170 IF(MINT(51).EQ.1) GOTO 100
3171 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3172
3173C...Multiple interactions - PYTHIA 6.2 style.
3174 ELSEIF(MINT(111).NE.12) THEN
3175 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3176 CALL PYMULT(6)
3177 MINT(53)=N
3178 ENDIF
3179
3180C...Hadron remnants and primordial kT.
3181 CALL PYREMN(IPU1,IPU2)
3182 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3183 & 110
3184 IF(MINT(51).EQ.1) GOTO 100
3185 ENDIF
3186
3187 ELSEIF(ISUB.NE.99) THEN
3188C...Diffractive and elastic scattering.
3189 CALL PYDIFF
3190
3191 ELSE
3192C...DIS scattering (photon flux external).
3193 CALL PYDISG
3194 IF(MINT(51).EQ.1) GOTO 100
3195 ENDIF
3196
3197C...Check that no odd resonance left undecayed.
3198 MINT(54)=N
3199 IF(MSTP(111).GE.1) THEN
3200 NFIX=N
3201 DO 150 I=MINT(84)+1,NFIX
3202 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3203 & K(I,2).NE.22) THEN
3204 KCA=PYCOMP(K(I,2))
3205 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3206 CALL PYRESD(I)
3207 IF(MINT(51).EQ.1) GOTO 100
3208 ENDIF
3209 ENDIF
3210 150 CONTINUE
3211 ENDIF
3212
3213C...Boost hadronic subsystem to overall rest frame.
3214C..(Only relevant when photon inside lepton beam.)
3215 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3216
3217C...Recalculate energies from momenta and masses (if desired).
3218 IF(MSTP(113).GE.1) THEN
3219 DO 160 I=MINT(83)+1,N
3220 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3221 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3222 160 CONTINUE
3223 NRECAL=N
3224 ENDIF
3225
3226C...Colour reconnection before string formation
3227 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3228
3229C...Rearrange partons along strings, check invariant mass cuts.
3230 MSTU(28)=0
3231 IF(MSTP(111).LE.0) MSTJ(14)=-1
3232 CALL PYPREP(MINT(84)+1)
3233 MSTJ(14)=MSTJ14
3234 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3235 MSTU(24)=0
3236 GOTO 100
3237 ENDIF
3238 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3239 IF (MINT(51).EQ.1) GOTO 100
3240 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3241 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3242 DO 190 I=MINT(84)+1,N
3243 IF(K(I,2).EQ.94) THEN
3244 DO 180 I1=I+1,MIN(N,I+10)
3245 IF(K(I1,3).EQ.I) THEN
3246 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3247 IF(K(I1,3).EQ.0) THEN
3248 DO 170 II=MINT(84)+1,I-1
3249 IF(K(II,2).EQ.K(I1,2)) THEN
3250 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3251 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3252 ENDIF
3253 170 CONTINUE
3254 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3255 ENDIF
3256 ENDIF
3257 180 CONTINUE
3258 ENDIF
3259 190 CONTINUE
3260 CALL PYEDIT(12)
3261 CALL PYEDIT(14)
3262 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3263 IF(MSTP(125).EQ.0) MINT(4)=0
3264 DO 210 I=MINT(83)+1,N
3265 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3266 DO 200 I1=I+1,N
3267 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3268 IF(K(I1,3).EQ.I) K(I,5)=I1
3269 200 CONTINUE
3270 ENDIF
3271 210 CONTINUE
3272 ENDIF
3273
3274C...Introduce separators between sections in PYLIST event listing.
3275 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3276 MSTU70=1
3277 MSTU(71)=N
3278 ELSEIF(IPILE.EQ.1) THEN
3279 MSTU70=3
3280 MSTU(71)=2
3281 MSTU(72)=MINT(4)
3282 MSTU(73)=N
3283 ENDIF
3284
3285C...Go back to lab frame (needed for vertices, also in fragmentation).
3286 CALL PYFRAM(1)
3287
3288C...Set nonvanishing production vertex (optional).
3289 IF(MSTP(151).EQ.1) THEN
3290 DO 220 J=1,4
3291 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3292 & SIN(PARU(2)*PYR(0))
3293 220 CONTINUE
3294 DO 240 I=MINT(83)+1,N
3295 DO 230 J=1,4
3296 V(I,J)=V(I,J)+VTX(J)
3297 230 CONTINUE
3298 240 CONTINUE
3299 ENDIF
3300
3301C...Perform hadronization (if desired).
3302 IF(MSTP(111).GE.1) THEN
3303 CALL PYEXEC
3304 IF(MSTU(24).NE.0) GOTO 100
3305 ENDIF
3306 IF(MSTP(113).GE.1) THEN
3307 DO 250 I=NRECAL,N
3308 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3309 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3310 250 CONTINUE
3311 ENDIF
3312 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3313
3314C...Store event information and calculate Monte Carlo estimates of
3315C...subprocess cross-sections.
3316 260 IF(IPILE.EQ.1) CALL PYDOCU
3317
3318C...Set counters for current pileup event and loop to next one.
3319 MSTI(41)=IPILE
3320 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3321 IF(MSTU70.LT.10) THEN
3322 MSTU70=MSTU70+1
3323 MSTU(70+MSTU70)=N
3324 ENDIF
3325 MINT(83)=N
3326 MINT(84)=N+MSTP(126)
3327 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3328 270 CONTINUE
3329
3330C...Generic information on pileup events. Reconstruct missing history.
3331 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3332 PARI(91)=VINT(132)
3333 PARI(92)=VINT(133)
3334 PARI(93)=VINT(134)
3335 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3336 ENDIF
3337 CALL PYEDIT(16)
3338
3339C...Transform to the desired coordinate frame.
3340 280 CALL PYFRAM(MSTP(124))
3341 MSTU(70)=MSTU70
3342 PARU(21)=VINT(1)
3343
3344C...Error messages
3345 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3346 &1X,'Execution stopped.')
3347
3348 RETURN
3349 END
3350
3351C*********************************************************************
3352
3353C...PYEVNW
3354C...Administers the generation of a high-pT event via calls to
3355C...a number of subroutines for the new multiple interactions and
3356C...showering framework.
3357
3358 SUBROUTINE PYEVNW
3359
3360C...Double precision and integer declarations.
3361 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3362 IMPLICIT INTEGER(I-N)
3363 INTEGER PYK,PYCHGE,PYCOMP
3364C...Commonblocks.
3365 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3366 COMMON/PYCTAG/NCT,MCT(4000,2)
3367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3369 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3370 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3371 COMMON/PYINT1/MINT(400),VINT(400)
3372 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3373 COMMON/PYINT4/MWID(500),WIDS(500,5)
3374 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3375 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3376 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3377 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3378 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3379 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3380C...Local arrays.
3381 DIMENSION VTX(4)
3382
3383C...Stop if no subprocesses on.
3384 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3385 WRITE(MSTU(11),5100)
3386 STOP
3387 ENDIF
3388
3389C...Initial values for some counters.
3390 N=0
3391 MINT(5)=MINT(5)+1
3392 MINT(7)=0
3393 MINT(8)=0
3394 MINT(30)=0
3395 MINT(83)=0
3396 MINT(84)=MSTP(126)
3397 MSTU(24)=0
3398 MSTU70=0
3399 MSTJ14=MSTJ(14)
3400C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3401 NCT=0
3402 MINT(33)=0
3403
3404C...Let called routines know call is from PYEVNW (not PYEVNT).
3405 MINT(35)=3
3406
3407C...If variable energies: redo incoming kinematics and cross-section.
3408 MSTI(61)=0
3409 IF(MSTP(171).EQ.1) THEN
3410 CALL PYINKI(1)
3411 IF(MSTI(61).EQ.1) THEN
3412 MINT(5)=MINT(5)-1
3413 RETURN
3414 ENDIF
3415 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3416 CALL PYXTOT
3417 ENDIF
3418
3419C...Loop over number of pileup events; check space left.
3420 IF(MSTP(131).LE.0) THEN
3421 NPILE=1
3422 ELSE
3423 CALL PYPILE(2)
3424 NPILE=MINT(81)
3425 ENDIF
3426 DO 300 IPILE=1,NPILE
3427 IF(MINT(84)+100.GE.MSTU(4)) THEN
3428 CALL PYERRM(11,
3429 & '(PYEVNW:) no more space in PYJETS for pileup events')
3430 IF(MSTU(21).GE.1) GOTO 310
3431 ENDIF
3432 MINT(82)=IPILE
3433
3434C...Generate variables of hard scattering.
3435 MINT(51)=0
3436 MSTI(52)=0
3437 100 CONTINUE
3438 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3439 MINT(31)=0
3440 MINT(39)=0
3441 MINT(36)=0
3442 MINT(51)=0
3443 MINT(57)=0
3444 CALL PYRAND
3445 IF(MSTI(61).EQ.1) THEN
3446 MINT(5)=MINT(5)-1
3447 RETURN
3448 ENDIF
3449 IF(MINT(51).EQ.2) RETURN
3450 ISUB=MINT(1)
3451 IF(MSTP(111).EQ.-1) GOTO 290
3452
3453C...Loopback point if PYPREP fails, especially for junction topologies.
3454 NPREP=0
3455 MNT31S=MINT(31)
3456 110 NPREP=NPREP+1
3457 MINT(31)=MNT31S
3458
3459 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3460C...Hard scattering (including low-pT):
3461C...reconstruct kinematics and colour flow of hard scattering.
3462 MINT31=MINT(31)
3463 120 MINT(31)=MINT31
3464 MINT(51)=0
3465 CALL PYSCAT
3466 IF(MINT(51).EQ.1) GOTO 100
3467 NPARTD=N
3468 NFIN=N
3469
3470C...Intertwined initial state showers and multiple interactions.
3471C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3472C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3473 MSTP61=MSTP(61)
3474 IF (MINT(47).LT.2) MSTP(61)=0
3475 MSTP81=MSTP(81)
3476 IF (MINT(50).EQ.0) MSTP(81)=0
3477 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3478 & MINT(111).NE.12) THEN
3479C...Absolute max pT2 scale for evolution: phase space limit.
3480 PT2MXS=0.25D0*VINT(2)
3481C...Check if more constrained by ISR and MI max scales:
3482 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3483C...Loopback point in case of failure in evolution.
3484 LOOP=0
3485 130 LOOP=LOOP+1
3486 MINT(51)=0
3487 IF(LOOP.GT.100) THEN
3488 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3489 & //'multiple interactions.')
3490 MINT(51)=1
3491 RETURN
3492 ENDIF
3493
3494C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3495C...once per event. (E.g. compute constants and save variables to be
3496C...restored later in case of failure.)
3497 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3498
3499C...Initialize interleaved MI/ISR/JI evolution.
3500C...PT2MAX: absolute upper limit for evolution - Initialization may
3501C... return a PT2MAX which is lower than this.
3502C...PT2MIN: absolute lower limit for evolution - Initialization may
3503C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3504 PT2MAX=PT2MXS
3505 PT2MIN=0D0
3506 CALL PYEVOL(0,PT2MAX,PT2MIN)
3507 IF (MINT(51).EQ.1) GOTO 130
3508
3509C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3510C...In principle factorized, so can be stopped and restarted.
3511C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3512C PT2MED=MAX(10D0**2,PT2MIN)
3513C CALL PYEVOL(1,PT2MAX,PT2MED)
3514C IF (MINT(51).EQ.1) GOTO 160
3515C PT2MAX=PT2MED
3516 CALL PYEVOL(1,PT2MAX,PT2MIN)
3517 IF (MINT(51).EQ.1) GOTO 130
3518
3519C...Finalize interleaved MI/ISR/JI evolution.
3520 CALL PYEVOL(2,PT2MAX,PT2MIN)
3521 IF (MINT(51).EQ.1) GOTO 130
3522
3523 ENDIF
3524 MSTP(61)=MSTP61
3525 MSTP(81)=MSTP81
3526 IF(MINT(51).EQ.1) GOTO 100
3527C...(MINT(52) is actually obsolete in this routine. Set anyway
3528C...to ensure PYDOCU stable.)
3529 MINT(52)=N
3530 MINT(53)=N
3531
3532C...Beam remnants - new scheme.
3533 140 IF(MINT(50).EQ.1) THEN
3534 IF (ISUB.EQ.95) MINT(31)=1
3535
3536C...Beam remnant flavour and colour assignments - new scheme.
3537 CALL PYMIHK
3538 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3539 & GOTO 120
3540 IF(MINT(51).EQ.1) GOTO 100
3541
3542C...Primordial kT and beam remnant momentum sharing - new scheme.
3543 CALL PYMIRM
3544 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3545 & GOTO 120
3546 IF(MINT(51).EQ.1) GOTO 100
3547 IF (ISUB.EQ.95) MINT(31)=0
3548 ELSEIF(MINT(111).NE.12) THEN
3549C...Hadron remnants and primordial kT - old model.
3550C...Happens e.g. for direct photon on one side.
3551 IPU1=IMI(1,1,1)
3552 IPU2=IMI(2,1,1)
3553 CALL PYREMN(IPU1,IPU2)
3554 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3555 & 110
3556 IF(MINT(51).EQ.1) GOTO 100
3557C...PYREMN does not set colour tags for BRs, so needs to be done now.
3558 DO 160 I=MINT(53)+1,N
3559 DO 150 KCS=4,5
3560 IDA=MOD(K(I,KCS),MSTU(5))
3561 IF (IDA.NE.0) THEN
3562 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3563 ELSE
3564 MCT(I,KCS-3)=0
3565 ENDIF
3566 150 CONTINUE
3567 160 CONTINUE
3568C...Instruct PYPREP to use colour tags
3569 MINT(33)=1
3570C...Now delete any colour processing information if set (since partons
3571C...otherwise not FS showered!)
3572 DO 170 I=MINT(84)+1,N
3573 IF (I.LE.N) THEN
3574 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3575 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3576 ENDIF
3577 170 CONTINUE
3578 ENDIF
3579
3580C...Showering of final state partons (optional).
3581 ALAMSV=PARJ(81)
3582 PARJ(81)=PARP(72)
3583 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3584 & THEN
3585 QMAX=VINT(55)
3586 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3587 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3588 ENDIF
3589 PARJ(81)=ALAMSV
3590
3591C...Decay of final state resonances.
3592 MINT(32)=0
3593 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3594 CALL PYRESD(0)
3595 IF(MINT(51).NE.0) GOTO 100
3596
3597C...External processes: handle successive showers.
3598 ELSEIF(ISET(ISUB).EQ.11) THEN
3599 CALL PYADSH(NFIN)
3600 ENDIF
3601 IF(MINT(51).EQ.1) GOTO 100
3602
3603 ELSEIF(ISUB.NE.99) THEN
3604C...Diffractive and elastic scattering.
3605 CALL PYDIFF
3606
3607 ELSE
3608C...DIS scattering (photon flux external).
3609 CALL PYDISG
3610 IF(MINT(51).EQ.1) GOTO 100
3611 ENDIF
3612
3613C...Check that no odd resonance left undecayed.
3614 MINT(54)=N
3615 IF(MSTP(111).GE.1) THEN
3616 NFIX=N
3617 DO 180 I=MINT(84)+1,NFIX
3618 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3619 & K(I,2).NE.22) THEN
3620 KCA=PYCOMP(K(I,2))
3621 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3622 CALL PYRESD(I)
3623 IF(MINT(51).EQ.1) GOTO 100
3624 ENDIF
3625 ENDIF
3626 180 CONTINUE
3627 ENDIF
3628
3629C...Boost hadronic subsystem to overall rest frame.
3630C..(Only relevant when photon inside lepton beam.)
3631 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3632
3633C...Recalculate energies from momenta and masses (if desired).
3634 IF(MSTP(113).GE.1) THEN
3635 DO 190 I=MINT(83)+1,N
3636 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3637 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3638 190 CONTINUE
3639 NRECAL=N
3640 ENDIF
3641
3642C...Colour reconnection before string formation
3643 CALL PYFSCR(MINT(84)+1)
3644
3645C...Rearrange partons along strings, check invariant mass cuts.
3646 MSTU(28)=0
3647 IF(MSTP(111).LE.0) MSTJ(14)=-1
3648 CALL PYPREP(MINT(84)+1)
3649 MSTJ(14)=MSTJ14
3650 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3651 MSTU(24)=0
3652 GOTO 100
3653 ENDIF
3654 IF(MINT(51).EQ.1) GOTO 110
3655 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3656 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3657 DO 220 I=MINT(84)+1,N
3658 IF(K(I,2).EQ.94) THEN
3659 DO 210 I1=I+1,MIN(N,I+10)
3660 IF(K(I1,3).EQ.I) THEN
3661 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3662 IF(K(I1,3).EQ.0) THEN
3663 DO 200 II=MINT(84)+1,I-1
3664 IF(K(II,2).EQ.K(I1,2)) THEN
3665 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3666 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3667 ENDIF
3668 200 CONTINUE
3669 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3670 ENDIF
3671 ENDIF
3672 210 CONTINUE
3673 ENDIF
3674 220 CONTINUE
3675 CALL PYEDIT(12)
3676 CALL PYEDIT(14)
3677 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3678 IF(MSTP(125).EQ.0) MINT(4)=0
3679 DO 240 I=MINT(83)+1,N
3680 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3681 DO 230 I1=I+1,N
3682 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3683 IF(K(I1,3).EQ.I) K(I,5)=I1
3684 230 CONTINUE
3685 ENDIF
3686 240 CONTINUE
3687 ENDIF
3688
3689C...Introduce separators between sections in PYLIST event listing.
3690 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3691 MSTU70=1
3692 MSTU(71)=N
3693 ELSEIF(IPILE.EQ.1) THEN
3694 MSTU70=3
3695 MSTU(71)=2
3696 MSTU(72)=MINT(4)
3697 MSTU(73)=N
3698 ENDIF
3699
3700C...Go back to lab frame (needed for vertices, also in fragmentation).
3701 CALL PYFRAM(1)
3702
3703C...Set nonvanishing production vertex (optional).
3704 IF(MSTP(151).EQ.1) THEN
3705 DO 250 J=1,4
3706 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3707 & SIN(PARU(2)*PYR(0))
3708 250 CONTINUE
3709 DO 270 I=MINT(83)+1,N
3710 DO 260 J=1,4
3711 V(I,J)=V(I,J)+VTX(J)
3712 260 CONTINUE
3713 270 CONTINUE
3714 ENDIF
3715
3716C...Perform hadronization (if desired).
3717 IF(MSTP(111).GE.1) THEN
3718 CALL PYEXEC
3719 IF(MSTU(24).NE.0) GOTO 100
3720 ENDIF
3721 IF(MSTP(113).GE.1) THEN
3722 DO 280 I=NRECAL,N
3723 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3724 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3725 280 CONTINUE
3726 ENDIF
3727 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3728
3729C...Store event information and calculate Monte Carlo estimates of
3730C...subprocess cross-sections.
3731 290 IF(IPILE.EQ.1) CALL PYDOCU
3732
3733C...Set counters for current pileup event and loop to next one.
3734 MSTI(41)=IPILE
3735 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3736 IF(MSTU70.LT.10) THEN
3737 MSTU70=MSTU70+1
3738 MSTU(70+MSTU70)=N
3739 ENDIF
3740 MINT(83)=N
3741 MINT(84)=N+MSTP(126)
3742 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3743 300 CONTINUE
3744
3745C...Generic information on pileup events. Reconstruct missing history.
3746 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3747 PARI(91)=VINT(132)
3748 PARI(92)=VINT(133)
3749 PARI(93)=VINT(134)
3750 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3751 ENDIF
3752 CALL PYEDIT(16)
3753
3754C...Transform to the desired coordinate frame.
3755 310 CALL PYFRAM(MSTP(124))
3756 MSTU(70)=MSTU70
3757 PARU(21)=VINT(1)
3758
3759C...Error messages
3760 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3761 &1X,'Execution stopped.')
3762
3763 RETURN
3764 END
3765
3766
3767C***********************************************************************
3768
3769C...PYSTAT
3770C...Prints out information about cross-sections, decay widths, branching
3771C...ratios, kinematical limits, status codes and parameter values.
3772
3773 SUBROUTINE PYSTAT(MSTAT)
3774
3775C...Double precision and integer declarations.
3776 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3777 IMPLICIT INTEGER(I-N)
3778 INTEGER PYK,PYCHGE,PYCOMP
3779C...Parameter statement to help give large particle numbers.
3780 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3781 &KEXCIT=4000000,KDIMEN=5000000)
3782 PARAMETER (EPS=1D-3)
3783C...Commonblocks.
3784 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3785 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3786 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3787 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3788 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3789 COMMON/PYINT1/MINT(400),VINT(400)
3790 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3791 COMMON/PYINT4/MWID(500),WIDS(500,5)
3792 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3793 COMMON/PYINT6/PROC(0:500)
3794 CHARACTER PROC*28, CHTMP*16
3795 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3796 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3797 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3798 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3799C...Local arrays, character variables and data.
3800 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3801 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3802 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3803 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3804 CHARACTER*24 CHD0, CHDC(10)
3805 CHARACTER*6 DNAME(3)
3806 DATA PROGA/
3807 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3808 &'VMD/hadron * anomalous ','direct * direct ',
3809 &'direct * anomalous ','anomalous * anomalous '/
3810 DATA DISGA/'e * VMD','e * anomalous'/
3811 DATA PROGG9/
3812 &'direct * direct ','direct * VMD ',
3813 &'direct * anomalous ','VMD * direct ',
3814 &'VMD * VMD ','VMD * anomalous ',
3815 &'anomalous * direct ','anomalous * VMD ',
3816 &'anomalous * anomalous ','DIS * VMD ',
3817 &'DIS * anomalous ','VMD * DIS ',
3818 &'anomalous * DIS '/
3819 DATA PROGG4/
3820 &'direct * direct ','direct * resolved ',
3821 &'resolved * direct ','resolved * resolved '/
3822 DATA PROGG2/
3823 &'direct * hadron ','resolved * hadron '/
3824 DATA PROGP4/
3825 &'VMD * hadron ','direct * hadron ',
3826 &'anomalous * hadron ','DIS * hadron '/
3827 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3828 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3829 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3830 &' y*_small ',' eta*_large ',' eta*_small ',
3831 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3832 &' x_2 ',' x_F ',' cos(theta_hard) ',
3833 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3834 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3835 &' tau'' '/
3836 DATA DNAME /'q ','lepton','nu '/
3837
3838C...Cross-sections.
3839 IF(MSTAT.LE.1) THEN
3840 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3841 WRITE(MSTU(11),5000)
3842 WRITE(MSTU(11),5100)
3843 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3844 DO 100 I=1,500
3845 IF(MSUB(I).NE.1) GOTO 100
3846 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3847 100 CONTINUE
3848 IF(MINT(121).GT.1) THEN
3849 WRITE(MSTU(11),5300)
3850 DO 110 IGA=1,MINT(121)
3851 CALL PYSAVE(3,IGA)
3852 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3853 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3854 & XSEC(0,3)
3855 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3856 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3857 & XSEC(0,3)
3858 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3859 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3860 & XSEC(0,3)
3861 ELSEIF(MINT(121).EQ.4) THEN
3862 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3863 & XSEC(0,3)
3864 ELSEIF(MINT(121).EQ.2) THEN
3865 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3866 & XSEC(0,3)
3867 ELSE
3868 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3869 & XSEC(0,3)
3870 ENDIF
3871 110 CONTINUE
3872 CALL PYSAVE(5,0)
3873 ENDIF
3874 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3875 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3876
3877C...Decay widths and branching ratios.
3878 ELSEIF(MSTAT.EQ.2) THEN
3879 WRITE(MSTU(11),5500)
3880 WRITE(MSTU(11),5600)
3881 DO 140 KC=1,500
3882 KF=KCHG(KC,4)
3883 CALL PYNAME(KF,CHKF)
3884 IOFF=0
3885 IF(KC.LE.22) THEN
3886 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3887 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3888 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3889 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3890 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3891 ELSE
3892 IF(MWID(KC).LE.0) GOTO 140
3893 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3894 & KF/KSUSY1.EQ.2)) GOTO 140
3895 ENDIF
3896C...Off-shell branchings.
3897 IF(IOFF.EQ.1) THEN
3898 NGP=0
3899 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3900 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3901 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3902 DO 120 J=1,MDCY(KC,3)
3903 IDC=J+MDCY(KC,2)-1
3904 NGP1=0
3905 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3906 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3907 NGP2=0
3908 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3909 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3910 CALL PYNAME(KFDP(IDC,1),CHD1)
3911 CALL PYNAME(KFDP(IDC,2),CHD2)
3912 IF(KFDP(IDC,3).EQ.0) THEN
3913 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3914 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3915 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3916 ELSE
3917 CALL PYNAME(KFDP(IDC,3),CHD3)
3918 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3919 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3920 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3921 ENDIF
3922 120 CONTINUE
3923C...On-shell decays.
3924 ELSE
3925 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3926 BRFIN=1D0
3927 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3928 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3929 & STATE(MDCY(KC,1)),BRFIN
3930 DO 130 J=1,MDCY(KC,3)
3931 IDC=J+MDCY(KC,2)-1
3932 NGP1=0
3933 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3934 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3935 NGP2=0
3936 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3937 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3938 BRPRI=0D0
3939 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
3940 BRFIN=0D0
3941 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
3942 CALL PYNAME(KFDP(IDC,1),CHD1)
3943 CALL PYNAME(KFDP(IDC,2),CHD2)
3944 IF(KFDP(IDC,3).EQ.0) THEN
3945 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3946 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3947 & CHD2(1:10),WDTP(J),BRPRI,
3948 & STATE(MDME(IDC,1)),BRFIN
3949 ELSE
3950 CALL PYNAME(KFDP(IDC,3),CHD3)
3951 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
3952 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3953 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
3954 & STATE(MDME(IDC,1)),BRFIN
3955 ENDIF
3956 130 CONTINUE
3957 ENDIF
3958 140 CONTINUE
3959 WRITE(MSTU(11),6000)
3960
3961C...Allowed incoming partons/particles at hard interaction.
3962 ELSEIF(MSTAT.EQ.3) THEN
3963 WRITE(MSTU(11),6100)
3964 CALL PYNAME(MINT(11),CHAU)
3965 CHIN(1)=CHAU(1:12)
3966 CALL PYNAME(MINT(12),CHAU)
3967 CHIN(2)=CHAU(1:12)
3968 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
3969 DO 150 I=-20,22
3970 IF(I.EQ.0) GOTO 150
3971 IA=IABS(I)
3972 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
3973 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
3974 CALL PYNAME(I,CHAU)
3975 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
3976 & STATE(KFIN(2,I))
3977 150 CONTINUE
3978 WRITE(MSTU(11),6400)
3979
3980C...User-defined limits on kinematical variables.
3981 ELSEIF(MSTAT.EQ.4) THEN
3982 WRITE(MSTU(11),6500)
3983 WRITE(MSTU(11),6600)
3984 SHRMAX=CKIN(2)
3985 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
3986 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
3987 PTHMIN=MAX(CKIN(3),CKIN(5))
3988 PTHMAX=CKIN(4)
3989 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
3990 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
3991 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
3992 DO 160 I=4,14
3993 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
3994 160 CONTINUE
3995 SPRMAX=CKIN(32)
3996 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
3997 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
3998 WRITE(MSTU(11),7000)
3999
4000C...Status codes and parameter values.
4001 ELSEIF(MSTAT.EQ.5) THEN
4002 WRITE(MSTU(11),7100)
4003 WRITE(MSTU(11),7200)
4004 DO 170 I=1,100
4005 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4006 & PARP(100+I)
4007 170 CONTINUE
4008
4009C...List of all processes implemented in the program.
4010 ELSEIF(MSTAT.EQ.6) THEN
4011 WRITE(MSTU(11),7400)
4012 WRITE(MSTU(11),7500)
4013 DO 180 I=1,500
4014 IF(ISET(I).LT.0) GOTO 180
4015 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4016 180 CONTINUE
4017 WRITE(MSTU(11),7700)
4018
4019 ELSEIF(MSTAT.EQ.7) THEN
4020 WRITE (MSTU(11),8000)
4021 NMODES(0)=0
4022 NMODES(10)=0
4023 NMODES(9)=0
4024 DO 290 ILR=1,2
4025 DO 280 KFSM=1,16
4026 KFSUSY=ILR*KSUSY1+KFSM
4027 NRVDC=0
4028C...SDOWN DECAYS
4029 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4030 NRVDC=3
4031 DO 190 I=1,NRVDC
4032 PBRAT(I)=0D0
4033 NMODES(I)=0
4034 190 CONTINUE
4035 CALL PYNAME(KFSUSY,CHTMP)
4036 CHD0=CHTMP//' '
4037 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4038 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4039 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4040 KC=PYCOMP(KFSUSY)
4041 DO 200 J=1,MDCY(KC,3)
4042 IDC=J+MDCY(KC,2)-1
4043 ID1=IABS(KFDP(IDC,1))
4044 ID2=IABS(KFDP(IDC,2))
4045 IF (KFDP(IDC,3).EQ.0) THEN
4046 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4047 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4048 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4049 NMODES(1)=NMODES(1)+1
4050 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4051 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4052 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4053 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4054 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4055 NMODES(2)=NMODES(2)+1
4056 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4057 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4058 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4059 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4060 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4061 NMODES(3)=NMODES(3)+1
4062 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4063 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4064 ENDIF
4065 ENDIF
4066 200 CONTINUE
4067 ENDIF
4068C...SUP DECAYS
4069 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4070 NRVDC=2
4071 DO 210 I=1,NRVDC
4072 NMODES(I)=0
4073 PBRAT(I)=0D0
4074 210 CONTINUE
4075 CALL PYNAME(KFSUSY,CHTMP)
4076 CHD0=CHTMP//' '
4077 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4078 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4079 KC=PYCOMP(KFSUSY)
4080 DO 220 J=1,MDCY(KC,3)
4081 IDC=J+MDCY(KC,2)-1
4082 ID1=IABS(KFDP(IDC,1))
4083 ID2=IABS(KFDP(IDC,2))
4084 IF (KFDP(IDC,3).EQ.0) THEN
4085 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4086 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4087 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4088 NMODES(1)=NMODES(1)+1
4089 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4090 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4091 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4092 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4093 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4094 NMODES(2)=NMODES(2)+1
4095 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4096 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4097 ENDIF
4098 ENDIF
4099 220 CONTINUE
4100 ENDIF
4101C...SLEPTON DECAYS
4102 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4103 NRVDC=2
4104 DO 230 I=1,NRVDC
4105 PBRAT(I)=0D0
4106 NMODES(I)=0
4107 230 CONTINUE
4108 CALL PYNAME(KFSUSY,CHTMP)
4109 CHD0=CHTMP//' '
4110 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4111 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4112 KC=PYCOMP(KFSUSY)
4113 DO 240 J=1,MDCY(KC,3)
4114 IDC=J+MDCY(KC,2)-1
4115 ID1=IABS(KFDP(IDC,1))
4116 ID2=IABS(KFDP(IDC,2))
4117 IF (KFDP(IDC,3).EQ.0) THEN
4118 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4119 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4120 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4121 NMODES(1)=NMODES(1)+1
4122 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4123 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4124 ENDIF
4125 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4126 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4127 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4128 NMODES(2)=NMODES(2)+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 240 CONTINUE
4134 ENDIF
4135C...SNEUTRINO DECAYS
4136 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4137 & THEN
4138 NRVDC=2
4139 DO 250 I=1,NRVDC
4140 PBRAT(I)=0D0
4141 NMODES(I)=0
4142 250 CONTINUE
4143 CALL PYNAME(KFSUSY,CHTMP)
4144 CHD0=CHTMP//' '
4145 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4146 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4147 KC=PYCOMP(KFSUSY)
4148 DO 260 J=1,MDCY(KC,3)
4149 IDC=J+MDCY(KC,2)-1
4150 ID1=IABS(KFDP(IDC,1))
4151 ID2=IABS(KFDP(IDC,2))
4152 IF (KFDP(IDC,3).EQ.0) THEN
4153 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4154 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4155 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4156 NMODES(1)=NMODES(1)+1
4157 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4158 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4159 ENDIF
4160 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4161 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4162 NMODES(2)=NMODES(2)+1
4163 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4164 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4165 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4166 ENDIF
4167 ENDIF
4168 260 CONTINUE
4169 ENDIF
4170 IF (NRVDC.NE.0) THEN
4171 DO 270 I=1,NRVDC
4172 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4173 NMODES(0)=NMODES(0)+NMODES(I)
4174 270 CONTINUE
4175 ENDIF
4176 280 CONTINUE
4177 290 CONTINUE
4178 DO 370 KFSM=21,37
4179 KFSUSY=KSUSY1+KFSM
4180 NRVDC=0
4181C...NEUTRALINO DECAYS
4182 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4183 NRVDC=4
4184 DO 300 I=1,NRVDC
4185 PBRAT(I)=0D0
4186 NMODES(I)=0
4187 300 CONTINUE
4188 CALL PYNAME(KFSUSY,CHTMP)
4189 CHD0=CHTMP//' '
4190 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4191 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4192 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4193 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4194 KC=PYCOMP(KFSUSY)
4195 DO 310 J=1,MDCY(KC,3)
4196 IDC=J+MDCY(KC,2)-1
4197 ID1=IABS(KFDP(IDC,1))
4198 ID2=IABS(KFDP(IDC,2))
4199 ID3=IABS(KFDP(IDC,3))
4200 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4201 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4202 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4203 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4204 NMODES(1)=NMODES(1)+1
4205 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4206 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4207 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4208 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4209 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4210 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4211 NMODES(2)=NMODES(2)+1
4212 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4213 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4214 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4215 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4216 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4217 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4218 NMODES(3)=NMODES(3)+1
4219 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4220 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4221 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4222 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4223 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4224 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4225 NMODES(4)=NMODES(4)+1
4226 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4227 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4228 ENDIF
4229 310 CONTINUE
4230 ENDIF
4231C...CHARGINO DECAYS
4232 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4233 NRVDC=5
4234 DO 320 I=1,NRVDC
4235 PBRAT(I)=0D0
4236 NMODES(I)=0
4237 320 CONTINUE
4238 CALL PYNAME(KFSUSY,CHTMP)
4239 CHD0=CHTMP//' '
4240 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4241 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4242 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4243 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4244 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4245 KC=PYCOMP(KFSUSY)
4246 DO 330 J=1,MDCY(KC,3)
4247 IDC=J+MDCY(KC,2)-1
4248 ID1=IABS(KFDP(IDC,1))
4249 ID2=IABS(KFDP(IDC,2))
4250 ID3=IABS(KFDP(IDC,3))
4251 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4252 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4253 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4254 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4255 NMODES(1)=NMODES(1)+1
4256 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4257 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4258 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4259 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4260 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4261 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4262 NMODES(1)=NMODES(1)+1
4263 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4264 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4265 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4266 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4267 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4268 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4269 NMODES(2)=NMODES(2)+1
4270 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4271 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4272 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4273 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4274 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4275 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4276 NMODES(3)=NMODES(3)+1
4277 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4278 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4279 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4280 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4281 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4282 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4283 NMODES(3)=NMODES(3)+1
4284 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4285 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4286 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4287 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4288 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4289 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4290 NMODES(4)=NMODES(4)+1
4291 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4292 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4293 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4294 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4295 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4296 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4297 NMODES(4)=NMODES(4)+1
4298 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4299 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4300 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4301 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4302 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4303 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4304 NMODES(5)=NMODES(5)+1
4305 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4306 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4307 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4308 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4309 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4310 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4311 NMODES(5)=NMODES(5)+1
4312 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4313 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4314 ENDIF
4315 330 CONTINUE
4316 ENDIF
4317C...GLUINO DECAYS
4318 IF (KFSM.EQ.21) THEN
4319 NRVDC=3
4320 DO 340 I=1,NRVDC
4321 PBRAT(I)=0D0
4322 NMODES(I)=0
4323 340 CONTINUE
4324 CALL PYNAME(KFSUSY,CHTMP)
4325 CHD0=CHTMP//' '
4326 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4327 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4328 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4329 KC=PYCOMP(KFSUSY)
4330 DO 350 J=1,MDCY(KC,3)
4331 IDC=J+MDCY(KC,2)-1
4332 ID1=IABS(KFDP(IDC,1))
4333 ID2=IABS(KFDP(IDC,2))
4334 ID3=IABS(KFDP(IDC,3))
4335 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4336 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4337 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4338 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4339 NMODES(1)=NMODES(1)+1
4340 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4341 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4342 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4343 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4344 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4345 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4346 NMODES(2)=NMODES(2)+1
4347 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4348 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4349 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4350 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4351 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4352 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4353 NMODES(3)=NMODES(3)+1
4354 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4355 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4356 ENDIF
4357 350 CONTINUE
4358 ENDIF
4359
4360 IF (NRVDC.NE.0) THEN
4361 DO 360 I=1,NRVDC
4362 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4363 NMODES(0)=NMODES(0)+NMODES(I)
4364 360 CONTINUE
4365 ENDIF
4366 370 CONTINUE
4367 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4368
4369 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4370 WRITE (MSTU(11),8500)
4371 DO 400 IRV=1,3
4372 DO 390 JRV=1,3
4373 DO 380 KRV=1,3
4374 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4375 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4376 380 CONTINUE
4377 390 CONTINUE
4378 400 CONTINUE
4379 WRITE (MSTU(11),8600)
4380 ENDIF
4381 ENDIF
4382
4383C...Formats for printouts.
4384 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4385 &'Events and Cross-sections',1X,9('*'))
4386 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4387 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4388 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4389 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4390 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4391 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4392 &'I',12X,'I')
4393 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4394 &D10.3,1X,'I')
4395 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4396 &1X,'I',34X,'I',28X,'I',12X,'I')
4397 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4398 &1X,'********* Total number of errors, excluding junctions =',
4399 &1X,I8,' *************'/
4400 &1X,'********* Total number of errors, including junctions =',
4401 &1X,I8,' *************'/
4402 &1X,'********* Total number of warnings = ',
4403 &1X,I8,' *************'/
4404 &1X,'********* Fraction of events that fail fragmentation ',
4405 &'cuts =',1X,F8.5,' *********'/)
4406 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4407 &'Ratios',1X,27('*'))
4408 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4409 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4410 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4411 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4412 &1X,98('='))
4413 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4414 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4415 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4416 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4417 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4418 &1P,D10.3,0P,1X,'I')
4419 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4420 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4421 &1P,D10.3,0P,1X,'I')
4422 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4423 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4424 &'Particles at Hard Interaction',1X,7('*'))
4425 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4426 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4427 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4428 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4429 &78('=')/1X,'I',38X,'I',37X,'I')
4430 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4431 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4432 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4433 &'Kinematical Variables',1X,12('*'))
4434 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4435 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4436 &16X,'I')
4437 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4438 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4439 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4440 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4441 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4442 &'Parameter Values',1X,12('*'))
4443 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4444 &'PARP(I)'/)
4445 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4446 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4447 &1X,13('*'))
4448 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4449 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4450 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4451 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4452 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4453 8000 FORMAT(1X/ 1X/
4454 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4455 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4456 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4457 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4458 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4459 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4460 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4461 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4462 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4463 & /1X,70('='))
4464 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4465 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4466 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4467 8500 FORMAT(1X/ 1X/
4468 & 1X,'R-Violating couplings',1X/ 1X /
4469 & 1X,55('=')/
4470 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4471 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4472 & ,'I',15X,'I',15X,'I',15X,'I')
4473 8600 FORMAT(1X,55('='))
4474 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4475 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4476
4477 RETURN
4478 END
4479
4480C*********************************************************************
4481
4482C...PYUPEV
4483C...Administers the hard-process generation required for output to the
4484C...Les Houches event record.
4485
4486 SUBROUTINE PYUPEV
4487
4488C...Double precision and integer declarations.
4489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4490 IMPLICIT INTEGER(I-N)
4491 INTEGER PYK,PYCHGE,PYCOMP
4492
4493C...Commonblocks.
4494 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4495 COMMON/PYCTAG/NCT,MCT(4000,2)
4496 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4497 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4498 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4499 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4500 COMMON/PYINT1/MINT(400),VINT(400)
4501 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4502 COMMON/PYINT4/MWID(500),WIDS(500,5)
4503 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4504 &/PYINT1/,/PYINT2/,/PYINT4/
4505
4506C...HEPEUP for output.
4507 INTEGER MAXNUP
4508 PARAMETER (MAXNUP=500)
4509 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4510 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4511 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4512 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4513 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4514 SAVE /HEPEUP/
4515
4516C...Stop if no subprocesses on.
4517 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4518 WRITE(MSTU(11),5100)
4519 STOP
4520 ENDIF
4521
4522C...Special flags for hard-process generation only.
4523 MSTP71=MSTP(71)
4524 MSTP(71)=0
4525 MST128=MSTP(128)
4526 MSTP(128)=1
4527
4528C...Initial values for some counters.
4529 N=0
4530 MINT(5)=MINT(5)+1
4531 MINT(7)=0
4532 MINT(8)=0
4533 MINT(30)=0
4534 MINT(83)=0
4535 MINT(84)=MSTP(126)
4536 MSTU(24)=0
4537 MSTU70=0
4538 MSTJ14=MSTJ(14)
4539C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4540 MINT(33)=0
4541
4542C...If variable energies: redo incoming kinematics and cross-section.
4543 MSTI(61)=0
4544 IF(MSTP(171).EQ.1) THEN
4545 CALL PYINKI(1)
4546 IF(MSTI(61).EQ.1) THEN
4547 MINT(5)=MINT(5)-1
4548 RETURN
4549 ENDIF
4550 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4551 CALL PYXTOT
4552 ENDIF
4553
4554C...Do not allow pileup events.
4555 MINT(82)=1
4556
4557C...Generate variables of hard scattering.
4558 MINT(51)=0
4559 MSTI(52)=0
4560 100 CONTINUE
4561 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4562 MINT(31)=0
4563 MINT(51)=0
4564 MINT(57)=0
4565 CALL PYRAND
4566 IF(MSTI(61).EQ.1) THEN
4567 MINT(5)=MINT(5)-1
4568 RETURN
4569 ENDIF
4570 IF(MINT(51).EQ.2) RETURN
4571 ISUB=MINT(1)
4572
4573 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4574C...Hard scattering (including low-pT):
4575C...reconstruct kinematics and colour flow of hard scattering.
4576 MINT31=MINT(31)
4577 110 MINT(31)=MINT31
4578 MINT(51)=0
4579 CALL PYSCAT
4580 IF(MINT(51).EQ.1) GOTO 100
4581 IPU1=MINT(84)+1
4582 IPU2=MINT(84)+2
4583
4584C...Decay of final state resonances.
4585 MINT(32)=0
4586 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4587 & CALL PYRESD(0)
4588 IF(MINT(51).EQ.1) GOTO 100
4589 MINT(52)=N
4590
4591C...Longitudinal boost of hard scattering.
4592 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4593 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4594
4595 ELSEIF(ISUB.NE.99) THEN
4596C...Diffractive and elastic scattering.
4597 CALL PYDIFF
4598
4599 ELSE
4600C...DIS scattering (photon flux external).
4601 CALL PYDISG
4602 IF(MINT(51).EQ.1) GOTO 100
4603 ENDIF
4604
4605C...Check that no odd resonance left undecayed.
4606 MINT(54)=N
4607 NFIX=N
4608 DO 120 I=MINT(84)+1,NFIX
4609 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4610 & K(I,2).NE.22) THEN
4611 KCA=PYCOMP(K(I,2))
4612 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4613 CALL PYRESD(I)
4614 IF(MINT(51).EQ.1) GOTO 100
4615 ENDIF
4616 ENDIF
4617 120 CONTINUE
4618
4619C...Boost hadronic subsystem to overall rest frame.
4620C..(Only relevant when photon inside lepton beam.)
4621 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4622
4623C...Store event information and calculate Monte Carlo estimates of
4624C...subprocess cross-sections.
4625 130 CALL PYDOCU
4626
4627C...Transform to the desired coordinate frame.
4628 140 CALL PYFRAM(MSTP(124))
4629 MSTU(70)=MSTU70
4630 PARU(21)=VINT(1)
4631
4632C...Restore special flags for hard-process generation only.
4633 MSTP(71)=MSTP71
4634 MSTP(128)=MST128
4635
4636C...Trace colour tags; convert to LHA style labels.
4637 NCT=100
4638 DO 150 I=MINT(84)+1,N
4639 MCT(I,1)=0
4640 MCT(I,2)=0
4641 150 CONTINUE
4642 DO 160 I=MINT(84)+1,N
4643 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4644 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4645 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4646 & THEN
4647 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4648 IDA=MOD(K(I,4),MSTU(5))
4649 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4650 & MCT(IMO,2).NE.0) THEN
4651 MCT(I,1)=MCT(IMO,2)
4652 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4653 & MCT(IMO,1).NE.0) THEN
4654 MCT(I,1)=MCT(IMO,1)
4655 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4656 & MCT(IDA,2).NE.0) THEN
4657 MCT(I,1)=MCT(IDA,2)
4658 ELSE
4659 NCT=NCT+1
4660 MCT(I,1)=NCT
4661 ENDIF
4662 ENDIF
4663 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4664 & THEN
4665 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4666 IDA=MOD(K(I,5),MSTU(5))
4667 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4668 & MCT(IMO,1).NE.0) THEN
4669 MCT(I,2)=MCT(IMO,1)
4670 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4671 & MCT(IMO,2).NE.0) THEN
4672 MCT(I,2)=MCT(IMO,2)
4673 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4674 & MCT(IDA,1).NE.0) THEN
4675 MCT(I,2)=MCT(IDA,1)
4676 ELSE
4677 NCT=NCT+1
4678 MCT(I,2)=NCT
4679 ENDIF
4680 ENDIF
4681 ENDIF
4682 160 CONTINUE
4683
4684C...Put event in HEPEUP commonblock.
4685 NUP=N-MINT(84)
4686 IDPRUP=MINT(1)
4687 XWGTUP=1D0
4688 SCALUP=VINT(53)
4689 AQEDUP=VINT(57)
4690 AQCDUP=VINT(58)
4691 DO 180 I=1,NUP
4692 IDUP(I)=K(I+MINT(84),2)
4693 IF(I.LE.2) THEN
4694 ISTUP(I)=-1
4695 MOTHUP(1,I)=0
4696 MOTHUP(2,I)=0
4697 ELSEIF(K(I+4,3).EQ.0) THEN
4698 ISTUP(I)=1
4699 MOTHUP(1,I)=1
4700 MOTHUP(2,I)=2
4701 ELSE
4702 ISTUP(I)=1
4703 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4704 MOTHUP(2,I)=0
4705 ENDIF
4706 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4707 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4708 ICOLUP(1,I)=MCT(I+MINT(84),1)
4709 ICOLUP(2,I)=MCT(I+MINT(84),2)
4710 DO 170 J=1,5
4711 PUP(J,I)=P(I+MINT(84),J)
4712 170 CONTINUE
4713 VTIMUP(I)=V(I,5)
4714 SPINUP(I)=9D0
4715 180 CONTINUE
4716
4717C...Optionally write out event to disk. Minimal size for time/spin fields.
4718 IF(MSTP(162).GT.0) THEN
4719 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4720 DO 190 I=1,NUP
4721 IF(VTIMUP(I).EQ.0D0) THEN
4722 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4723 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4724 & ' 0. 9.'
4725 ELSE
4726 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4727 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4728 & VTIMUP(I),' 9.'
4729 ENDIF
4730 190 CONTINUE
4731
4732C...Optional extra line with parton-density information.
4733 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4734 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4735 ENDIF
4736
4737C...Error messages and other print formats.
4738 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4739 &1X,'Execution stopped.')
4740 5200 FORMAT(1P,2I6,4E14.6)
4741 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4742 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4743 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4744
4745 RETURN
4746 END
4747
4748C*********************************************************************
4749
4750C...PYUPIN
4751C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4752C...processes, and optionally stores that information on file.
4753
4754 SUBROUTINE PYUPIN
4755
4756C...Double precision and integer declarations.
4757 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4758 IMPLICIT INTEGER(I-N)
4759
4760C...Commonblocks.
4761 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4762 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4763 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4764 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4765 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4766
4767C...User process initialization commonblock.
4768 INTEGER MAXPUP
4769 PARAMETER (MAXPUP=100)
4770 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4771 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4772 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4773 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4774 &LPRUP(MAXPUP)
4775 SAVE /HEPRUP/
4776
4777C...Store info on incoming beams.
4778 IDBMUP(1)=K(1,2)
4779 IDBMUP(2)=K(2,2)
4780 EBMUP(1)=P(1,4)
4781 EBMUP(2)=P(2,4)
4782 PDFGUP(1)=0
4783 PDFGUP(2)=0
4784 PDFSUP(1)=MSTP(51)
4785 PDFSUP(2)=MSTP(51)
4786
4787C...Event weighting strategy.
4788 IDWTUP=3
4789
4790C...Info on individual processes.
4791 NPRUP=0
4792 DO 100 ISUB=1,500
4793 IF(MSUB(ISUB).EQ.1) THEN
4794 NPRUP=NPRUP+1
4795 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4796 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4797 XMAXUP(NPRUP)=1D0
4798 LPRUP(NPRUP)=ISUB
4799 ENDIF
4800 100 CONTINUE
4801
4802C...Write info to file.
4803 IF(MSTP(161).GT.0) THEN
4804 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4805 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4806 DO 110 IPR=1,NPRUP
4807 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4808 & LPRUP(IPR)
4809 110 CONTINUE
4810 ENDIF
4811
4812C...Formats for printout.
4813 5100 FORMAT(1P,2I8,2E14.6,6I6)
4814 5200 FORMAT(1P,3E14.6,I6)
4815
4816 RETURN
4817 END
4818
4819
4820C*********************************************************************
4821
4822C...Combine the two old-style Pythia initialization and event files
4823C...into a single Les Houches Event File.
4824
4825 SUBROUTINE PYLHEF
4826
4827C...Double precision and integer declarations.
4828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4829 IMPLICIT INTEGER(I-N)
4830
4831C...PYTHIA commonblock: only used to provide read/write units and version.
4832 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4833 SAVE /PYPARS/
4834
4835C...User process initialization commonblock.
4836 INTEGER MAXPUP
4837 PARAMETER (MAXPUP=100)
4838 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4839 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4840 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4841 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4842 &LPRUP(MAXPUP)
4843 SAVE /HEPRUP/
4844
4845C...User process event common block.
4846 INTEGER MAXNUP
4847 PARAMETER (MAXNUP=500)
4848 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4849 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4850 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4851 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4852 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4853 SAVE /HEPEUP/
4854
4855C...Lines to read in assumed never longer than 200 characters.
4856 PARAMETER (MAXLEN=200)
4857 CHARACTER*(MAXLEN) STRING
4858
4859C...Format for reading lines.
4860 CHARACTER*6 STRFMT
4861 STRFMT='(A000)'
4862 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4863
4864C...Rewind initialization and event files.
4865 REWIND MSTP(161)
4866 REWIND MSTP(162)
4867
4868C...Write header info.
4869 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4870 WRITE(MSTP(163),'(A)') '<!--'
4871 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4872 &MSTP(181),'.',MSTP(182)
4873 WRITE(MSTP(163),'(A)') '-->'
4874
4875C...Read first line of initialization info and get number of processes.
4876 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4877 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4878 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4879
4880C...Copy initialization lines, omitting trailing blanks.
4881C...Embed in <init> ... </init> block.
4882 WRITE(MSTP(163),'(A)') '<init>'
4883 DO 140 IPR=0,NPRUP
4884 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4885 LEN=MAXLEN+1
4886 120 LEN=LEN-1
4887 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4888 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4889 140 CONTINUE
4890 WRITE(MSTP(163),'(A)') '</init>'
4891
4892C...Begin event loop. Read first line of event info or already done.
4893 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4894 200 CONTINUE
4895
4896C...Look at first line to know number of particles in event.
4897 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4898
4899C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4900 WRITE(MSTP(163),'(A)') '<event>'
4901 DO 240 I=0,NUP
4902 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4903 LEN=MAXLEN+1
4904 220 LEN=LEN-1
4905 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4906 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4907 240 CONTINUE
4908
4909C...Copy trailing comment lines - with a # in the first column - as is.
4910 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4911 IF(STRING(1:1).EQ.'#') THEN
4912 LEN=MAXLEN+1
4913 280 LEN=LEN-1
4914 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4915 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4916 GOTO 260
4917 ENDIF
4918
4919C..End the <event> block. Loop back to look for next event.
4920 WRITE(MSTP(163),'(A)') '</event>'
4921 GOTO 200
4922
4923C...Successfully reached end of event loop: write closing tag
4924C...and remove temporary intermediate files (unless asked not to).
4925 300 WRITE(MSTP(163),'(A)') '</event>'
4926 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4927 IF(MSTP(164).EQ.1) RETURN
4928 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4929 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
4930 RETURN
4931
4932C...Error exit.
4933 400 WRITE(*,*) ' PYLHEF file joining failed!'
4934
4935 RETURN
4936 END
4937
4938C*********************************************************************
4939
4940C...PYINRE
4941C...Calculates full and effective widths of gauge bosons, stores
4942C...masses and widths, rescales coefficients to be used for
4943C...resonance production generation.
4944
4945 SUBROUTINE PYINRE
4946
4947C...Double precision and integer declarations.
4948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4949 IMPLICIT INTEGER(I-N)
4950 INTEGER PYK,PYCHGE,PYCOMP
4951C...Parameter statement to help give large particle numbers.
4952 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4953 &KEXCIT=4000000,KDIMEN=5000000)
4954C...Commonblocks.
4955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4956 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4957 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4958 COMMON/PYDAT4/CHAF(500,2)
4959 CHARACTER CHAF*16
4960 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4961 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4962 COMMON/PYINT1/MINT(400),VINT(400)
4963 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4964 COMMON/PYINT4/MWID(500),WIDS(500,5)
4965 COMMON/PYINT6/PROC(0:500)
4966 CHARACTER PROC*28
4967 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4968 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
4969 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
4970C...Local arrays and data.
4971 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
4972 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
4973
4974C...Born level couplings in MSSM Higgs doublet sector.
4975 XW=PARU(102)
4976 XWV=XW
4977 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
4978 XW1=1D0-XW
4979 IF(MSTP(4).EQ.2) THEN
4980 TANBE=PARU(141)
4981 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
4982 SQMZ=PMAS(23,1)**2
4983 SQMW=PMAS(24,1)**2
4984 SQMH=PMAS(25,1)**2
4985 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
4986 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
4987 SQMHC=SQMA+SQMW
4988 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
4989 WRITE(MSTU(11),5000)
4990 STOP
4991 ENDIF
4992 PMAS(35,1)=SQRT(SQMHP)
4993 PMAS(36,1)=SQRT(SQMA)
4994 PMAS(37,1)=SQRT(SQMHC)
4995 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
4996 & (SQMA-SQMZ)))
4997 BESU=ATAN(TANBE)
4998 PARU(142)=1D0
4999 PARU(143)=1D0
5000 PARU(161)=-SIN(ALSU)/COS(BESU)
5001 PARU(162)=COS(ALSU)/SIN(BESU)
5002 PARU(163)=PARU(161)
5003 PARU(164)=SIN(BESU-ALSU)
5004 PARU(165)=PARU(164)
5005 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5006 PARU(171)=COS(ALSU)/COS(BESU)
5007 PARU(172)=SIN(ALSU)/SIN(BESU)
5008 PARU(173)=PARU(171)
5009 PARU(174)=COS(BESU-ALSU)
5010 PARU(175)=PARU(174)
5011 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5012 & SIN(BESU+ALSU)
5013 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5014 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5015 PARU(181)=TANBE
5016 PARU(182)=1D0/TANBE
5017 PARU(183)=PARU(181)
5018 PARU(184)=0D0
5019 PARU(185)=PARU(184)
5020 PARU(186)=COS(BESU-ALSU)
5021 PARU(187)=SIN(BESU-ALSU)
5022 PARU(188)=PARU(186)
5023 PARU(189)=PARU(187)
5024 PARU(190)=0D0
5025 PARU(195)=COS(BESU-ALSU)
5026 ENDIF
5027
5028C...Reset effective widths of gauge bosons.
5029 DO 110 I=1,500
5030 DO 100 J=1,5
5031 WIDS(I,J)=1D0
5032 100 CONTINUE
5033 110 CONTINUE
5034
5035C...Order resonances by increasing mass (except Z0 and W+/-).
5036 NRES=0
5037 DO 140 KC=1,500
5038 KF=KCHG(KC,4)
5039 IF(KF.EQ.0) GOTO 140
5040 IF(MWID(KC).EQ.0) GOTO 140
5041 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5042 IF(MSTP(1).LE.3) GOTO 140
5043 ENDIF
5044 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5045 IF(IMSS(1).LE.0) GOTO 140
5046 ENDIF
5047 NRES=NRES+1
5048 PMRES=PMAS(KC,1)
5049 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5050 DO 120 I1=NRES-1,1,-1
5051 IF(PMRES.GE.PMORD(I1)) GOTO 130
5052 KCORD(I1+1)=KCORD(I1)
5053 PMORD(I1+1)=PMORD(I1)
5054 120 CONTINUE
5055 130 KCORD(I1+1)=KC
5056 PMORD(I1+1)=PMRES
5057 140 CONTINUE
5058
5059C...Loop over possible resonances.
5060 DO 180 I=1,NRES
5061 KC=KCORD(I)
5062 KF=KCHG(KC,4)
5063
5064C...Check that no fourth generation channels on by mistake.
5065 IF(MSTP(1).LE.3) THEN
5066 DO 150 J=1,MDCY(KC,3)
5067 IDC=J+MDCY(KC,2)-1
5068 KFA1=IABS(KFDP(IDC,1))
5069 KFA2=IABS(KFDP(IDC,2))
5070 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5071 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5072 & MDME(IDC,1)=-1
5073 150 CONTINUE
5074 ENDIF
5075
5076C...Check that no supersymmetric channels on by mistake.
5077 IF(IMSS(1).LE.0) THEN
5078 DO 160 J=1,MDCY(KC,3)
5079 IDC=J+MDCY(KC,2)-1
5080 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5081 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5082 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5083 & MDME(IDC,1)=-1
5084 160 CONTINUE
5085 ENDIF
5086
5087C...Find mass and evaluate width.
5088 PMR=PMAS(KC,1)
5089 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5090 IF(MWID(KC).EQ.3) MINT(63)=1
5091 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5092 MINT(51)=0
5093
5094C...Evaluate suppression factors due to non-simulated channels.
5095 IF(KCHG(KC,3).EQ.0) THEN
5096 WDTP0I=0D0
5097 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5098 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5099 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5100 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5101 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5102 WIDS(KC,3)=0D0
5103 WIDS(KC,4)=0D0
5104 WIDS(KC,5)=0D0
5105 ELSE
5106 IF(MWID(KC).EQ.3) MINT(63)=1
5107 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5108 MINT(51)=0
5109 WDTP0I=0D0
5110 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5111 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5112 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5113 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5114 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5115 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5116 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5117 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5118 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5119 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5120 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5121 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5122 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5123 ENDIF
5124
5125C...Set resonance widths and branching ratios;
5126C...also on/off switch for decays.
5127 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5128 PMAS(KC,2)=WDTP(0)
5129 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5130 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5131 DO 170 J=1,MDCY(KC,3)
5132 IDC=J+MDCY(KC,2)-1
5133 BRAT(IDC)=0D0
5134 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5135 170 CONTINUE
5136 ENDIF
5137 180 CONTINUE
5138
5139C...Flavours of leptoquark: redefine charge and name.
5140 KFLQQ=KFDP(MDCY(42,2),1)
5141 KFLQL=KFDP(MDCY(42,2),2)
5142 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5143 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5144 LL=1
5145 IF(IABS(KFLQL).EQ.13) LL=2
5146 IF(IABS(KFLQL).EQ.15) LL=3
5147 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5148 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5149 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5150
5151C...Special cases in treatment of gamma*/Z0: redefine process name.
5152 IF(MSTP(43).EQ.1) THEN
5153 PROC(1)='f + fbar -> gamma*'
5154 PROC(15)='f + fbar -> g + gamma*'
5155 PROC(19)='f + fbar -> gamma + gamma*'
5156 PROC(30)='f + g -> f + gamma*'
5157 PROC(35)='f + gamma -> f + gamma*'
5158 ELSEIF(MSTP(43).EQ.2) THEN
5159 PROC(1)='f + fbar -> Z0'
5160 PROC(15)='f + fbar -> g + Z0'
5161 PROC(19)='f + fbar -> gamma + Z0'
5162 PROC(30)='f + g -> f + Z0'
5163 PROC(35)='f + gamma -> f + Z0'
5164 ELSEIF(MSTP(43).EQ.3) THEN
5165 PROC(1)='f + fbar -> gamma*/Z0'
5166 PROC(15)='f + fbar -> g + gamma*/Z0'
5167 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5168 PROC(30)='f + g -> f + gamma*/Z0'
5169 PROC(35)='f + gamma -> f + gamma*/Z0'
5170 ENDIF
5171
5172C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5173 IF(MSTP(44).EQ.1) THEN
5174 PROC(141)='f + fbar -> gamma*'
5175 ELSEIF(MSTP(44).EQ.2) THEN
5176 PROC(141)='f + fbar -> Z0'
5177 ELSEIF(MSTP(44).EQ.3) THEN
5178 PROC(141)='f + fbar -> Z''0'
5179 ELSEIF(MSTP(44).EQ.4) THEN
5180 PROC(141)='f + fbar -> gamma*/Z0'
5181 ELSEIF(MSTP(44).EQ.5) THEN
5182 PROC(141)='f + fbar -> gamma*/Z''0'
5183 ELSEIF(MSTP(44).EQ.6) THEN
5184 PROC(141)='f + fbar -> Z0/Z''0'
5185 ELSEIF(MSTP(44).EQ.7) THEN
5186 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5187 ENDIF
5188
5189C...Special cases in treatment of WW -> WW: redefine process name.
5190 IF(MSTP(45).EQ.1) THEN
5191 PROC(77)='W+ + W+ -> W+ + W+'
5192 ELSEIF(MSTP(45).EQ.2) THEN
5193 PROC(77)='W+ + W- -> W+ + W-'
5194 ELSEIF(MSTP(45).EQ.3) THEN
5195 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5196 ENDIF
5197
5198C...Format for error information.
5199 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5200 &'combination'/1X,'Execution stopped!')
5201
5202 RETURN
5203 END
5204
5205C*********************************************************************
5206
5207C...PYINBM
5208C...Identifies the two incoming particles and the choice of frame.
5209
5210 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5211
5212C...Double precision and integer declarations.
5213 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5214 IMPLICIT INTEGER(I-N)
5215 INTEGER PYK,PYCHGE,PYCOMP
5216
5217C...User process initialization commonblock.
5218 INTEGER MAXPUP
5219 PARAMETER (MAXPUP=100)
5220 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5221 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5222 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5223 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5224 &LPRUP(MAXPUP)
5225 SAVE /HEPRUP/
5226
5227C...Commonblocks.
5228 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5231 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5232 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5233 COMMON/PYINT1/MINT(400),VINT(400)
5234 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5235
5236C...Local arrays, character variables and data.
5237 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5238 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5239 DIMENSION LEN(3),KCDE(39),PM(2)
5240 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5241 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5242 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5243 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5244 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5245 &'nu_taubar ','pi+ ','pi- ','n0 ',
5246 &'nbar0 ','p+ ','pbar- ','gamma ',
5247 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5248 &'xi- ','xi0 ','omega- ','pi0 ',
5249 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5250 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5251 &'k+ ','k- ','ks0 ','kl0 '/
5252 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5253 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5254 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5255
5256C...Store initial energy. Default frame.
5257 VINT(290)=WIN
5258 MINT(111)=0
5259
5260C...Special user process initialization; convert to normal input.
5261 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5262 MINT(111)=11
5263 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5264 CALL PYNAME(IDBMUP(1),CHNAME)
5265 CHBEAM=CHNAME(1:12)
5266 CALL PYNAME(IDBMUP(2),CHNAME)
5267 CHTARG=CHNAME(1:12)
5268 ENDIF
5269
5270C...Convert character variables to lowercase and find their length.
5271 CHCOM(1)=CHFRAM
5272 CHCOM(2)=CHBEAM
5273 CHCOM(3)=CHTARG
5274 DO 130 I=1,3
5275 LEN(I)=12
5276 DO 110 LL=12,1,-1
5277 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5278 DO 100 LA=1,26
5279 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5280 & CHALP(1)(LA:LA)
5281 100 CONTINUE
5282 110 CONTINUE
5283 CHIDNT(I)=CHCOM(I)
5284
5285C...Fix up bar, underscore and charge in particle name (if needed).
5286 DO 120 LL=1,10
5287 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5288 CHTEMP=CHIDNT(I)
5289 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5290 ENDIF
5291 120 CONTINUE
5292 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5293 CHTEMP=CHIDNT(I)
5294 CHIDNT(I)='nu_'//CHTEMP(3:7)
5295 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5296 CHIDNT(I)(1:3)='n0 '
5297 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5298 CHIDNT(I)(1:5)='nbar0'
5299 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5300 CHIDNT(I)(1:3)='p+ '
5301 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5302 & CHIDNT(I)(1:2).EQ.'p-') THEN
5303 CHIDNT(I)(1:5)='pbar-'
5304 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5305 CHIDNT(I)(7:7)='0'
5306 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5307 CHIDNT(I)(1:7)='reggeon'
5308 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5309 CHIDNT(I)(1:7)='pomeron'
5310 ENDIF
5311 130 CONTINUE
5312
5313C...Identify free initialization.
5314 IF(CHCOM(1)(1:2).EQ.'no') THEN
5315 MINT(65)=1
5316 RETURN
5317 ENDIF
5318
5319C...Identify incoming beam and target particles.
5320 DO 160 I=1,2
5321 DO 140 J=1,39
5322 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5323 140 CONTINUE
5324 PM(I)=PYMASS(MINT(10+I))
5325 VINT(2+I)=PM(I)
5326 MINT(140+I)=0
5327 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5328 CHTEMP=CHIDNT(I+1)(7:12)//' '
5329 DO 150 J=1,12
5330 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5331 150 CONTINUE
5332 PM(I)=PYMASS(MINT(140+I))
5333 VINT(302+I)=PM(I)
5334 ENDIF
5335 160 CONTINUE
5336 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5337 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5338 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP
5339
5340C...Identify choice of frame and input energies.
5341 CHINIT=' '
5342
5343C...Events defined in the CM frame.
5344 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5345 MINT(111)=1
5346 S=WIN**2
5347 IF(MSTP(122).GE.1) THEN
5348 IF(CHCOM(2)(1:1).NE.'e') THEN
5349 LOFFS=(31-(LEN(2)+LEN(3)))/2
5350 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5351 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5352 & ' collider'//' '
5353 ELSE
5354 LOFFS=(30-(LEN(2)+LEN(3)))/2
5355 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5356 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5357 & ' collider'//' '
5358 ENDIF
5359 WRITE(MSTU(11),5200) CHINIT
5360 WRITE(MSTU(11),5300) WIN
5361 ENDIF
5362
5363C...Events defined in fixed target frame.
5364 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5365 MINT(111)=2
5366 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5367 IF(MSTP(122).GE.1) THEN
5368 LOFFS=(29-(LEN(2)+LEN(3)))/2
5369 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5370 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5371 & ' fixed target'//' '
5372 WRITE(MSTU(11),5200) CHINIT
5373 WRITE(MSTU(11),5400) WIN
5374 WRITE(MSTU(11),5500) SQRT(S)
5375 ENDIF
5376
5377C...Frame defined by user three-vectors.
5378 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5379 MINT(111)=3
5380 P(1,5)=PM(1)
5381 P(2,5)=PM(2)
5382 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5383 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5384 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5385 & (P(1,3)+P(2,3))**2
5386 IF(MSTP(122).GE.1) THEN
5387 LOFFS=(22-(LEN(2)+LEN(3)))/2
5388 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5389 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5390 & ' user configuration'//' '
5391 WRITE(MSTU(11),5200) CHINIT
5392 WRITE(MSTU(11),5600)
5393 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5394 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5395 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5396 ENDIF
5397
5398C...Frame defined by user four-vectors.
5399 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5400 MINT(111)=4
5401 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5402 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5403 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5404 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5405 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5406 & (P(1,3)+P(2,3))**2
5407 IF(MSTP(122).GE.1) THEN
5408 LOFFS=(22-(LEN(2)+LEN(3)))/2
5409 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5410 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5411 & ' user configuration'//' '
5412 WRITE(MSTU(11),5200) CHINIT
5413 WRITE(MSTU(11),5600)
5414 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5415 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5416 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5417 ENDIF
5418
5419C...Frame defined by user five-vectors.
5420 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5421 MINT(111)=5
5422 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5423 & (P(1,3)+P(2,3))**2
5424 IF(MSTP(122).GE.1) THEN
5425 LOFFS=(22-(LEN(2)+LEN(3)))/2
5426 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5427 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5428 & ' user configuration'//' '
5429 WRITE(MSTU(11),5200) CHINIT
5430 WRITE(MSTU(11),5600)
5431 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5432 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5433 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5434 ENDIF
5435
5436C...Frame defined by HEPRUP common block.
5437 ELSEIF(MINT(111).GE.11) THEN
5438 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5439 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5440 IF(MSTP(122).GE.1) THEN
5441 LOFFS=(22-(LEN(2)+LEN(3)))/2
5442 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5443 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5444 & ' user configuration'//' '
5445 WRITE(MSTU(11),5200) CHINIT
5446 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5447 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5448 ENDIF
5449
5450C...Unknown frame. Error for too low CM energy.
5451 ELSE
5452 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5453 STOP
5454 ENDIF
5455 IF(S.LT.PARP(2)**2) THEN
5456 WRITE(MSTU(11),5900) SQRT(S)
5457 STOP
5458 ENDIF
5459
5460C...Formats for initialization and error information.
5461 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5462 &1X,'Execution stopped!')
5463 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5464 &1X,'Execution stopped!')
5465 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5466 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5467 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5468 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5469 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5470 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5471 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5472 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5473 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5474 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5475 &1X,'Execution stopped!')
5476 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5477 &'generation.'/1X,'Execution stopped!')
5478 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5479 &'GeV beam energies',13X,'I')
5480
5481 RETURN
5482 END
5483
5484C*********************************************************************
5485
5486C...PYINKI
5487C...Sets up kinematics, including rotations and boosts to/from CM frame.
5488
5489 SUBROUTINE PYINKI(MODKI)
5490
5491C...Double precision and integer declarations.
5492 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5493 IMPLICIT INTEGER(I-N)
5494 INTEGER PYK,PYCHGE,PYCOMP
5495
5496C...User process initialization commonblock.
5497 INTEGER MAXPUP
5498 PARAMETER (MAXPUP=100)
5499 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5500 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5501 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5502 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5503 &LPRUP(MAXPUP)
5504 SAVE /HEPRUP/
5505
5506C...Commonblocks.
5507 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5508 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5509 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5510 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5512 COMMON/PYINT1/MINT(400),VINT(400)
5513 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5514
5515C...Set initial flavour state.
5516 N=2
5517 DO 100 I=1,2
5518 K(I,1)=1
5519 K(I,2)=MINT(10+I)
5520 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5521 100 CONTINUE
5522
5523C...Reset boost. Do kinematics for various cases.
5524 DO 110 J=6,10
5525 VINT(J)=0D0
5526 110 CONTINUE
5527
5528C...Set up kinematics for events defined in CM frame.
5529 IF(MINT(111).EQ.1) THEN
5530 WIN=VINT(290)
5531 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5532 S=WIN**2
5533 P(1,5)=VINT(3)
5534 P(2,5)=VINT(4)
5535 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5536 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5537 P(1,1)=0D0
5538 P(1,2)=0D0
5539 P(2,1)=0D0
5540 P(2,2)=0D0
5541 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5542 & (4D0*S))
5543 P(2,3)=-P(1,3)
5544 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5545 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5546
5547C...Set up kinematics for fixed target events.
5548 ELSEIF(MINT(111).EQ.2) THEN
5549 WIN=VINT(290)
5550 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5551 P(1,5)=VINT(3)
5552 P(2,5)=VINT(4)
5553 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5554 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5555 P(1,1)=0D0
5556 P(1,2)=0D0
5557 P(2,1)=0D0
5558 P(2,2)=0D0
5559 P(1,3)=WIN
5560 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5561 P(2,3)=0D0
5562 P(2,4)=P(2,5)
5563 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5564 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5565 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5566
5567C...Set up kinematics for events in user-defined frame.
5568 ELSEIF(MINT(111).EQ.3) THEN
5569 P(1,5)=VINT(3)
5570 P(2,5)=VINT(4)
5571 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5572 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5573 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5574 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5575 DO 120 J=1,3
5576 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5577 120 CONTINUE
5578 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5579 VINT(7)=PYANGL(P(1,1),P(1,2))
5580 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5581 VINT(6)=PYANGL(P(1,3),P(1,1))
5582 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5583 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5584
5585C...Set up kinematics for events with user-defined four-vectors.
5586 ELSEIF(MINT(111).EQ.4) THEN
5587 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5588 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5589 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5590 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5591 DO 130 J=1,3
5592 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5593 130 CONTINUE
5594 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5595 VINT(7)=PYANGL(P(1,1),P(1,2))
5596 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5597 VINT(6)=PYANGL(P(1,3),P(1,1))
5598 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5599 S=(P(1,4)+P(2,4))**2
5600
5601C...Set up kinematics for events with user-defined five-vectors.
5602 ELSEIF(MINT(111).EQ.5) THEN
5603 DO 140 J=1,3
5604 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5605 140 CONTINUE
5606 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5607 VINT(7)=PYANGL(P(1,1),P(1,2))
5608 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5609 VINT(6)=PYANGL(P(1,3),P(1,1))
5610 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5611 S=(P(1,4)+P(2,4))**2
5612
5613C...Set up kinematics for events with external user processes.
5614 ELSEIF(MINT(111).GE.11) THEN
5615 P(1,5)=VINT(3)
5616 P(2,5)=VINT(4)
5617 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5618 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5619 P(1,1)=0D0
5620 P(1,2)=0D0
5621 P(2,1)=0D0
5622 P(2,2)=0D0
5623 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5624 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5625 P(1,4)=EBMUP(1)
5626 P(2,4)=EBMUP(2)
5627 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5628 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5629 S=(P(1,4)+P(2,4))**2
5630 ENDIF
5631
5632C...Return or error for too low CM energy.
5633 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5634 IF(MSTP(172).LE.1) THEN
5635 CALL PYERRM(23,
5636 & '(PYINKI:) too low invariant mass in this event')
5637 ELSE
5638 MSTI(61)=1
5639 RETURN
5640 ENDIF
5641 ENDIF
5642
5643C...Save information on incoming particles.
5644 VINT(1)=SQRT(S)
5645 VINT(2)=S
5646 IF(MINT(111).GE.4) THEN
5647 IF(MINT(141).EQ.0) THEN
5648 VINT(3)=P(1,5)
5649 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5650 ELSE
5651 VINT(303)=P(1,5)
5652 ENDIF
5653 IF(MINT(142).EQ.0) THEN
5654 VINT(4)=P(2,5)
5655 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5656 ELSE
5657 VINT(304)=P(2,5)
5658 ENDIF
5659 ENDIF
5660 VINT(5)=P(1,3)
5661 IF(MODKI.EQ.0) VINT(289)=S
5662 DO 150 J=1,5
5663 V(1,J)=0D0
5664 V(2,J)=0D0
5665 VINT(290+J)=P(1,J)
5666 VINT(295+J)=P(2,J)
5667 150 CONTINUE
5668
5669C...Store pT cut-off and related constants to be used in generation.
5670 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5671 IF(MSTP(82).LE.1) THEN
5672 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5673 ELSE
5674 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5675 ENDIF
5676 VINT(149)=4D0*PTMN**2/S
5677 VINT(154)=PTMN
5678
5679 RETURN
5680 END
5681
5682C*********************************************************************
5683
5684C...PYINPR
5685C...Selects partonic subprocesses to be included in the simulation.
5686
5687 SUBROUTINE PYINPR
5688
5689C...Double precision and integer declarations.
5690 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5691 IMPLICIT INTEGER(I-N)
5692 INTEGER PYK,PYCHGE,PYCOMP
5693
5694C...User process initialization commonblock.
5695 INTEGER MAXPUP
5696 PARAMETER (MAXPUP=100)
5697 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5698 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5699 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5700 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5701 &LPRUP(MAXPUP)
5702 SAVE /HEPRUP/
5703
5704C...Commonblocks and character variables.
5705 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5706 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5707 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5708 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5709 COMMON/PYINT1/MINT(400),VINT(400)
5710 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5711 COMMON/PYINT6/PROC(0:500)
5712 CHARACTER PROC*28
5713 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5714 &/PYINT6/
5715 CHARACTER CHIPR*10
5716
5717C...Reset processes to be included.
5718 IF(MSEL.NE.0) THEN
5719 DO 100 I=1,500
5720 MSUB(I)=0
5721 100 CONTINUE
5722 ENDIF
5723
5724C...Set running pTmin scale.
5725 IF(MSTP(82).LE.1) THEN
5726 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5727 ELSE
5728 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5729 ENDIF
5730
5731C...Begin by assuming incoming photon to enter subprocess.
5732 IF(MINT(11).EQ.22) MINT(15)=22
5733 IF(MINT(12).EQ.22) MINT(16)=22
5734
5735C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5736 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5737 MSUB(10)=1
5738 MINT(123)=MINT(122)+1
5739
5740C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5741C...allow mixture.
5742C...Here also set a few parameters otherwise normally not touched.
5743 ELSEIF(MINT(121).GT.1) THEN
5744
5745C...Parton distributions dampened at small Q2; go to low energies,
5746C...alpha_s <1; no minimum pT cut-off a priori.
5747 IF(MSTP(18).EQ.2) THEN
5748 MSTP(57)=3
5749 PARP(2)=2D0
5750 PARU(115)=1D0
5751 CKIN(5)=0.2D0
5752 CKIN(6)=0.2D0
5753 ENDIF
5754
5755C...Define pT cut-off parameters and whether run involves low-pT.
5756 PTMVMD=PTMRUN
5757 VINT(154)=PTMVMD
5758 PTMDIR=PTMVMD
5759 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5760 PTMANO=PTMVMD
5761 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5762 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5763 IPTL=1
5764 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5765 IF(MSEL.EQ.2) IPTL=1
5766
5767C...Set up for p/gamma * gamma; real or virtual photons.
5768 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5769 & MSTP(14).EQ.30)) THEN
5770
5771C...Set up for p/VMD * VMD.
5772 IF(MINT(122).EQ.1) THEN
5773 MINT(123)=2
5774 MSUB(11)=1
5775 MSUB(12)=1
5776 MSUB(13)=1
5777 MSUB(28)=1
5778 MSUB(53)=1
5779 MSUB(68)=1
5780 IF(IPTL.EQ.1) MSUB(95)=1
5781 IF(MSEL.EQ.2) THEN
5782 MSUB(91)=1
5783 MSUB(92)=1
5784 MSUB(93)=1
5785 MSUB(94)=1
5786 ENDIF
5787 IF(IPTL.EQ.1) CKIN(3)=0D0
5788
5789C...Set up for p/VMD * direct gamma.
5790 ELSEIF(MINT(122).EQ.2) THEN
5791 MINT(123)=0
5792 IF(MINT(121).EQ.6) MINT(123)=5
5793 MSUB(131)=1
5794 MSUB(132)=1
5795 MSUB(135)=1
5796 MSUB(136)=1
5797 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5798
5799C...Set up for p/VMD * anomalous gamma.
5800 ELSEIF(MINT(122).EQ.3) THEN
5801 MINT(123)=3
5802 IF(MINT(121).EQ.6) MINT(123)=7
5803 MSUB(11)=1
5804 MSUB(12)=1
5805 MSUB(13)=1
5806 MSUB(28)=1
5807 MSUB(53)=1
5808 MSUB(68)=1
5809 IF(IPTL.EQ.1) MSUB(95)=1
5810 IF(MSEL.EQ.2) THEN
5811 MSUB(91)=1
5812 MSUB(92)=1
5813 MSUB(93)=1
5814 MSUB(94)=1
5815 ENDIF
5816 IF(IPTL.EQ.1) CKIN(3)=0D0
5817
5818C...Set up for DIS * p.
5819 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5820 & IABS(MINT(12)).GT.100)) THEN
5821 MINT(123)=8
5822 IF(IPTL.EQ.1) MSUB(99)=1
5823
5824C...Set up for direct * direct gamma (switch off leptons).
5825 ELSEIF(MINT(122).EQ.4) THEN
5826 MINT(123)=0
5827 MSUB(137)=1
5828 MSUB(138)=1
5829 MSUB(139)=1
5830 MSUB(140)=1
5831 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5832 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5833 110 CONTINUE
5834 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5835
5836C...Set up for direct * anomalous gamma.
5837 ELSEIF(MINT(122).EQ.5) THEN
5838 MINT(123)=6
5839 MSUB(131)=1
5840 MSUB(132)=1
5841 MSUB(135)=1
5842 MSUB(136)=1
5843 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5844
5845C...Set up for anomalous * anomalous gamma.
5846 ELSEIF(MINT(122).EQ.6) THEN
5847 MINT(123)=3
5848 MSUB(11)=1
5849 MSUB(12)=1
5850 MSUB(13)=1
5851 MSUB(28)=1
5852 MSUB(53)=1
5853 MSUB(68)=1
5854 IF(IPTL.EQ.1) MSUB(95)=1
5855 IF(MSEL.EQ.2) THEN
5856 MSUB(91)=1
5857 MSUB(92)=1
5858 MSUB(93)=1
5859 MSUB(94)=1
5860 ENDIF
5861 IF(IPTL.EQ.1) CKIN(3)=0D0
5862 ENDIF
5863
5864C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5865 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5866
5867C...Set up for direct * direct gamma (switch off leptons).
5868 IF(MINT(122).EQ.1) THEN
5869 MINT(123)=0
5870 MSUB(137)=1
5871 MSUB(138)=1
5872 MSUB(139)=1
5873 MSUB(140)=1
5874 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5875 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5876 120 CONTINUE
5877 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5878
5879C...Set up for direct * VMD and VMD * direct gamma.
5880 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5881 MINT(123)=5
5882 MSUB(131)=1
5883 MSUB(132)=1
5884 MSUB(135)=1
5885 MSUB(136)=1
5886 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5887
5888C...Set up for direct * anomalous and anomalous * direct gamma.
5889 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5890 MINT(123)=6
5891 MSUB(131)=1
5892 MSUB(132)=1
5893 MSUB(135)=1
5894 MSUB(136)=1
5895 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5896
5897C...Set up for VMD*VMD.
5898 ELSEIF(MINT(122).EQ.5) THEN
5899 MINT(123)=2
5900 MSUB(11)=1
5901 MSUB(12)=1
5902 MSUB(13)=1
5903 MSUB(28)=1
5904 MSUB(53)=1
5905 MSUB(68)=1
5906 IF(IPTL.EQ.1) MSUB(95)=1
5907 IF(MSEL.EQ.2) THEN
5908 MSUB(91)=1
5909 MSUB(92)=1
5910 MSUB(93)=1
5911 MSUB(94)=1
5912 ENDIF
5913 IF(IPTL.EQ.1) CKIN(3)=0D0
5914
5915C...Set up for VMD * anomalous and anomalous * VMD gamma.
5916 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5917 MINT(123)=7
5918 MSUB(11)=1
5919 MSUB(12)=1
5920 MSUB(13)=1
5921 MSUB(28)=1
5922 MSUB(53)=1
5923 MSUB(68)=1
5924 IF(IPTL.EQ.1) MSUB(95)=1
5925 IF(MSEL.EQ.2) THEN
5926 MSUB(91)=1
5927 MSUB(92)=1
5928 MSUB(93)=1
5929 MSUB(94)=1
5930 ENDIF
5931 IF(IPTL.EQ.1) CKIN(3)=0D0
5932
5933C...Set up for anomalous * anomalous gamma.
5934 ELSEIF(MINT(122).EQ.9) THEN
5935 MINT(123)=3
5936 MSUB(11)=1
5937 MSUB(12)=1
5938 MSUB(13)=1
5939 MSUB(28)=1
5940 MSUB(53)=1
5941 MSUB(68)=1
5942 IF(IPTL.EQ.1) MSUB(95)=1
5943 IF(MSEL.EQ.2) THEN
5944 MSUB(91)=1
5945 MSUB(92)=1
5946 MSUB(93)=1
5947 MSUB(94)=1
5948 ENDIF
5949 IF(IPTL.EQ.1) CKIN(3)=0D0
5950
5951C...Set up for DIS * VMD and VMD * DIS gamma.
5952 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
5953 MINT(123)=8
5954 IF(IPTL.EQ.1) MSUB(99)=1
5955
5956C...Set up for DIS * anomalous and anomalous * DIS gamma.
5957 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
5958 MINT(123)=9
5959 IF(IPTL.EQ.1) MSUB(99)=1
5960 ENDIF
5961
5962C...Set up for gamma* * p; virtual photons = dir, res.
5963 ELSEIF(MINT(121).EQ.2) THEN
5964
5965C...Set up for direct * p.
5966 IF(MINT(122).EQ.1) THEN
5967 MINT(123)=0
5968 MSUB(131)=1
5969 MSUB(132)=1
5970 MSUB(135)=1
5971 MSUB(136)=1
5972 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5973
5974C...Set up for resolved * p.
5975 ELSEIF(MINT(122).EQ.2) THEN
5976 MINT(123)=1
5977 MSUB(11)=1
5978 MSUB(12)=1
5979 MSUB(13)=1
5980 MSUB(28)=1
5981 MSUB(53)=1
5982 MSUB(68)=1
5983 IF(IPTL.EQ.1) MSUB(95)=1
5984 IF(MSEL.EQ.2) THEN
5985 MSUB(91)=1
5986 MSUB(92)=1
5987 MSUB(93)=1
5988 MSUB(94)=1
5989 ENDIF
5990 IF(IPTL.EQ.1) CKIN(3)=0D0
5991 ENDIF
5992
5993C...Set up for gamma* * gamma*; virtual photons = dir, res.
5994 ELSEIF(MINT(121).EQ.4) THEN
5995
5996C...Set up for direct * direct gamma (switch off leptons).
5997 IF(MINT(122).EQ.1) THEN
5998 MINT(123)=0
5999 MSUB(137)=1
6000 MSUB(138)=1
6001 MSUB(139)=1
6002 MSUB(140)=1
6003 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6004 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6005 130 CONTINUE
6006 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6007
6008C...Set up for direct * resolved and resolved * direct gamma.
6009 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6010 MINT(123)=5
6011 MSUB(131)=1
6012 MSUB(132)=1
6013 MSUB(135)=1
6014 MSUB(136)=1
6015 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6016
6017C...Set up for resolved * resolved gamma.
6018 ELSEIF(MINT(122).EQ.4) THEN
6019 MINT(123)=2
6020 MSUB(11)=1
6021 MSUB(12)=1
6022 MSUB(13)=1
6023 MSUB(28)=1
6024 MSUB(53)=1
6025 MSUB(68)=1
6026 IF(IPTL.EQ.1) MSUB(95)=1
6027 IF(MSEL.EQ.2) THEN
6028 MSUB(91)=1
6029 MSUB(92)=1
6030 MSUB(93)=1
6031 MSUB(94)=1
6032 ENDIF
6033 IF(IPTL.EQ.1) CKIN(3)=0D0
6034 ENDIF
6035
6036C...End of special set up for gamma-p and gamma-gamma.
6037 ENDIF
6038 CKIN(1)=2D0*CKIN(3)
6039 ENDIF
6040
6041C...Flavour information for individual beams.
6042 DO 140 I=1,2
6043 MINT(40+I)=1
6044 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6045 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6046 MINT(44+I)=MINT(40+I)
6047 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6048 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6049 140 CONTINUE
6050
6051C...If two real gammas, whereof one direct, pick the first.
6052C...For two virtual photons, keep requested order.
6053 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6054 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6055 MINT(41)=1
6056 MINT(45)=1
6057 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6058 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6059 MINT(41)=1
6060 MINT(45)=1
6061 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6062 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6063 MINT(42)=1
6064 MINT(46)=1
6065 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6066 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6067 MINT(41)=1
6068 MINT(45)=1
6069 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6070 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6071 MINT(42)=1
6072 MINT(46)=1
6073 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6074 MINT(41)=1
6075 MINT(45)=1
6076 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6077 MINT(42)=1
6078 MINT(46)=1
6079 ENDIF
6080 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6081 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6082 IF(MINT(11).EQ.22) THEN
6083 MINT(41)=1
6084 MINT(45)=1
6085 ELSE
6086 MINT(42)=1
6087 MINT(46)=1
6088 ENDIF
6089 ENDIF
6090 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6091 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6092 ENDIF
6093
6094C...Flavour information on combination of incoming particles.
6095 MINT(43)=2*MINT(41)+MINT(42)-2
6096 MINT(44)=MINT(43)
6097 IF(MINT(123).LE.0) THEN
6098 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6099 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6100 ELSEIF(MINT(123).LE.3) THEN
6101 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6102 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6103 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6104 MINT(43)=4
6105 MINT(44)=1
6106 ENDIF
6107 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6108 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6109 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6110 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6111 MINT(50)=0
6112 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6113 MINT(107)=0
6114 MINT(108)=0
6115 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6116 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6117 & MINT(107)=2
6118 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6119 & MINT(107)=3
6120 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6121 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6122 & MINT(122).EQ.10) MINT(108)=2
6123 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6124 & MINT(122).EQ.11) MINT(108)=3
6125 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6126 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6127 IF(MINT(122).GE.3) MINT(107)=1
6128 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6129 ELSEIF(MINT(121).EQ.2) THEN
6130 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6131 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6132 ELSE
6133 IF(MINT(11).EQ.22) THEN
6134 MINT(107)=MINT(123)
6135 IF(MINT(123).GE.4) MINT(107)=0
6136 IF(MINT(123).EQ.7) MINT(107)=2
6137 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6138 IF(MSTP(14).EQ.28) MINT(107)=2
6139 IF(MSTP(14).EQ.29) MINT(107)=3
6140 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6141 & MINT(107)=4
6142 ENDIF
6143 IF(MINT(12).EQ.22) THEN
6144 MINT(108)=MINT(123)
6145 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6146 IF(MINT(123).EQ.7) MINT(108)=3
6147 IF(MSTP(14).EQ.26) MINT(108)=2
6148 IF(MSTP(14).EQ.27) MINT(108)=3
6149 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6150 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6151 & MINT(108)=4
6152 ENDIF
6153 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6154 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6155 MINTTP=MINT(107)
6156 MINT(107)=MINT(108)
6157 MINT(108)=MINTTP
6158 ENDIF
6159 ENDIF
6160 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6161 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6162
6163C...Select default processes according to incoming beams
6164C...(already done for gamma-p and gamma-gamma with
6165C...MSTP(14) = 10, 20, 25 or 30).
6166 IF(MINT(121).GT.1) THEN
6167 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6168
6169 IF(MINT(43).EQ.1) THEN
6170C...Lepton + lepton -> gamma/Z0 or W.
6171 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6172 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6173
6174 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6175 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6176C...Unresolved photon + lepton: Compton scattering.
6177 MSUB(133)=1
6178 MSUB(134)=1
6179
6180 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6181 & .OR.MINT(12).EQ.22)) THEN
6182C...DIS as pure gamma* + f -> f process.
6183 MSUB(99)=1
6184
6185 ELSEIF(MINT(43).LE.3) THEN
6186C...Lepton + hadron: deep inelastic scattering.
6187 MSUB(10)=1
6188
6189 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6190 & MINT(12).EQ.22) THEN
6191C...Two unresolved photons: fermion pair production,
6192C...exclude lepton pairs.
6193 DO 150 ISUB=137,140
6194 MSUB(ISUB)=1
6195 150 CONTINUE
6196 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6197 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6198 160 CONTINUE
6199 PTMDIR=PTMRUN
6200 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6201 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6202 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6203
6204 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6205 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6206 & MINT(12).EQ.22)) THEN
6207C...Unresolved photon + hadron: photon-parton scattering.
6208 DO 170 ISUB=131,136
6209 MSUB(ISUB)=1
6210 170 CONTINUE
6211
6212 ELSEIF(MSEL.EQ.1) THEN
6213C...High-pT QCD processes:
6214 MSUB(11)=1
6215 MSUB(12)=1
6216 MSUB(13)=1
6217 MSUB(28)=1
6218 MSUB(53)=1
6219 MSUB(68)=1
6220 PTMN=PTMRUN
6221 VINT(154)=PTMN
6222 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6223 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6224
6225 ELSE
6226C...All QCD processes:
6227 MSUB(11)=1
6228 MSUB(12)=1
6229 MSUB(13)=1
6230 MSUB(28)=1
6231 MSUB(53)=1
6232 MSUB(68)=1
6233 MSUB(91)=1
6234 MSUB(92)=1
6235 MSUB(93)=1
6236 MSUB(94)=1
6237 MSUB(95)=1
6238 ENDIF
6239
6240 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6241C...Heavy quark production.
6242 MSUB(81)=1
6243 MSUB(82)=1
6244 MSUB(84)=1
6245 DO 180 J=1,MIN(8,MDCY(21,3))
6246 MDME(MDCY(21,2)+J-1,1)=0
6247 180 CONTINUE
6248 MDME(MDCY(21,2)+MSEL-1,1)=1
6249 MSUB(85)=1
6250 DO 190 J=1,MIN(12,MDCY(22,3))
6251 MDME(MDCY(22,2)+J-1,1)=0
6252 190 CONTINUE
6253 MDME(MDCY(22,2)+MSEL-1,1)=1
6254
6255 ELSEIF(MSEL.EQ.10) THEN
6256C...Prompt photon production:
6257 MSUB(14)=1
6258 MSUB(18)=1
6259 MSUB(29)=1
6260
6261 ELSEIF(MSEL.EQ.11) THEN
6262C...Z0/gamma* production:
6263 MSUB(1)=1
6264
6265 ELSEIF(MSEL.EQ.12) THEN
6266C...W+/- production:
6267 MSUB(2)=1
6268
6269 ELSEIF(MSEL.EQ.13) THEN
6270C...Z0 + jet:
6271 MSUB(15)=1
6272 MSUB(30)=1
6273
6274 ELSEIF(MSEL.EQ.14) THEN
6275C...W+/- + jet:
6276 MSUB(16)=1
6277 MSUB(31)=1
6278
6279 ELSEIF(MSEL.EQ.15) THEN
6280C...Z0 & W+/- pair production:
6281 MSUB(19)=1
6282 MSUB(20)=1
6283 MSUB(22)=1
6284 MSUB(23)=1
6285 MSUB(25)=1
6286
6287 ELSEIF(MSEL.EQ.16) THEN
6288C...h0 production:
6289 MSUB(3)=1
6290 MSUB(102)=1
6291 MSUB(103)=1
6292 MSUB(123)=1
6293 MSUB(124)=1
6294
6295 ELSEIF(MSEL.EQ.17) THEN
6296C...h0 & Z0 or W+/- pair production:
6297 MSUB(24)=1
6298 MSUB(26)=1
6299
6300 ELSEIF(MSEL.EQ.18) THEN
6301C...h0 production; interesting processes in e+e-.
6302 MSUB(24)=1
6303 MSUB(103)=1
6304 MSUB(123)=1
6305 MSUB(124)=1
6306
6307 ELSEIF(MSEL.EQ.19) THEN
6308C...h0, H0 and A0 production; interesting processes in e+e-.
6309 MSUB(24)=1
6310 MSUB(103)=1
6311 MSUB(123)=1
6312 MSUB(124)=1
6313 MSUB(153)=1
6314 MSUB(171)=1
6315 MSUB(173)=1
6316 MSUB(174)=1
6317 MSUB(158)=1
6318 MSUB(176)=1
6319 MSUB(178)=1
6320 MSUB(179)=1
6321
6322 ELSEIF(MSEL.EQ.21) THEN
6323C...Z'0 production:
6324 MSUB(141)=1
6325
6326 ELSEIF(MSEL.EQ.22) THEN
6327C...W'+/- production:
6328 MSUB(142)=1
6329
6330 ELSEIF(MSEL.EQ.23) THEN
6331C...H+/- production:
6332 MSUB(143)=1
6333
6334 ELSEIF(MSEL.EQ.24) THEN
6335C...R production:
6336 MSUB(144)=1
6337
6338 ELSEIF(MSEL.EQ.25) THEN
6339C...LQ (leptoquark) production.
6340 MSUB(145)=1
6341 MSUB(162)=1
6342 MSUB(163)=1
6343 MSUB(164)=1
6344
6345 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6346C...Production of one heavy quark (W exchange):
6347 MSUB(83)=1
6348 DO 200 J=1,MIN(8,MDCY(21,3))
6349 MDME(MDCY(21,2)+J-1,1)=0
6350 200 CONTINUE
6351 MDME(MDCY(21,2)+MSEL-31,1)=1
6352
6353CMRENNA++Define SUSY alternatives.
6354 ELSEIF(MSEL.EQ.39) THEN
6355C...Turn on all SUSY processes.
6356 IF(MINT(43).EQ.4) THEN
6357C...Hadron-hadron processes.
6358 DO 210 I=201,301
6359 IF(ISET(I).GE.0) MSUB(I)=1
6360 210 CONTINUE
6361 ELSEIF(MINT(43).EQ.1) THEN
6362C...Lepton-lepton processes: QED production of squarks.
6363 DO 220 I=201,214
6364 MSUB(I)=1
6365 220 CONTINUE
6366 MSUB(210)=0
6367 MSUB(211)=0
6368 MSUB(212)=0
6369 DO 230 I=216,228
6370 MSUB(I)=1
6371 230 CONTINUE
6372 DO 240 I=261,263
6373 MSUB(I)=1
6374 240 CONTINUE
6375 MSUB(277)=1
6376 MSUB(278)=1
6377 ENDIF
6378
6379 ELSEIF(MSEL.EQ.40) THEN
6380C...Gluinos and squarks.
6381 IF(MINT(43).EQ.4) THEN
6382 MSUB(243)=1
6383 MSUB(244)=1
6384 MSUB(258)=1
6385 MSUB(259)=1
6386 MSUB(261)=1
6387 MSUB(262)=1
6388 MSUB(264)=1
6389 MSUB(265)=1
6390 DO 250 I=271,296
6391 MSUB(I)=1
6392 250 CONTINUE
6393 ELSEIF(MINT(43).EQ.1) THEN
6394 MSUB(277)=1
6395 MSUB(278)=1
6396 ENDIF
6397
6398 ELSEIF(MSEL.EQ.41) THEN
6399C...Stop production.
6400 MSUB(261)=1
6401 MSUB(262)=1
6402 MSUB(263)=1
6403 IF(MINT(43).EQ.4) THEN
6404 MSUB(264)=1
6405 MSUB(265)=1
6406 ENDIF
6407
6408 ELSEIF(MSEL.EQ.42) THEN
6409C...Slepton production.
6410 DO 260 I=201,214
6411 MSUB(I)=1
6412 260 CONTINUE
6413 IF(MINT(43).NE.4) THEN
6414 MSUB(210)=0
6415 MSUB(211)=0
6416 MSUB(212)=0
6417 ENDIF
6418
6419 ELSEIF(MSEL.EQ.43) THEN
6420C...Neutralino/Chargino + Gluino/Squark.
6421 IF(MINT(43).EQ.4) THEN
6422 DO 270 I=237,242
6423 MSUB(I)=1
6424 270 CONTINUE
6425 DO 280 I=246,254
6426 MSUB(I)=1
6427 280 CONTINUE
6428 MSUB(256)=1
6429 ENDIF
6430
6431 ELSEIF(MSEL.EQ.44) THEN
6432C...Neutralino/Chargino pair production.
6433 IF(MINT(43).EQ.4) THEN
6434 DO 290 I=216,236
6435 MSUB(I)=1
6436 290 CONTINUE
6437 ELSEIF(MINT(43).EQ.1) THEN
6438 DO 300 I=216,228
6439 MSUB(I)=1
6440 300 CONTINUE
6441 ENDIF
6442
6443 ELSEIF(MSEL.EQ.45) THEN
6444C...Sbottom production.
6445 MSUB(287)=1
6446 MSUB(288)=1
6447 IF(MINT(43).EQ.4) THEN
6448 DO 310 I=281,296
6449 MSUB(I)=1
6450 310 CONTINUE
6451 ENDIF
6452
6453 ELSEIF(MSEL.EQ.50) THEN
6454C...Pair production of technipions and gauge bosons.
6455 DO 320 I=361,368
6456 MSUB(I)=1
6457 320 CONTINUE
6458 IF(MINT(43).EQ.4) THEN
6459 DO 330 I=370,377
6460 MSUB(I)=1
6461 330 CONTINUE
6462 ENDIF
6463
6464 ELSEIF(MSEL.EQ.51) THEN
6465C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6466 DO 340 I=381,386
6467 MSUB(I)=1
6468 340 CONTINUE
6469
6470 ELSEIF(MSEL.EQ.61) THEN
6471C...Charmonium production in colour octet model, with recoiling parton.
6472 DO 342 I=421,439
6473 MSUB(I)=1
6474 342 CONTINUE
6475
6476 ELSEIF(MSEL.EQ.62) THEN
6477C...Bottomonium production in colour octet model, with recoiling parton.
6478 DO 344 I=461,479
6479 MSUB(I)=1
6480 344 CONTINUE
6481
6482 ELSEIF(MSEL.EQ.63) THEN
6483C...Charmonium and bottomonium production in colour octet model.
6484 DO 346 I=421,439
6485 MSUB(I)=1
6486 MSUB(I+40)=1
6487 346 CONTINUE
6488 ENDIF
6489
6490C...Find heaviest new quark flavour allowed in processes 81-84.
6491 KFLQM=1
6492 DO 350 I=1,MIN(8,MDCY(21,3))
6493 IDC=I+MDCY(21,2)-1
6494 IF(MDME(IDC,1).LE.0) GOTO 350
6495 KFLQM=I
6496 350 CONTINUE
6497 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6498 &KFLQM=MSTP(7)
6499 MINT(55)=KFLQM
6500 KFPR(81,1)=KFLQM
6501 KFPR(81,2)=KFLQM
6502 KFPR(82,1)=KFLQM
6503 KFPR(82,2)=KFLQM
6504 KFPR(83,1)=KFLQM
6505 KFPR(84,1)=KFLQM
6506 KFPR(84,2)=KFLQM
6507
6508C...Find heaviest new fermion flavour allowed in process 85.
6509 KFLFM=1
6510 DO 360 I=1,MIN(12,MDCY(22,3))
6511 IDC=I+MDCY(22,2)-1
6512 IF(MDME(IDC,1).LE.0) GOTO 360
6513 KFLFM=KFDP(IDC,1)
6514 360 CONTINUE
6515 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6516 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6517 MINT(56)=KFLFM
6518 KFPR(85,1)=KFLFM
6519 KFPR(85,2)=KFLFM
6520
6521C...Import relevant information on external user processes.
6522 IF(MINT(111).GE.11) THEN
6523 IPYPR=0
6524 DO 390 IUP=1,NPRUP
6525C...Find next empty PYTHIA process number slot and enable it.
6526 370 IPYPR=IPYPR+1
6527 IF(IPYPR.GT.500) CALL PYERRM(26,
6528 & '(PYINPR.) no more empty slots for user processes')
6529 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6530 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6531 ISET(IPYPR)=11
6532C...Overwrite KFPR with references back to process number and ID.
6533 KFPR(IPYPR,1)=IUP
6534 KFPR(IPYPR,2)=LPRUP(IUP)
6535C...Process title.
6536 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6537 ICHIN=1
6538 DO 380 ICH=1,9
6539 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6540 380 CONTINUE
6541 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6542C...Switch on process.
6543 MSUB(IPYPR)=1
6544 390 CONTINUE
6545 ENDIF
6546
6547 RETURN
6548 END
6549
6550C*********************************************************************
6551
6552C...PYXTOT
6553C...Parametrizes total, elastic and diffractive cross-sections
6554C...for different energies and beams. Donnachie-Landshoff for
6555C...total and Schuler-Sjostrand for elastic and diffractive.
6556C...Process code IPROC:
6557C...= 1 : p + p;
6558C...= 2 : pbar + p;
6559C...= 3 : pi+ + p;
6560C...= 4 : pi- + p;
6561C...= 5 : pi0 + p;
6562C...= 6 : phi + p;
6563C...= 7 : J/psi + p;
6564C...= 11 : rho + rho;
6565C...= 12 : rho + phi;
6566C...= 13 : rho + J/psi;
6567C...= 14 : phi + phi;
6568C...= 15 : phi + J/psi;
6569C...= 16 : J/psi + J/psi;
6570C...= 21 : gamma + p (DL);
6571C...= 22 : gamma + p (VDM).
6572C...= 23 : gamma + pi (DL);
6573C...= 24 : gamma + pi (VDM);
6574C...= 25 : gamma + gamma (DL);
6575C...= 26 : gamma + gamma (VDM).
6576
6577 SUBROUTINE PYXTOT
6578
6579C...Double precision and integer declarations.
6580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6581 IMPLICIT INTEGER(I-N)
6582 INTEGER PYK,PYCHGE,PYCOMP
6583C...Commonblocks.
6584 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6585 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6586 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6587 COMMON/PYINT1/MINT(400),VINT(400)
6588 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6589 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6590 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6591C...Local arrays.
6592 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6593 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6594 &CEFFD(10,9),SIGTMP(6,0:5)
6595
6596C...Common constants.
6597 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6598 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6599 &FACDD/0.0084D0/
6600
6601C...Number of multiple processes to be evaluated (= 0 : undefined).
6602 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6603C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6604 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6605 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6606 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6607 DATA YPAR/
6608 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6609 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6610 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6611
6612C...Beam and target hadron class:
6613C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6614 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6615 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6616C...Characteristic class masses, slope parameters, beta = sqrt(X).
6617 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6618 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6619 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6620
6621C...Fitting constants used in parametrizations of diffractive results.
6622 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6623 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6624 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6625 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6626 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6627 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6628 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6629 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6630 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6631 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6632 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6633 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6634 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6635 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6636 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6637 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6638 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6639 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6640 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6641 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6642 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6643 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6644 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6645 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6646 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6647 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6648 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6649 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6650 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6651
6652C...Parameters. Combinations of the energy.
6653 AEM=PARU(101)
6654 PMTH=PARP(102)
6655 S=VINT(2)
6656 SRT=VINT(1)
6657 SEPS=S**EPS
6658 SETA=S**ETA
6659 SLOG=LOG(S)
6660
6661C...Ratio of gamma/pi (for rescaling in parton distributions).
6662 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6663 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6664 VINT(317)=1D0
6665 IF(MINT(50).NE.1) RETURN
6666
6667C...Order flavours of incoming particles: KF1 < KF2.
6668 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6669 KF1=IABS(MINT(11))
6670 KF2=IABS(MINT(12))
6671 IORD=1
6672 ELSE
6673 KF1=IABS(MINT(12))
6674 KF2=IABS(MINT(11))
6675 IORD=2
6676 ENDIF
6677 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6678
6679C...Find process number (for lookup tables).
6680 IF(KF1.GT.1000) THEN
6681 IPROC=1
6682 IF(ISGN12.LT.0) IPROC=2
6683 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6684 IPROC=3
6685 IF(ISGN12.LT.0) IPROC=4
6686 IF(KF1.EQ.111) IPROC=5
6687 ELSEIF(KF1.GT.100) THEN
6688 IPROC=11
6689 ELSEIF(KF2.GT.1000) THEN
6690 IPROC=21
6691 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6692 ELSEIF(KF2.GT.100) THEN
6693 IPROC=23
6694 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6695 ELSE
6696 IPROC=25
6697 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6698 ENDIF
6699
6700C... Number of multiple processes to be stored; beam/target side.
6701 NPR=NPROC(IPROC)
6702 MINT(101)=1
6703 MINT(102)=1
6704 IF(NPR.EQ.3) THEN
6705 MINT(100+IORD)=4
6706 ELSEIF(NPR.EQ.6) THEN
6707 MINT(101)=4
6708 MINT(102)=4
6709 ENDIF
6710 N1=0
6711 IF(MINT(101).EQ.4) N1=4
6712 N2=0
6713 IF(MINT(102).EQ.4) N2=4
6714
6715C...Do not do any more for user-set or undefined cross-sections.
6716 IF(MSTP(31).LE.0) RETURN
6717 IF(NPR.EQ.0) CALL PYERRM(26,
6718 &'(PYXTOT:) cross section for this process not yet implemented')
6719
6720C...Parameters. Combinations of the energy.
6721 AEM=PARU(101)
6722 PMTH=PARP(102)
6723 S=VINT(2)
6724 SRT=VINT(1)
6725 SEPS=S**EPS
6726 SETA=S**ETA
6727 SLOG=LOG(S)
6728
6729C...Loop over multiple processes (for VDM).
6730 DO 110 I=1,NPR
6731 IF(NPR.EQ.1) THEN
6732 IPR=IPROC
6733 ELSEIF(NPR.EQ.3) THEN
6734 IPR=I+4
6735 IF(KF2.LT.1000) IPR=I+10
6736 ELSEIF(NPR.EQ.6) THEN
6737 IPR=I+10
6738 ENDIF
6739
6740C...Evaluate hadron species, mass, slope contribution and fit number.
6741 IHA=IHADA(IPR)
6742 IHB=IHADB(IPR)
6743 PMA=PMHAD(IHA)
6744 PMB=PMHAD(IHB)
6745 BHA=BHAD(IHA)
6746 BHB=BHAD(IHB)
6747 ISD=IFITSD(IPR)
6748 IDD=IFITDD(IPR)
6749
6750C...Skip if energy too low relative to masses.
6751 DO 100 J=0,5
6752 SIGTMP(I,J)=0D0
6753 100 CONTINUE
6754 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6755
6756C...Total cross-section. Elastic slope parameter and cross-section.
6757 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6758 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6759 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6760
6761C...Diffractive scattering A + B -> X + B.
6762 BSD=2D0*BHB
6763 SQML=(PMA+PMTH)**2
6764 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6765 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6766 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6767 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6768 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6769 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6770 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6771
6772C...Diffractive scattering A + B -> A + X.
6773 BSD=2D0*BHA
6774 SQML=(PMB+PMTH)**2
6775 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6776 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6777 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6778 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6779 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6780 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6781 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6782
6783C...Order single diffractive correctly.
6784 IF(IORD.EQ.2) THEN
6785 SIGSAV=SIGTMP(I,2)
6786 SIGTMP(I,2)=SIGTMP(I,3)
6787 SIGTMP(I,3)=SIGSAV
6788 ENDIF
6789
6790C...Double diffractive scattering A + B -> X1 + X2.
6791 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6792 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6793 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6794 IF(YEFF.LE.0) SUM1=0D0
6795 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6796 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6797 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6798 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6799 & (2D0*ALP)
6800 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6801 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6802 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6803 & (2D0*ALP)
6804 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6805 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6806 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6807 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6808 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6809
6810C...Non-diffractive by unitarity.
6811 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6812 & SIGTMP(I,4)
6813 110 CONTINUE
6814
6815C...Put temporary results in output array: only one process.
6816 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6817 DO 120 J=0,5
6818 SIGT(0,0,J)=SIGTMP(1,J)
6819 120 CONTINUE
6820
6821C...Beam multiple processes.
6822 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6823 IF(MINT(107).EQ.2) THEN
6824 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6825 ELSE
6826 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6827 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6828 ENDIF
6829 IF(MSTP(20).GT.0) THEN
6830 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6831 ENDIF
6832 DO 140 I=1,4
6833 IF(MINT(107).EQ.2) THEN
6834 CONV=(AEM/PARP(160+I))*VINT(317)
6835 ELSEIF(VINT(154).GT.PARP(15)) THEN
6836 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6837 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6838 ELSE
6839 CONV=0D0
6840 ENDIF
6841 I1=MAX(1,I-1)
6842 DO 130 J=0,5
6843 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6844 130 CONTINUE
6845 140 CONTINUE
6846 DO 150 J=0,5
6847 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6848 150 CONTINUE
6849
6850C...Target multiple processes.
6851 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6852 IF(MINT(108).EQ.2) THEN
6853 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6854 ELSE
6855 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6856 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6857 ENDIF
6858 IF(MSTP(20).GT.0) THEN
6859 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6860 ENDIF
6861 DO 170 I=1,4
6862 IF(MINT(108).EQ.2) THEN
6863 CONV=(AEM/PARP(160+I))*VINT(317)
6864 ELSEIF(VINT(154).GT.PARP(15)) THEN
6865 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6866 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6867 ELSE
6868 CONV=0D0
6869 ENDIF
6870 IV=MAX(1,I-1)
6871 DO 160 J=0,5
6872 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6873 160 CONTINUE
6874 170 CONTINUE
6875 DO 180 J=0,5
6876 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6877 180 CONTINUE
6878
6879C...Both beam and target multiple processes.
6880 ELSE
6881 IF(MINT(107).EQ.2) THEN
6882 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6883 ELSE
6884 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6885 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6886 ENDIF
6887 IF(MINT(108).EQ.2) THEN
6888 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6889 ELSE
6890 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6891 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6892 ENDIF
6893 IF(MSTP(20).GT.0) THEN
6894 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6895 & VINT(308)))**MSTP(20)
6896 ENDIF
6897 DO 210 I1=1,4
6898 DO 200 I2=1,4
6899 IF(MINT(107).EQ.2) THEN
6900 CONV=(AEM/PARP(160+I1))*VINT(317)
6901 ELSEIF(VINT(154).GT.PARP(15)) THEN
6902 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6903 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6904 ELSE
6905 CONV=0D0
6906 ENDIF
6907 IF(MINT(108).EQ.2) THEN
6908 CONV=CONV*(AEM/PARP(160+I2))
6909 ELSEIF(VINT(154).GT.PARP(15)) THEN
6910 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6911 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6912 ELSE
6913 CONV=0D0
6914 ENDIF
6915 IF(I1.LE.2) THEN
6916 IV=MAX(1,I2-1)
6917 ELSEIF(I2.LE.2) THEN
6918 IV=MAX(1,I1-1)
6919 ELSEIF(I1.EQ.I2) THEN
6920 IV=2*I1-2
6921 ELSE
6922 IV=5
6923 ENDIF
6924 DO 190 J=0,5
6925 JV=J
6926 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6927 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
6928 190 CONTINUE
6929 200 CONTINUE
6930 210 CONTINUE
6931 DO 230 J=0,5
6932 DO 220 I=1,4
6933 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
6934 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
6935 220 CONTINUE
6936 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6937 230 CONTINUE
6938 ENDIF
6939
6940C...Scale up uniformly for Donnachie-Landshoff parametrization.
6941 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
6942 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
6943 DO 260 I1=0,N1
6944 DO 250 I2=0,N2
6945 DO 240 J=0,5
6946 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
6947 240 CONTINUE
6948 250 CONTINUE
6949 260 CONTINUE
6950 ENDIF
6951
6952 RETURN
6953 END
6954
6955C*********************************************************************
6956
6957C...PYMAXI
6958C...Finds optimal set of coefficients for kinematical variable selection
6959C...and the maximum of the part of the differential cross-section used
6960C...in the event weighting.
6961
6962 SUBROUTINE PYMAXI
6963
6964C...Double precision and integer declarations.
6965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6966 IMPLICIT INTEGER(I-N)
6967 INTEGER PYK,PYCHGE,PYCOMP
6968C...Parameter statement to help give large particle numbers.
6969 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
6970 &KEXCIT=4000000,KDIMEN=5000000)
6971
6972C...User process initialization commonblock.
6973 INTEGER MAXPUP
6974 PARAMETER (MAXPUP=100)
6975 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
6976 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
6977 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
6978 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
6979 &LPRUP(MAXPUP)
6980 SAVE /HEPRUP/
6981
6982C...Commonblocks.
6983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6984 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6985 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
6986 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6987 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6988 COMMON/PYINT1/MINT(400),VINT(400)
6989 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6990 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
6991 COMMON/PYINT4/MWID(500),WIDS(500,5)
6992 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6993 COMMON/PYINT6/PROC(0:500)
6994 CHARACTER PROC*28
6995 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6996 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6997 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
6998C...Local arrays, character variables and data.
6999 CHARACTER CVAR(4)*4
7000 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7001 &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
7002 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7003 DATA CVAR/'tau ','tau''','y* ','cth '/
7004 DATA SIGSSM/3*0D0/
7005
7006C...Initial values and loop over subprocesses.
7007 NPOSI=0
7008 VINT(143)=1D0
7009 VINT(144)=1D0
7010 XSEC(0,1)=0D0
7011 DO 460 ISUB=1,500
7012 MINT(1)=ISUB
7013 MINT(51)=0
7014
7015C...Find maximum weight factors for photon flux.
7016 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7017 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7018 ENDIF
7019
7020C...Select subprocess to study: skip cases not applicable.
7021 IF(ISET(ISUB).EQ.11) THEN
7022 IF(MSUB(ISUB).NE.1) GOTO 460
7023C...User process intialization: cross section model dependent.
7024 IF(IABS(IDWTUP).EQ.1) THEN
7025 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7026 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7027 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7028 ELSE
7029 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7030 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7031 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7032 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7033 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7034 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7035 ENDIF
7036 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7037 & WTGAGA*XSEC(ISUB,1)
7038 NPOSI=NPOSI+1
7039 GOTO 450
7040 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7041 CALL PYSIGH(NCHN,SIGS)
7042 XSEC(ISUB,1)=SIGS
7043 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7044 & WTGAGA*XSEC(ISUB,1)
7045 IF(MSUB(ISUB).NE.1) GOTO 460
7046 NPOSI=NPOSI+1
7047 GOTO 450
7048 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7049 CALL PYSIGH(NCHN,SIGS)
7050 XSEC(ISUB,1)=SIGS
7051 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7052 & WTGAGA*XSEC(ISUB,1)
7053 IF(XSEC(ISUB,1).EQ.0D0) THEN
7054 MSUB(ISUB)=0
7055 ELSE
7056 NPOSI=NPOSI+1
7057 ENDIF
7058 GOTO 450
7059 ELSEIF(ISUB.EQ.96) THEN
7060 IF(MINT(50).EQ.0) GOTO 460
7061 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7062 & GOTO 460
7063 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7064 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7065 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7066 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7067 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7068 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7069 ELSE
7070 IF(MSUB(ISUB).NE.1) GOTO 460
7071 ENDIF
7072 ISTSB=ISET(ISUB)
7073 IF(ISUB.EQ.96) ISTSB=2
7074 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7075 MWTXS=0
7076 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7077 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7078
7079C...Find resonances (explicit or implicit in cross-section).
7080 MINT(72)=0
7081 KFR1=0
7082 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7083 KFR1=KFPR(ISUB,1)
7084 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7085 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7086 KFR1=23
7087 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7088 & .OR.ISUB.EQ.177) THEN
7089 KFR1=24
7090 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7091 KFR1=25
7092 IF(MSTP(46).EQ.5) THEN
7093 KFR1=89
7094 PMAS(89,1)=PARP(45)
7095 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7096 ENDIF
7097 ELSEIF(ISUB.EQ.194) THEN
7098 KFR1=KTECHN+113
7099 ELSEIF(ISUB.EQ.195) THEN
7100 KFR1=KTECHN+213
7101 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
7102 KFR1=KTECHN+113
7103 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
7104 KFR1=KTECHN+213
7105 ENDIF
7106 CKMX=CKIN(2)
7107 IF(CKMX.LE.0D0) CKMX=VINT(1)
7108 KCR1=PYCOMP(KFR1)
7109 IF(KFR1.NE.0) THEN
7110 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7111 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7112 ENDIF
7113 IF(KFR1.NE.0) THEN
7114 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7115 IF(KFR1.EQ.KTECHN+113) THEN
7116 CALL PYTECM(S1,S2)
7117 TAUR1=S1/VINT(2)
7118 ENDIF
7119 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7120 MINT(72)=1
7121 MINT(73)=KFR1
7122 VINT(73)=TAUR1
7123 VINT(74)=GAMR1
7124 ENDIF
7125 KFR2=0
7126 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
7127 $ THEN
7128 KFR2=23
7129 IF(ISUB.EQ.194) THEN
7130 KFR2=KTECHN+223
7131 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
7132 KFR2=KTECHN+223
7133 ENDIF
7134 KCR2=PYCOMP(KFR2)
7135 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7136 IF(KFR2.EQ.KTECHN+223) THEN
7137 CALL PYTECM(S1,S2)
7138 TAUR2=S2/VINT(2)
7139 ENDIF
7140 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7141 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7142 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
7143 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7144 MINT(72)=2
7145 MINT(74)=KFR2
7146 VINT(75)=TAUR2
7147 VINT(76)=GAMR2
7148 ELSEIF(KFR2.NE.0) THEN
7149 KFR1=KFR2
7150 TAUR1=TAUR2
7151 GAMR1=GAMR2
7152 MINT(72)=1
7153 MINT(73)=KFR1
7154 VINT(73)=TAUR1
7155 VINT(74)=GAMR1
7156 KFR2=0
7157 ENDIF
7158 ENDIF
7159
7160C...Find product masses and minimum pT of process.
7161 SQM3=0D0
7162 SQM4=0D0
7163 MINT(71)=0
7164 VINT(71)=CKIN(3)
7165 VINT(80)=1D0
7166 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7167 NBW=0
7168 DO 110 I=1,2
7169 PMMN(I)=0D0
7170 IF(KFPR(ISUB,I).EQ.0) THEN
7171 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7172 & PARP(41)) THEN
7173 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7174 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7175 ELSE
7176 NBW=NBW+1
7177C...This prevents SUSY/t particles from becoming too light.
7178 KFLW=KFPR(ISUB,I)
7179 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7180 KCW=PYCOMP(KFLW)
7181 PMMN(I)=PMAS(KCW,1)
7182 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7183 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7184 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7185 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7186 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7187 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7188 PMMN(I)=MIN(PMMN(I),PMSUM)
7189 ENDIF
7190 100 CONTINUE
7191 ELSEIF(KFLW.EQ.6) THEN
7192 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7193 ENDIF
7194 ENDIF
7195 110 CONTINUE
7196 IF(NBW.GE.1) THEN
7197 CKIN41=CKIN(41)
7198 CKIN43=CKIN(43)
7199 CKIN(41)=MAX(PMMN(1),CKIN(41))
7200 CKIN(43)=MAX(PMMN(2),CKIN(43))
7201 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7202 CKIN(41)=CKIN41
7203 CKIN(43)=CKIN43
7204 IF(MINT(51).EQ.1) THEN
7205 WRITE(MSTU(11),5100) ISUB
7206 MSUB(ISUB)=0
7207 GOTO 460
7208 ENDIF
7209 SQM3=PQM3**2
7210 SQM4=PQM4**2
7211 ENDIF
7212 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7213 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7214 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7215 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7216 ELSEIF(ISUB.EQ.96) THEN
7217 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7218 ENDIF
7219 ENDIF
7220 VINT(63)=SQM3
7221 VINT(64)=SQM4
7222
7223C...Prepare for additional variable choices in 2 -> 3.
7224 IF(ISTSB.EQ.5) THEN
7225 VINT(201)=0D0
7226 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7227 VINT(206)=VINT(201)
7228 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7229 VINT(204)=PMAS(23,1)
7230 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7231 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7232 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7233 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7234 & VINT(204)=VINT(201)
7235 VINT(209)=VINT(204)
7236 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7237 ENDIF
7238
7239C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7240 NPTS(1)=2+2*MINT(72)
7241 IF(MINT(47).EQ.1) THEN
7242 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7243 ELSEIF(MINT(47).GE.5) THEN
7244 IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1
7245 ENDIF
7246 NPTS(2)=1
7247 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7248 IF(MINT(47).GE.2) NPTS(2)=2
7249 IF(MINT(47).GE.5) NPTS(2)=3
7250 ENDIF
7251 NPTS(3)=1
7252 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7253 NPTS(3)=3
7254 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7255 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7256 ENDIF
7257 NPTS(4)=1
7258 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7259 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7260
7261C...Reset coefficients of cross-section weighting.
7262 DO 120 J=1,20
7263 COEF(ISUB,J)=0D0
7264 120 CONTINUE
7265 COEF(ISUB,1)=1D0
7266 COEF(ISUB,8)=0.5D0
7267 COEF(ISUB,9)=0.5D0
7268 COEF(ISUB,13)=1D0
7269 COEF(ISUB,18)=1D0
7270 MCTH=0
7271 MTAUP=0
7272 METAUP=0
7273 VINT(23)=0D0
7274 VINT(26)=0D0
7275 SIGSAM=0D0
7276
7277C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7278C...in grid of phase space points.
7279 CALL PYKLIM(1)
7280 METAU=MINT(51)
7281 NACC=0
7282 DO 150 ITRY=1,NTRY
7283 MINT(51)=0
7284 IF(METAU.EQ.1) GOTO 150
7285 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7286 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7287 IF(MTAU.GT.2+2*MINT(72)) MTAU=7
7288 RTAU=0.5D0
7289C...Special case when both resonances have same mass,
7290C...as is often the case in process 194.
7291 IF(MINT(72).EQ.2) THEN
7292 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7293 & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7294 IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7295 RTAU=0.4D0
7296 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7297 RTAU=0.6D0
7298 ENDIF
7299 ENDIF
7300 ENDIF
7301 CALL PYKMAP(1,MTAU,RTAU)
7302 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7303 METAUP=MINT(51)
7304 ENDIF
7305 IF(METAUP.EQ.1) GOTO 150
7306 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7307 & .EQ.0) THEN
7308 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7309 CALL PYKMAP(4,MTAUP,0.5D0)
7310 ENDIF
7311 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7312 CALL PYKLIM(2)
7313 MEYST=MINT(51)
7314 ENDIF
7315 IF(MEYST.EQ.1) GOTO 150
7316 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7317 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7318 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7319 CALL PYKMAP(2,MYST,0.5D0)
7320 CALL PYKLIM(3)
7321 MECTH=MINT(51)
7322 ENDIF
7323 IF(MECTH.EQ.1) GOTO 150
7324 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7325 MCTH=1+MOD(ITRY-1,NPTS(4))
7326 CALL PYKMAP(3,MCTH,0.5D0)
7327 ENDIF
7328 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7329
7330C...Store position and limits.
7331 MINT(51)=0
7332 CALL PYKLIM(0)
7333 IF(MINT(51).EQ.1) GOTO 150
7334 NACC=NACC+1
7335 MVARPT(NACC,1)=MTAU
7336 MVARPT(NACC,2)=MTAUP
7337 MVARPT(NACC,3)=MYST
7338 MVARPT(NACC,4)=MCTH
7339 DO 130 J=1,30
7340 VINTPT(NACC,J)=VINT(10+J)
7341 130 CONTINUE
7342
7343C...Normal case: calculate cross-section.
7344 IF(ISTSB.NE.5) THEN
7345 CALL PYSIGH(NCHN,SIGS)
7346 IF(MWTXS.EQ.1) THEN
7347 CALL PYEVWT(WTXS)
7348 SIGS=WTXS*SIGS
7349 ENDIF
7350
7351C..2 -> 3: find highest value out of a number of tries.
7352 ELSE
7353 SIGS=0D0
7354 DO 140 IKIN3=1,MSTP(129)
7355 CALL PYKMAP(5,0,0D0)
7356 IF(MINT(51).EQ.1) GOTO 140
7357 CALL PYSIGH(NCHN,SIGTMP)
7358 IF(MWTXS.EQ.1) THEN
7359 CALL PYEVWT(WTXS)
7360 SIGTMP=WTXS*SIGTMP
7361 ENDIF
7362 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7363 140 CONTINUE
7364 ENDIF
7365
7366C...Store cross-section.
7367 SIGSPT(NACC)=SIGS
7368 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7369 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7370 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7371 150 CONTINUE
7372 IF(NACC.EQ.0) THEN
7373 WRITE(MSTU(11),5100) ISUB
7374 MSUB(ISUB)=0
7375 GOTO 460
7376 ELSEIF(SIGSAM.EQ.0D0) THEN
7377 WRITE(MSTU(11),5300) ISUB
7378 MSUB(ISUB)=0
7379 GOTO 460
7380 ENDIF
7381 IF(ISUB.NE.96) NPOSI=NPOSI+1
7382
7383C...Calculate integrals in tau over maximal phase space limits.
7384 TAUMIN=VINT(11)
7385 TAUMAX=VINT(31)
7386 ATAU1=LOG(TAUMAX/TAUMIN)
7387 IF(NPTS(1).GE.2) THEN
7388 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7389 ENDIF
7390 IF(NPTS(1).GE.4) THEN
7391 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7392 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7393 & GAMR1
7394 ENDIF
7395 IF(NPTS(1).GE.6) THEN
7396 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7397 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7398 & GAMR2
7399 ENDIF
7400 IF(NPTS(1).GT.2+2*MINT(72)) THEN
7401 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7402 ENDIF
7403
7404C...Reset. Sum up cross-sections in points calculated.
7405 DO 320 IVAR=1,4
7406 IF(NPTS(IVAR).EQ.1) GOTO 320
7407 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7408 NBIN=NPTS(IVAR)
7409 DO 170 J1=1,NBIN
7410 NAREL(J1)=0
7411 WTREL(J1)=0D0
7412 COEFU(J1)=0D0
7413 DO 160 J2=1,NBIN
7414 WTMAT(J1,J2)=0D0
7415 160 CONTINUE
7416 170 CONTINUE
7417 DO 180 IACC=1,NACC
7418 IBIN=MVARPT(IACC,IVAR)
7419 IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
7420 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7421 NAREL(IBIN)=NAREL(IBIN)+1
7422 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7423
7424C...Sum up tau cross-section pieces in points used.
7425 IF(IVAR.EQ.1) THEN
7426 TAU=VINTPT(IACC,11)
7427 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7428 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7429 IF(NBIN.GE.4) THEN
7430 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7431 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7432 & ((TAU-TAUR1)**2+GAMR1**2)
7433 ENDIF
7434 IF(NBIN.GE.6) THEN
7435 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7436 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7437 & ((TAU-TAUR2)**2+GAMR2**2)
7438 ENDIF
7439 IF(NBIN.GT.2+2*MINT(72)) THEN
7440 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
7441 & TAU/MAX(2D-10,1D0-TAU)
7442 ENDIF
7443
7444C...Sum up tau' cross-section pieces in points used.
7445 ELSEIF(IVAR.EQ.2) THEN
7446 TAU=VINTPT(IACC,11)
7447 TAUP=VINTPT(IACC,16)
7448 TAUPMN=VINTPT(IACC,6)
7449 TAUPMX=VINTPT(IACC,26)
7450 ATAUP1=LOG(TAUPMX/TAUPMN)
7451 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7452 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7453 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7454 & (1D0-TAU/TAUP)**3/TAUP
7455 IF(NBIN.GE.3) THEN
7456 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7457 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7458 & TAUP/MAX(2D-10,1D0-TAUP)
7459 ENDIF
7460
7461C...Sum up y* cross-section pieces in points used.
7462 ELSEIF(IVAR.EQ.3) THEN
7463 YST=VINTPT(IACC,12)
7464 YSTMIN=VINTPT(IACC,2)
7465 YSTMAX=VINTPT(IACC,22)
7466 AYST0=YSTMAX-YSTMIN
7467 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7468 AYST2=AYST1
7469 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7470 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7471 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7472 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7473 IF(MINT(45).EQ.3) THEN
7474 TAUE=VINTPT(IACC,11)
7475 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7476 YST0=-0.5D0*LOG(TAUE)
7477 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7478 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7479 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7480 & MAX(1D-10,1D0-EXP(YST-YST0))
7481 ENDIF
7482 IF(MINT(46).EQ.3) THEN
7483 TAUE=VINTPT(IACC,11)
7484 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7485 YST0=-0.5D0*LOG(TAUE)
7486 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7487 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7488 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7489 & MAX(1D-10,1D0-EXP(-YST-YST0))
7490 ENDIF
7491
7492C...Sum up cos(theta-hat) cross-section pieces in points used.
7493 ELSE
7494 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7495 RSQM=1D0+RM34
7496 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7497 CTHMIN=-CTHMAX
7498 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7499 & (TAUMAX*VINT(2)))
7500 ACTH1=CTHMAX-CTHMIN
7501 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7502 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7503 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7504 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7505 CTH=VINTPT(IACC,13)
7506 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7507 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7508 & MAX(RM34,RSQM-CTH)
7509 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7510 & MAX(RM34,RSQM+CTH)
7511 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7512 & MAX(RM34,RSQM-CTH)**2
7513 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7514 & MAX(RM34,RSQM+CTH)**2
7515 ENDIF
7516 180 CONTINUE
7517
7518C...Check that equation system solvable.
7519 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7520 MSOLV=1
7521 WTRELS=0D0
7522 DO 190 IBIN=1,NBIN
7523 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7524 & IRED=1,NBIN),WTREL(IBIN)
7525 IF(NAREL(IBIN).EQ.0) MSOLV=0
7526 WTRELS=WTRELS+WTREL(IBIN)
7527 190 CONTINUE
7528 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7529
7530C...Solve to find relative importance of cross-section pieces.
7531 IF(MSOLV.EQ.1) THEN
7532 DO 200 IBIN=1,NBIN
7533 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7534 200 CONTINUE
7535 DO 230 IRED=1,NBIN-1
7536 DO 220 IBIN=IRED+1,NBIN
7537 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7538 MSOLV=0
7539 GOTO 260
7540 ENDIF
7541 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7542 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7543 DO 210 ICOE=IRED,NBIN
7544 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7545 210 CONTINUE
7546 220 CONTINUE
7547 230 CONTINUE
7548 DO 250 IRED=NBIN,1,-1
7549 DO 240 ICOE=IRED+1,NBIN
7550 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7551 240 CONTINUE
7552 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7553 250 CONTINUE
7554 ENDIF
7555
7556C...Share evenly if failure.
7557 260 IF(MSOLV.EQ.0) THEN
7558 DO 270 IBIN=1,NBIN
7559 COEFU(IBIN)=1D0
7560 WTRELN(IBIN)=0.1D0
7561 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7562 & WTREL(IBIN)/WTRELS)
7563 270 CONTINUE
7564 ENDIF
7565
7566C...Normalize coefficients, with piece shared democratically.
7567 COEFSU=0D0
7568 WTRELS=0D0
7569 DO 280 IBIN=1,NBIN
7570 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7571 COEFSU=COEFSU+COEFU(IBIN)
7572 WTRELS=WTRELS+WTRELN(IBIN)
7573 280 CONTINUE
7574 IF(COEFSU.GT.0D0) THEN
7575 DO 290 IBIN=1,NBIN
7576 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7577 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7578 290 CONTINUE
7579 ELSE
7580 DO 300 IBIN=1,NBIN
7581 COEFO(IBIN)=1D0/NBIN
7582 300 CONTINUE
7583 ENDIF
7584 IF(IVAR.EQ.1) IOFF=0
7585 IF(IVAR.EQ.2) IOFF=17
7586 IF(IVAR.EQ.3) IOFF=7
7587 IF(IVAR.EQ.4) IOFF=12
7588 DO 310 IBIN=1,NBIN
7589 ICOF=IOFF+IBIN
7590 IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
7591 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7592 COEF(ISUB,ICOF)=COEFO(IBIN)
7593 310 CONTINUE
7594 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7595 & (COEFO(IBIN),IBIN=1,NBIN)
7596 320 CONTINUE
7597
7598C...Find two most promising maxima among points previously determined.
7599 DO 330 J=1,4
7600 IACCMX(J)=0
7601 SIGSMX(J)=0D0
7602 330 CONTINUE
7603 NMAX=0
7604 DO 390 IACC=1,NACC
7605 DO 340 J=1,30
7606 VINT(10+J)=VINTPT(IACC,J)
7607 340 CONTINUE
7608 IF(ISTSB.NE.5) THEN
7609 CALL PYSIGH(NCHN,SIGS)
7610 IF(MWTXS.EQ.1) THEN
7611 CALL PYEVWT(WTXS)
7612 SIGS=WTXS*SIGS
7613 ENDIF
7614 ELSE
7615 SIGS=0D0
7616 DO 350 IKIN3=1,MSTP(129)
7617 CALL PYKMAP(5,0,0D0)
7618 IF(MINT(51).EQ.1) GOTO 350
7619 CALL PYSIGH(NCHN,SIGTMP)
7620 IF(MWTXS.EQ.1) THEN
7621 CALL PYEVWT(WTXS)
7622 SIGTMP=WTXS*SIGTMP
7623 ENDIF
7624 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7625 350 CONTINUE
7626 ENDIF
7627 IEQ=0
7628 DO 360 IMV=1,NMAX
7629 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7630 360 CONTINUE
7631 IF(IEQ.EQ.0) THEN
7632 DO 370 IMV=NMAX,1,-1
7633 IIN=IMV+1
7634 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7635 IACCMX(IMV+1)=IACCMX(IMV)
7636 SIGSMX(IMV+1)=SIGSMX(IMV)
7637 370 CONTINUE
7638 IIN=1
7639 380 IACCMX(IIN)=IACC
7640 SIGSMX(IIN)=SIGS
7641 IF(NMAX.LE.1) NMAX=NMAX+1
7642 ENDIF
7643 390 CONTINUE
7644
7645C...Read out starting position for search.
7646 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7647 SIGSAM=SIGSMX(1)
7648 DO 440 IMAX=1,NMAX
7649 IACC=IACCMX(IMAX)
7650 MTAU=MVARPT(IACC,1)
7651 MTAUP=MVARPT(IACC,2)
7652 MYST=MVARPT(IACC,3)
7653 MCTH=MVARPT(IACC,4)
7654 VTAU=0.5D0
7655 VYST=0.5D0
7656 VCTH=0.5D0
7657 VTAUP=0.5D0
7658
7659C...Starting point and step size in parameter space.
7660 DO 430 IRPT=1,2
7661 DO 420 IVAR=1,4
7662 IF(NPTS(IVAR).EQ.1) GOTO 420
7663 IF(IVAR.EQ.1) VVAR=VTAU
7664 IF(IVAR.EQ.2) VVAR=VTAUP
7665 IF(IVAR.EQ.3) VVAR=VYST
7666 IF(IVAR.EQ.4) VVAR=VCTH
7667 IF(IVAR.EQ.1) MVAR=MTAU
7668 IF(IVAR.EQ.2) MVAR=MTAUP
7669 IF(IVAR.EQ.3) MVAR=MYST
7670 IF(IVAR.EQ.4) MVAR=MCTH
7671 IF(IRPT.EQ.1) VDEL=0.1D0
7672 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7673 & 0.98D0-VVAR))
7674 IF(IRPT.EQ.1) VMAR=0.02D0
7675 IF(IRPT.EQ.2) VMAR=0.002D0
7676 IMOV0=1
7677 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7678 DO 410 IMOV=IMOV0,8
7679
7680C...Define new point in parameter space.
7681 IF(IMOV.EQ.0) THEN
7682 INEW=2
7683 VNEW=VVAR
7684 ELSEIF(IMOV.EQ.1) THEN
7685 INEW=3
7686 VNEW=VVAR+VDEL
7687 ELSEIF(IMOV.EQ.2) THEN
7688 INEW=1
7689 VNEW=VVAR-VDEL
7690 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7691 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7692 VVAR=VVAR+VDEL
7693 SIGSSM(1)=SIGSSM(2)
7694 SIGSSM(2)=SIGSSM(3)
7695 INEW=3
7696 VNEW=VVAR+VDEL
7697 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7698 & VVAR-2D0*VDEL.GT.VMAR) THEN
7699 VVAR=VVAR-VDEL
7700 SIGSSM(3)=SIGSSM(2)
7701 SIGSSM(2)=SIGSSM(1)
7702 INEW=1
7703 VNEW=VVAR-VDEL
7704 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
7705 VDEL=0.5D0*VDEL
7706 VVAR=VVAR+VDEL
7707 SIGSSM(1)=SIGSSM(2)
7708 INEW=2
7709 VNEW=VVAR
7710 ELSE
7711 VDEL=0.5D0*VDEL
7712 VVAR=VVAR-VDEL
7713 SIGSSM(3)=SIGSSM(2)
7714 INEW=2
7715 VNEW=VVAR
7716 ENDIF
7717
7718C...Convert to relevant variables and find derived new limits.
7719 ILERR=0
7720 IF(IVAR.EQ.1) THEN
7721 VTAU=VNEW
7722 CALL PYKMAP(1,MTAU,VTAU)
7723 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7724 CALL PYKLIM(4)
7725 IF(MINT(51).EQ.1) ILERR=1
7726 ENDIF
7727 ENDIF
7728 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
7729 & ILERR.EQ.0) THEN
7730 IF(IVAR.EQ.2) VTAUP=VNEW
7731 CALL PYKMAP(4,MTAUP,VTAUP)
7732 ENDIF
7733 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
7734 CALL PYKLIM(2)
7735 IF(MINT(51).EQ.1) ILERR=1
7736 ENDIF
7737 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
7738 IF(IVAR.EQ.3) VYST=VNEW
7739 CALL PYKMAP(2,MYST,VYST)
7740 CALL PYKLIM(3)
7741 IF(MINT(51).EQ.1) ILERR=1
7742 ENDIF
7743 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
7744 & ILERR.EQ.0) THEN
7745 IF(IVAR.EQ.4) VCTH=VNEW
7746 CALL PYKMAP(3,MCTH,VCTH)
7747 ENDIF
7748 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
7749
7750C...Evaluate cross-section. Save new maximum. Final maximum.
7751 IF(ILERR.NE.0) THEN
7752 SIGS=0.
7753 ELSEIF(ISTSB.NE.5) THEN
7754 CALL PYSIGH(NCHN,SIGS)
7755 IF(MWTXS.EQ.1) THEN
7756 CALL PYEVWT(WTXS)
7757 SIGS=WTXS*SIGS
7758 ENDIF
7759 ELSE
7760 SIGS=0D0
7761 DO 400 IKIN3=1,MSTP(129)
7762 CALL PYKMAP(5,0,0D0)
7763 IF(MINT(51).EQ.1) GOTO 400
7764 CALL PYSIGH(NCHN,SIGTMP)
7765 IF(MWTXS.EQ.1) THEN
7766 CALL PYEVWT(WTXS)
7767 SIGTMP=WTXS*SIGTMP
7768 ENDIF
7769 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7770 400 CONTINUE
7771 ENDIF
7772 SIGSSM(INEW)=SIGS
7773 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7774 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
7775 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7776 410 CONTINUE
7777 420 CONTINUE
7778 430 CONTINUE
7779 440 CONTINUE
7780 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
7781 XSEC(ISUB,1)=1.05D0*SIGSAM
7782 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7783 & WTGAGA*XSEC(ISUB,1)
7784 450 CONTINUE
7785 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
7786 & PARP(174)*XSEC(ISUB,1)
7787 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
7788 460 CONTINUE
7789 MINT(51)=0
7790
7791C...Print summary table.
7792 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
7793 IF(MSTP(127).NE.1) THEN
7794 WRITE(MSTU(11),5900)
7795 STOP
7796 ELSE
7797 WRITE(MSTU(11),6400)
7798 MSTI(53)=1
7799 ENDIF
7800 ENDIF
7801 IF(MSTP(122).GE.1) THEN
7802 WRITE(MSTU(11),6000)
7803 WRITE(MSTU(11),6100)
7804 DO 470 ISUB=1,500
7805 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
7806 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
7807 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
7808 & GOTO 470
7809 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
7810 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
7811 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
7812 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
7813 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
7814 470 CONTINUE
7815 WRITE(MSTU(11),6300)
7816 ENDIF
7817
7818C...Format statements for maximization results.
7819 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
7820 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
7821 &'cth',9X,'tau''',7X,'sigma')
7822 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
7823 &'phase space.'/1X,'Process switched off!')
7824 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
7825 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
7826 &'cross-section.'/1X,'Process switched off!')
7827 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
7828 5500 FORMAT(1X,1P,8D11.3)
7829 5600 FORMAT(1X,'Result for ',A4,':',7F9.4)
7830 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
7831 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
7832 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
7833 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
7834 &'cross-section.'/1X,'Execution stopped!')
7835 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
7836 &'cross-section maximum search',1X,8('*'))
7837 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
7838 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
7839 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
7840 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
7841 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
7842 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
7843 &'cross-section.'/
7844 &1X,'Execution will stop if you try to generate events.')
7845
7846 RETURN
7847 END
7848
7849C*********************************************************************
7850
7851C...PYPILE
7852C...Initializes multiplicity distribution and selects mutliplicity
7853C...of pileup events, i.e. several events occuring at the same
7854C...beam crossing.
7855
7856 SUBROUTINE PYPILE(MPILE)
7857
7858C...Double precision and integer declarations.
7859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7860 IMPLICIT INTEGER(I-N)
7861 INTEGER PYK,PYCHGE,PYCOMP
7862C...Commonblocks.
7863 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7864 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7865 COMMON/PYINT1/MINT(400),VINT(400)
7866 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7867 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
7868C...Local arrays and saved variables.
7869 DIMENSION WTI(0:200)
7870 SAVE IMIN,IMAX,WTI,WTS
7871
7872C...Sum of allowed cross-sections for pileup events.
7873 IF(MPILE.EQ.1) THEN
7874 VINT(131)=SIGT(0,0,5)
7875 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
7876 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
7877 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
7878 IF(MSTP(133).LE.0) RETURN
7879
7880C...Initialize multiplicity distribution at maximum.
7881 XNAVE=VINT(131)*PARP(131)
7882 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
7883 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
7884 WTI(INAVE)=1D0
7885 WTS=WTI(INAVE)
7886 WTN=WTI(INAVE)*INAVE
7887
7888C...Find shape of multiplicity distribution below maximum.
7889 IMIN=INAVE
7890 DO 100 I=INAVE-1,1,-1
7891 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
7892 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
7893 IF(WTI(I).LT.1D-6) GOTO 110
7894 WTS=WTS+WTI(I)
7895 WTN=WTN+WTI(I)*I
7896 IMIN=I
7897 100 CONTINUE
7898
7899C...Find shape of multiplicity distribution above maximum.
7900 110 IMAX=INAVE
7901 DO 120 I=INAVE+1,200
7902 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
7903 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
7904 IF(WTI(I).LT.1D-6) GOTO 130
7905 WTS=WTS+WTI(I)
7906 WTN=WTN+WTI(I)*I
7907 IMAX=I
7908 120 CONTINUE
7909 130 VINT(132)=XNAVE
7910 VINT(133)=WTN/WTS
7911 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
7912 & WTS/(WTS+WTI(1)/XNAVE)
7913 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
7914 IF(MSTP(133).GE.2) VINT(134)=XNAVE
7915
7916C...Pick multiplicity of pileup events.
7917 ELSE
7918 IF(MSTP(133).LE.0) THEN
7919 MINT(81)=MAX(1,MSTP(134))
7920 ELSE
7921 WTR=WTS*PYR(0)
7922 DO 140 I=IMIN,IMAX
7923 MINT(81)=I
7924 WTR=WTR-WTI(I)
7925 IF(WTR.LE.0D0) GOTO 150
7926 140 CONTINUE
7927 150 CONTINUE
7928 ENDIF
7929 ENDIF
7930
7931C...Format statement for error message.
7932 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
7933 &'crossing too large, ',1P,D12.4)
7934
7935 RETURN
7936 END
7937
7938C*********************************************************************
7939
7940C...PYSAVE
7941C...Saves and restores parameter and cross section values for the
7942C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
7943C...Also makes random choice between alternatives.
7944
7945 SUBROUTINE PYSAVE(ISAVE,IGA)
7946
7947C...Double precision and integer declarations.
7948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7949 IMPLICIT INTEGER(I-N)
7950 INTEGER PYK,PYCHGE,PYCOMP
7951C...Commonblocks.
7952 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7953 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7954 COMMON/PYINT1/MINT(400),VINT(400)
7955 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7956 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7957 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7958 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
7959C...Local arrays and saved variables.
7960 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
7961 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
7962 &INTCP(15,20),RECP(15,20)
7963 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
7964
7965C...Save list of subprocesses and cross-section information.
7966 IF(ISAVE.EQ.1) THEN
7967 ICP=0
7968 DO 120 I=1,500
7969 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
7970 ICP=ICP+1
7971 NSUBCP(IGA,ICP)=I
7972 MSUBCP(IGA,ICP)=MSUB(I)
7973 DO 100 J=1,20
7974 COEFCP(IGA,ICP,J)=COEF(I,J)
7975 100 CONTINUE
7976 DO 110 J=1,3
7977 NGENCP(IGA,ICP,J)=NGEN(I,J)
7978 XSECCP(IGA,ICP,J)=XSEC(I,J)
7979 110 CONTINUE
7980 120 CONTINUE
7981 NCP(IGA)=ICP
7982 DO 130 J=1,3
7983 NGENCP(IGA,0,J)=NGEN(0,J)
7984 XSECCP(IGA,0,J)=XSEC(0,J)
7985 130 CONTINUE
7986 DO 160 I1=0,6
7987 DO 150 I2=0,6
7988 DO 140 J=0,5
7989 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
7990 140 CONTINUE
7991 150 CONTINUE
7992 160 CONTINUE
7993
7994C...Save various common process variables.
7995 DO 170 J=1,10
7996 INTCP(IGA,J)=MINT(40+J)
7997 170 CONTINUE
7998 INTCP(IGA,11)=MINT(101)
7999 INTCP(IGA,12)=MINT(102)
8000 INTCP(IGA,13)=MINT(107)
8001 INTCP(IGA,14)=MINT(108)
8002 INTCP(IGA,15)=MINT(123)
8003 RECP(IGA,1)=CKIN(3)
8004 RECP(IGA,2)=VINT(318)
8005
8006C...Save cross-section information only.
8007 ELSEIF(ISAVE.EQ.2) THEN
8008 DO 190 ICP=1,NCP(IGA)
8009 I=NSUBCP(IGA,ICP)
8010 DO 180 J=1,3
8011 NGENCP(IGA,ICP,J)=NGEN(I,J)
8012 XSECCP(IGA,ICP,J)=XSEC(I,J)
8013 180 CONTINUE
8014 190 CONTINUE
8015 DO 200 J=1,3
8016 NGENCP(IGA,0,J)=NGEN(0,J)
8017 XSECCP(IGA,0,J)=XSEC(0,J)
8018 200 CONTINUE
8019
8020C...Choose between allowed alternatives.
8021 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8022 IF(ISAVE.EQ.4) THEN
8023 XSUMCP=0D0
8024 DO 210 IG=1,MINT(121)
8025 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8026 210 CONTINUE
8027 XSUMCP=XSUMCP*PYR(0)
8028 DO 220 IG=1,MINT(121)
8029 IGA=IG
8030 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8031 IF(XSUMCP.LE.0D0) GOTO 230
8032 220 CONTINUE
8033 230 CONTINUE
8034 ENDIF
8035
8036C...Restore cross-section information.
8037 DO 240 I=1,500
8038 MSUB(I)=0
8039 240 CONTINUE
8040 DO 270 ICP=1,NCP(IGA)
8041 I=NSUBCP(IGA,ICP)
8042 MSUB(I)=MSUBCP(IGA,ICP)
8043 DO 250 J=1,20
8044 COEF(I,J)=COEFCP(IGA,ICP,J)
8045 250 CONTINUE
8046 DO 260 J=1,3
8047 NGEN(I,J)=NGENCP(IGA,ICP,J)
8048 XSEC(I,J)=XSECCP(IGA,ICP,J)
8049 260 CONTINUE
8050 270 CONTINUE
8051 DO 280 J=1,3
8052 NGEN(0,J)=NGENCP(IGA,0,J)
8053 XSEC(0,J)=XSECCP(IGA,0,J)
8054 280 CONTINUE
8055 DO 310 I1=0,6
8056 DO 300 I2=0,6
8057 DO 290 J=0,5
8058 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8059 290 CONTINUE
8060 300 CONTINUE
8061 310 CONTINUE
8062
8063C...Restore various common process variables.
8064 DO 320 J=1,10
8065 MINT(40+J)=INTCP(IGA,J)
8066 320 CONTINUE
8067 MINT(101)=INTCP(IGA,11)
8068 MINT(102)=INTCP(IGA,12)
8069 MINT(107)=INTCP(IGA,13)
8070 MINT(108)=INTCP(IGA,14)
8071 MINT(123)=INTCP(IGA,15)
8072 CKIN(3)=RECP(IGA,1)
8073 CKIN(1)=2D0*CKIN(3)
8074 VINT(318)=RECP(IGA,2)
8075
8076C...Sum up cross-section info (for PYSTAT).
8077 ELSEIF(ISAVE.EQ.5) THEN
8078 DO 330 I=1,500
8079 MSUB(I)=0
8080 NGEN(I,1)=0
8081 NGEN(I,3)=0
8082 XSEC(I,3)=0D0
8083 330 CONTINUE
8084 NGEN(0,1)=0
8085 NGEN(0,2)=0
8086 NGEN(0,3)=0
8087 XSEC(0,3)=0
8088 DO 350 IG=1,MINT(121)
8089 DO 340 ICP=1,NCP(IG)
8090 I=NSUBCP(IG,ICP)
8091 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8092 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8093 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8094 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8095 340 CONTINUE
8096 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8097 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8098 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8099 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8100 350 CONTINUE
8101 ENDIF
8102
8103 RETURN
8104 END
8105
8106C*********************************************************************
8107
8108C...PYGAGA
8109C...For lepton beams it gives photon-hadron or photon-photon systems
8110C...to be treated with the ordinary machinery and combines this with a
8111C...description of the lepton -> lepton + photon branching.
8112
8113 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8114
8115C...Double precision and integer declarations.
8116 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8117 IMPLICIT INTEGER(I-N)
8118 INTEGER PYK,PYCHGE,PYCOMP
8119C...Commonblocks.
8120 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8121 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8122 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8123 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8125 COMMON/PYINT1/MINT(400),VINT(400)
8126 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8127 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8128 &/PYINT5/
8129C...Local variables and data statement.
8130 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8131 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8132 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8133 DATA EPS/1D-4/
8134
8135C...Initialize generation of photons inside leptons.
8136 IF(IGAGA.EQ.1) THEN
8137
8138C...Save quantities on incoming lepton system.
8139 VINT(301)=VINT(1)
8140 VINT(302)=VINT(2)
8141 PMS(1)=VINT(303)**2
8142 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8143 PMS(2)=VINT(304)**2
8144 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8145 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8146 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8147
8148C...Calculate range of x and Q2 values allowed in generation.
8149 DO 100 I=1,2
8150 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8151 IF(MINT(140+I).NE.0) THEN
8152 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8153 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8154 & PMC(I),1D0-EPS)
8155 YMIN=MAX(CKIN(71+2*I),EPS)
8156 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8157 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8158 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8159 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8160 THEMIN=MAX(CKIN(67+2*I),0D0)
8161 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8162 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8163 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8164 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8165 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8166 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8167 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8168 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8169 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8170C...W limits when lepton on one side only.
8171 IF(MINT(143-I).EQ.0) THEN
8172 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8173 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8174 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8175 ENDIF
8176 ENDIF
8177 100 CONTINUE
8178
8179C...W limits when lepton on both sides.
8180 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8181 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8182 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8183 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8184 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8185 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8186 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8187 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8188 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8189 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8190 ELSE
8191 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8192 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8193 ENDIF
8194 ENDIF
8195
8196C...Q2 and W values and photon flux weight factors for initialization.
8197 ELSEIF(IGAGA.EQ.2) THEN
8198 ISUB=MINT(1)
8199 MINT(15)=0
8200 MINT(16)=0
8201
8202C...W value for photon on one or both sides, and for processes
8203C...with gamma-gamma cross section peaked at small shat.
8204 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8205 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8206 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8207 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8208 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8209 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8210 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8211 ELSE
8212 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8213 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8214 ENDIF
8215 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8216
8217C...Upper estimate of photon flux weight factor.
8218C...Initialization Q2 scale. Flag incoming unresolved photon.
8219 WTGAGA=1D0
8220 DO 110 I=1,2
8221 IF(MINT(140+I).NE.0) THEN
8222 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8223 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8224 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8225 & THEN
8226 Q2INIT=5D0+Q2MIN(3-I)
8227 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8228 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8229 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8230 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8231 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8232 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8233 Q2INIT=VINT(2)/3D0
8234 ELSEIF(ISUB.EQ.140) THEN
8235 Q2INIT=VINT(2)/2D0
8236 ELSE
8237 Q2INIT=Q2MIN(I)
8238 ENDIF
8239 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8240 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8241 & MINT(14+I)=22
8242 VINT(306+I)=VINT(2+I)**2
8243 ENDIF
8244 110 CONTINUE
8245 VINT(320)=WTGAGA
8246
8247C...Update pTmin and cross section information.
8248 IF(MSTP(82).LE.1) THEN
8249 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8250 ELSE
8251 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8252 ENDIF
8253 VINT(149)=4D0*PTMN**2/VINT(2)
8254 VINT(154)=PTMN
8255 CALL PYXTOT
8256 VINT(318)=VINT(317)
8257
8258C...Generate photons inside leptons and
8259C...calculate photon flux weight factors.
8260 ELSEIF(IGAGA.EQ.3) THEN
8261 ISUB=MINT(1)
8262 MINT(15)=0
8263 MINT(16)=0
8264
8265C...Generate phase space point and check against cuts.
8266 LOOP=0
8267 120 LOOP=LOOP+1
8268 DO 130 I=1,2
8269 IF(MINT(140+I).NE.0) THEN
8270C...Pick x and Q2
8271 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8272 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8273C...Cuts on internal consistency in x and Q2.
8274 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8275 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8276 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8277C...Cuts on y and theta.
8278 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8279 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8280 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8281 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8282 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8283 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8284 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8285 & GOTO 120
8286
8287C...Phi angle isotropic. Reconstruct pT.
8288 PHI(I)=PARU(2)*PYR(0)
8289 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8290 & PMS(I))*SIN(THETA(I))
8291
8292C...Store info on variables selected, for documentation purposes.
8293 VINT(2+I)=-SQRT(Q2(I))
8294 VINT(304+I)=X(I)
8295 VINT(306+I)=Q2(I)
8296 VINT(308+I)=Y(I)
8297 VINT(310+I)=THETA(I)
8298 VINT(312+I)=PHI(I)
8299 ELSE
8300 VINT(304+I)=1D0
8301 VINT(306+I)=0D0
8302 VINT(308+I)=1D0
8303 VINT(310+I)=0D0
8304 VINT(312+I)=0D0
8305 ENDIF
8306 130 CONTINUE
8307
8308C...Cut on W combines info from two sides.
8309 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8310 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8311 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8312 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8313 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8314 IF(W2.LT.W2MIN) GOTO 120
8315 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8316 PMS1=-Q2(1)
8317 PMS2=-Q2(2)
8318 ELSEIF(MINT(141).NE.0) THEN
8319 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8320 PMS1=-Q2(1)
8321 PMS2=PMS(2)
8322 ELSEIF(MINT(142).NE.0) THEN
8323 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8324 PMS1=PMS(1)
8325 PMS2=-Q2(2)
8326 ENDIF
8327
8328C...Store kinematics info for photon(s) in subsystem cm frame.
8329 VINT(2)=W2
8330 VINT(1)=SQRT(W2)
8331 VINT(291)=0D0
8332 VINT(292)=0D0
8333 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8334 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8335 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8336 VINT(296)=0D0
8337 VINT(297)=0D0
8338 VINT(298)=-VINT(293)
8339 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8340 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8341
8342C...Assign weight for photon flux; different for transverse and
8343C...longitudinal photons. Flag incoming unresolved photon.
8344 WTGAGA=1D0
8345 DO 140 I=1,2
8346 IF(MINT(140+I).NE.0) THEN
8347 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8348 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8349 IF(MSTP(16).EQ.0) THEN
8350 XY=X(I)
8351 ELSE
8352 WTGAGA=WTGAGA*X(I)/Y(I)
8353 XY=Y(I)
8354 ENDIF
8355 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8356 WTGAGA=WTGAGA*(1D0-XY)
8357 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8358 WTGAGA=WTGAGA*(1D0-XY)
8359 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8360 WTGAGA=WTGAGA*(1D0-XY)
8361 ELSE
8362 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8363 & PMS(I)*XY**2/Q2(I))
8364 ENDIF
8365 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8366 ENDIF
8367 140 CONTINUE
8368 VINT(319)=WTGAGA
8369 MINT(143)=LOOP
8370
8371C...Update pTmin and cross section information.
8372 IF(MSTP(82).LE.1) THEN
8373 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8374 ELSE
8375 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8376 ENDIF
8377 VINT(149)=4D0*PTMN**2/VINT(2)
8378 VINT(154)=PTMN
8379 CALL PYXTOT
8380
8381C...Reconstruct kinematics of photons inside leptons.
8382 ELSEIF(IGAGA.EQ.4) THEN
8383
8384C...Make place for incoming particles and scattered leptons.
8385 MOVE=3
8386 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8387 MINT(4)=MINT(4)+MOVE
8388 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8389 IF(K(I,1).EQ.21) THEN
8390 DO 150 J=1,5
8391 K(I+MOVE,J)=K(I,J)
8392 P(I+MOVE,J)=P(I,J)
8393 V(I+MOVE,J)=V(I,J)
8394 150 CONTINUE
8395 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8396 & K(I+MOVE,3)=K(I,3)+MOVE
8397 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8398 & K(I+MOVE,4)=K(I,4)+MOVE
8399 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8400 & K(I+MOVE,5)=K(I,5)+MOVE
8401 ENDIF
8402 160 CONTINUE
8403 DO 170 I=MINT(84)+1,N
8404 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8405 & K(I,3)=K(I,3)+MOVE
8406 170 CONTINUE
8407
8408C...Fill in incoming particles.
8409 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8410 DO 180 J=1,5
8411 K(I,J)=0
8412 P(I,J)=0D0
8413 V(I,J)=0D0
8414 180 CONTINUE
8415 190 CONTINUE
8416 DO 200 I=1,2
8417 K(MINT(83)+I,1)=21
8418 IF(MINT(140+I).NE.0) THEN
8419 K(MINT(83)+I,2)=MINT(140+I)
8420 P(MINT(83)+I,5)=VINT(302+I)
8421 ELSE
8422 K(MINT(83)+I,2)=MINT(10+I)
8423 P(MINT(83)+I,5)=VINT(2+I)
8424 ENDIF
8425 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8426 & VINT(302))*(-1D0)**(I+1)
8427 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8428 200 CONTINUE
8429
8430C...New mother-daughter relations in documentation section.
8431 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8432 K(MINT(83)+1,4)=MINT(83)+3
8433 K(MINT(83)+1,5)=MINT(83)+5
8434 K(MINT(83)+2,4)=MINT(83)+4
8435 K(MINT(83)+2,5)=MINT(83)+6
8436 K(MINT(83)+3,3)=MINT(83)+1
8437 K(MINT(83)+5,3)=MINT(83)+1
8438 K(MINT(83)+4,3)=MINT(83)+2
8439 K(MINT(83)+6,3)=MINT(83)+2
8440 ELSEIF(MINT(141).NE.0) THEN
8441 K(MINT(83)+1,4)=MINT(83)+3
8442 K(MINT(83)+1,5)=MINT(83)+4
8443 K(MINT(83)+2,4)=MINT(83)+5
8444 K(MINT(83)+3,3)=MINT(83)+1
8445 K(MINT(83)+4,3)=MINT(83)+1
8446 K(MINT(83)+5,3)=MINT(83)+2
8447 ELSEIF(MINT(142).NE.0) THEN
8448 K(MINT(83)+1,4)=MINT(83)+4
8449 K(MINT(83)+2,4)=MINT(83)+3
8450 K(MINT(83)+2,5)=MINT(83)+5
8451 K(MINT(83)+3,3)=MINT(83)+2
8452 K(MINT(83)+4,3)=MINT(83)+1
8453 K(MINT(83)+5,3)=MINT(83)+2
8454 ENDIF
8455
8456C...Fill scattered lepton(s).
8457 DO 210 I=1,2
8458 IF(MINT(140+I).NE.0) THEN
8459 LSC=MINT(83)+MIN(I+2,MOVE)
8460 K(LSC,1)=21
8461 K(LSC,2)=MINT(140+I)
8462 P(LSC,1)=PT(I)*COS(PHI(I))
8463 P(LSC,2)=PT(I)*SIN(PHI(I))
8464 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8465 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8466 & (-1D0)**(I-1)
8467 P(LSC,5)=VINT(302+I)
8468 ENDIF
8469 210 CONTINUE
8470
8471C...Find incoming four-vectors to subprocess.
8472 K(N+1,1)=21
8473 IF(MINT(141).NE.0) THEN
8474 DO 220 J=1,4
8475 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8476 220 CONTINUE
8477 ELSE
8478 DO 230 J=1,4
8479 P(N+1,J)=P(MINT(83)+1,J)
8480 230 CONTINUE
8481 ENDIF
8482 K(N+2,1)=21
8483 IF(MINT(142).NE.0) THEN
8484 DO 240 J=1,4
8485 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8486 240 CONTINUE
8487 ELSE
8488 DO 250 J=1,4
8489 P(N+2,J)=P(MINT(83)+2,J)
8490 250 CONTINUE
8491 ENDIF
8492
8493C...Define boost and rotation between hadronic subsystem and
8494C...collision rest frame; boost hadronic subsystem to this frame.
8495 DO 260 J=1,3
8496 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8497 260 CONTINUE
8498 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8499 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8500 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8501 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8502 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8503 & BETA(3))
8504
8505C...Add on scattered leptons to final state.
8506 DO 280 I=1,2
8507 IF(MINT(140+I).NE.0) THEN
8508 LSC=MINT(83)+MIN(I+2,MOVE)
8509 N=N+1
8510 DO 270 J=1,5
8511 K(N,J)=K(LSC,J)
8512 P(N,J)=P(LSC,J)
8513 V(N,J)=V(LSC,J)
8514 270 CONTINUE
8515 K(N,1)=1
8516 K(N,3)=LSC
8517 ENDIF
8518 280 CONTINUE
8519 ENDIF
8520
8521 RETURN
8522 END
8523
8524C*********************************************************************
8525
8526C...PYRAND
8527C...Generates quantities characterizing the high-pT scattering at the
8528C...parton level according to the matrix elements. Chooses incoming,
8529C...reacting partons, their momentum fractions and one of the possible
8530C...subprocesses.
8531
8532 SUBROUTINE PYRAND
8533
8534C...Double precision and integer declarations.
8535 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8536 IMPLICIT INTEGER(I-N)
8537 INTEGER PYK,PYCHGE,PYCOMP
8538C...Parameter statement to help give large particle numbers.
8539 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8540 &KEXCIT=4000000,KDIMEN=5000000)
8541
8542C...User process initialization and event commonblocks.
8543 INTEGER MAXPUP
8544 PARAMETER (MAXPUP=100)
8545 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8546 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8547 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8548 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8549 &LPRUP(MAXPUP)
8550 INTEGER MAXNUP
8551 PARAMETER (MAXNUP=500)
8552 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8553 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8554 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8555 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8556 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8557 SAVE /HEPRUP/,/HEPEUP/
8558
8559C...Commonblocks.
8560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8561 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8562 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8563 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8564 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8565 COMMON/PYINT1/MINT(400),VINT(400)
8566 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8567 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8568 COMMON/PYINT4/MWID(500),WIDS(500,5)
8569 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8570 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8571 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8572 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8573 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
8574C...Local arrays.
8575 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8576
8577C...Parameters and data used in elastic/diffractive treatment.
8578 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8579 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8580
8581C...Initial values, specifically for (first) semihard interaction.
8582 MINT(10)=0
8583 MINT(17)=0
8584 MINT(18)=0
8585 VINT(143)=1D0
8586 VINT(144)=1D0
8587 VINT(157)=0D0
8588 VINT(158)=0D0
8589 MFAIL=0
8590 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8591 ISUB=0
8592 ISTSB=0
8593 LOOP=0
8594 100 LOOP=LOOP+1
8595 MINT(51)=0
8596 MINT(143)=1
8597 VINT(97)=1D0
8598
8599C...Start by assuming incoming photon is entering subprocess.
8600 IF(MINT(11).EQ.22) THEN
8601 MINT(15)=22
8602 VINT(307)=VINT(3)**2
8603 ENDIF
8604 IF(MINT(12).EQ.22) THEN
8605 MINT(16)=22
8606 VINT(308)=VINT(4)**2
8607 ENDIF
8608 MINT(103)=MINT(11)
8609 MINT(104)=MINT(12)
8610
8611C...Choice of process type - first event of pileup.
8612 INMULT=0
8613 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8614 ELSEIF(MINT(82).EQ.1) THEN
8615
8616C...For gamma-p or gamma-gamma first pick between alternatives.
8617 IGA=0
8618 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8619 MINT(122)=IGA
8620
8621C...For real gamma + gamma with different nature, flip at random.
8622 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8623 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8624 MINTSV=MINT(41)
8625 MINT(41)=MINT(42)
8626 MINT(42)=MINTSV
8627 MINTSV=MINT(45)
8628 MINT(45)=MINT(46)
8629 MINT(46)=MINTSV
8630 MINTSV=MINT(107)
8631 MINT(107)=MINT(108)
8632 MINT(108)=MINTSV
8633 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8634 ENDIF
8635
8636C...Pick process type, possibly by user process machinery.
8637C...(If the latter, also event will be picked here.)
8638 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8639 CALL UPEVNT
8640 CALL PYUPRE
8641 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8642 CALL UPEVNT
8643 CALL PYUPRE
8644 ISUB=0
8645 110 ISUB=ISUB+1
8646 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8647 & ISUB.LT.500) GOTO 110
8648 ELSE
8649 RSUB=XSEC(0,1)*PYR(0)
8650 DO 120 I=1,500
8651 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8652 ISUB=I
8653 RSUB=RSUB-XSEC(I,1)
8654 IF(RSUB.LE.0D0) GOTO 130
8655 120 CONTINUE
8656 130 IF(ISUB.EQ.95) ISUB=96
8657 IF(ISUB.EQ.96) INMULT=1
8658 IF(ISET(ISUB).EQ.11) THEN
8659 IDPRUP=KFPR(ISUB,2)
8660 CALL UPEVNT
8661 CALL PYUPRE
8662 ENDIF
8663 ENDIF
8664
8665C...Choice of inclusive process type - pileup events.
8666 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8667 RSUB=VINT(131)*PYR(0)
8668 ISUB=96
8669 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8670 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8671 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8672 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8673 & ISUB=91
8674 IF(ISUB.EQ.96) INMULT=1
8675 ENDIF
8676
8677C...Choice of photon energy and flux factor inside lepton.
8678 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8679 CALL PYGAGA(3,WTGAGA)
8680 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8681 CKIN(3)=MAX(VINT(285),VINT(154))
8682 CKIN(1)=2D0*CKIN(3)
8683 ENDIF
8684C...When necessary set direct/resolved photon by hand.
8685 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8686 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8687 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8688 ENDIF
8689
8690C...Restrict direct*resolved processes to pTmin >= Q,
8691C...to avoid doublecounting with DIS.
8692 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8693 IF(MINT(15).EQ.22) THEN
8694 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
8695 ELSE
8696 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
8697 ENDIF
8698 CKIN(1)=2D0*CKIN(3)
8699 ENDIF
8700
8701C...Set up for multiple interactions (may include impact parameter).
8702 IF(INMULT.EQ.1) THEN
8703 IF(MINT(35).LE.1) CALL PYMULT(2)
8704 IF(MINT(35).GE.2) CALL PYMIGN(2)
8705 ENDIF
8706
8707C...Loopback point for minimum bias in photon physics.
8708 LOOP2=0
8709 140 LOOP2=LOOP2+1
8710 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
8711 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
8712 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
8713 &NGEN(97,1)=NGEN(97,1)+MINT(143)
8714 MINT(1)=ISUB
8715 ISTSB=ISET(ISUB)
8716
8717C...Random choice of flavour for some SUSY processes.
8718 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
8719C...~e_L ~nu_e or ~mu_L ~nu_mu.
8720 IF(ISUB.EQ.210) THEN
8721 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
8722 KFPR(ISUB,2)=KFPR(ISUB,1)+1
8723C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
8724 ELSEIF(ISUB.EQ.213) THEN
8725 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
8726 KFPR(ISUB,2)=KFPR(ISUB,1)
8727C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
8728 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
8729 & ISUB.NE.257) THEN
8730 IF(ISUB.GE.258) THEN
8731 RKF=4D0
8732 ELSE
8733 RKF=5D0
8734 ENDIF
8735 IF(MOD(ISUB,2).EQ.0) THEN
8736 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
8737 ELSE
8738 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
8739 ENDIF
8740C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
8741 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
8742 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
8743 KSU1=KSUSY1
8744 KSU2=KSUSY1
8745 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
8746 KSU1=KSUSY2
8747 KSU2=KSUSY2
8748 ELSEIF(PYR(0).LT.0.5D0) THEN
8749 KSU1=KSUSY1
8750 KSU2=KSUSY2
8751 ELSE
8752 KSU1=KSUSY2
8753 KSU2=KSUSY1
8754 ENDIF
8755 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
8756 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
8757C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
8758 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
8759 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
8760 KFPR(ISUB,2)=KFPR(ISUB,1)
8761 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
8762 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
8763 KFPR(ISUB,2)=KFPR(ISUB,1)
8764C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
8765 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
8766 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
8767 KSU1=KSUSY1
8768 KSU2=KSUSY1
8769 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
8770 KSU1=KSUSY2
8771 KSU2=KSUSY2
8772 ELSEIF(PYR(0).LT.0.5D0) THEN
8773 KSU1=KSUSY1
8774 KSU2=KSUSY2
8775 ELSE
8776 KSU1=KSUSY2
8777 KSU2=KSUSY1
8778 ENDIF
8779 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
8780 RKF=5D0
8781 ELSE
8782 RKF=4D0
8783 ENDIF
8784 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
8785 ENDIF
8786 ENDIF
8787
8788C...Find resonances (explicit or implicit in cross-section).
8789 MINT(72)=0
8790 KFR1=0
8791 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
8792 KFR1=KFPR(ISUB,1)
8793 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
8794 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
8795 KFR1=23
8796 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
8797 & ISUB.EQ.177) THEN
8798 KFR1=24
8799 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
8800 KFR1=25
8801 IF(MSTP(46).EQ.5) THEN
8802 KFR1=89
8803 PMAS(89,1)=PARP(45)
8804 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
8805 ENDIF
8806 ELSEIF(ISUB.EQ.194) THEN
8807 KFR1=KTECHN+113
8808 ELSEIF(ISUB.EQ.195) THEN
8809 KFR1=KTECHN+213
8810 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
8811 KFR1=KTECHN+113
8812 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
8813 KFR1=KTECHN+213
8814 ENDIF
8815 CKMX=CKIN(2)
8816 IF(CKMX.LE.0D0) CKMX=VINT(1)
8817 KCR1=PYCOMP(KFR1)
8818 IF(KFR1.NE.0) THEN
8819 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
8820 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
8821 ENDIF
8822 IF(KFR1.NE.0) THEN
8823 TAUR1=PMAS(KCR1,1)**2/VINT(2)
8824 IF(KFR1.EQ.KTECHN+113) THEN
8825 CALL PYTECM(S1,S2)
8826 TAUR1=S1/VINT(2)
8827 ENDIF
8828 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
8829 MINT(72)=1
8830 MINT(73)=KFR1
8831 VINT(73)=TAUR1
8832 VINT(74)=GAMR1
8833 ENDIF
8834 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
8835 $THEN
8836 KFR2=23
8837 IF(ISUB.EQ.194) THEN
8838 KFR2=KTECHN+223
8839 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
8840 KFR2=KTECHN+223
8841 ENDIF
8842 KCR2=PYCOMP(KFR2)
8843 TAUR2=PMAS(KCR2,1)**2/VINT(2)
8844 IF(KFR2.EQ.KTECHN+223) THEN
8845 CALL PYTECM(S1,S2)
8846 TAUR2=S2/VINT(2)
8847 ENDIF
8848 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
8849 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
8850 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
8851 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
8852 MINT(72)=2
8853 MINT(74)=KFR2
8854 VINT(75)=TAUR2
8855 VINT(76)=GAMR2
8856 ELSEIF(KFR2.NE.0) THEN
8857 KFR1=KFR2
8858 TAUR1=TAUR2
8859 GAMR1=GAMR2
8860 MINT(72)=1
8861 MINT(73)=KFR1
8862 VINT(73)=TAUR1
8863 VINT(74)=GAMR1
8864 ENDIF
8865 ENDIF
8866
8867C...Find product masses and minimum pT of process,
8868C...optionally with broadening according to a truncated Breit-Wigner.
8869 VINT(63)=0D0
8870 VINT(64)=0D0
8871 MINT(71)=0
8872 VINT(71)=CKIN(3)
8873 IF(MINT(82).GE.2) VINT(71)=0D0
8874 VINT(80)=1D0
8875 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
8876 NBW=0
8877 DO 160 I=1,2
8878 PMMN(I)=0D0
8879 IF(KFPR(ISUB,I).EQ.0) THEN
8880 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
8881 & PARP(41)) THEN
8882 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
8883 ELSE
8884 NBW=NBW+1
8885C...This prevents SUSY/t particles from becoming too light.
8886 KFLW=KFPR(ISUB,I)
8887 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
8888 KCW=PYCOMP(KFLW)
8889 PMMN(I)=PMAS(KCW,1)
8890 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
8891 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
8892 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
8893 & PMAS(PYCOMP(KFDP(IDC,2)),1)
8894 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
8895 & PMAS(PYCOMP(KFDP(IDC,3)),1)
8896 PMMN(I)=MIN(PMMN(I),PMSUM)
8897 ENDIF
8898 150 CONTINUE
8899 ELSEIF(KFLW.EQ.6) THEN
8900 PMMN(I)=PMAS(24,1)+PMAS(5,1)
8901 ENDIF
8902 ENDIF
8903 160 CONTINUE
8904 IF(NBW.GE.1) THEN
8905 CKIN41=CKIN(41)
8906 CKIN43=CKIN(43)
8907 CKIN(41)=MAX(PMMN(1),CKIN(41))
8908 CKIN(43)=MAX(PMMN(2),CKIN(43))
8909 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
8910 CKIN(41)=CKIN41
8911 CKIN(43)=CKIN43
8912 IF(MINT(51).EQ.1) THEN
8913 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
8914 IF(MFAIL.EQ.1) THEN
8915 MSTI(61)=1
8916 RETURN
8917 ENDIF
8918 GOTO 100
8919 ENDIF
8920 VINT(63)=PQM3**2
8921 VINT(64)=PQM4**2
8922 ENDIF
8923 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
8924 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
8925 ENDIF
8926
8927C...Prepare for additional variable choices in 2 -> 3.
8928 IF(ISTSB.EQ.5) THEN
8929 VINT(201)=0D0
8930 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
8931 VINT(206)=VINT(201)
8932 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
8933 VINT(204)=PMAS(23,1)
8934 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
8935 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
8936 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
8937 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
8938 & VINT(204)=VINT(201)
8939 VINT(209)=VINT(204)
8940 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
8941 ENDIF
8942
8943C...Select incoming VDM particle (rho/omega/phi/J/psi).
8944 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
8945 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
8946 VRN=PYR(0)*SIGT(0,0,5)
8947 IF(MINT(101).LE.1) THEN
8948 I1MN=0
8949 I1MX=0
8950 ELSE
8951 I1MN=1
8952 I1MX=MINT(101)
8953 ENDIF
8954 IF(MINT(102).LE.1) THEN
8955 I2MN=0
8956 I2MX=0
8957 ELSE
8958 I2MN=1
8959 I2MX=MINT(102)
8960 ENDIF
8961 DO 180 I1=I1MN,I1MX
8962 KFV1=110*I1+3
8963 DO 170 I2=I2MN,I2MX
8964 KFV2=110*I2+3
8965 VRN=VRN-SIGT(I1,I2,5)
8966 IF(VRN.LE.0D0) GOTO 190
8967 170 CONTINUE
8968 180 CONTINUE
8969 190 IF(MINT(101).GE.2) MINT(103)=KFV1
8970 IF(MINT(102).GE.2) MINT(104)=KFV2
8971 ENDIF
8972
8973 IF(ISTSB.EQ.0) THEN
8974C...Elastic scattering or single or double diffractive scattering.
8975
8976C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
8977 MINT(103)=MINT(11)
8978 MINT(104)=MINT(12)
8979 PMM(1)=VINT(3)
8980 PMM(2)=VINT(4)
8981 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
8982 JJ=ISUB-90
8983 VRN=PYR(0)*SIGT(0,0,JJ)
8984 IF(MINT(101).LE.1) THEN
8985 I1MN=0
8986 I1MX=0
8987 ELSE
8988 I1MN=1
8989 I1MX=MINT(101)
8990 ENDIF
8991 IF(MINT(102).LE.1) THEN
8992 I2MN=0
8993 I2MX=0
8994 ELSE
8995 I2MN=1
8996 I2MX=MINT(102)
8997 ENDIF
8998 DO 210 I1=I1MN,I1MX
8999 KFV1=110*I1+3
9000 DO 200 I2=I2MN,I2MX
9001 KFV2=110*I2+3
9002 VRN=VRN-SIGT(I1,I2,JJ)
9003 IF(VRN.LE.0D0) GOTO 220
9004 200 CONTINUE
9005 210 CONTINUE
9006 220 IF(MINT(101).GE.2) THEN
9007 MINT(103)=KFV1
9008 PMM(1)=PYMASS(KFV1)
9009 ENDIF
9010 IF(MINT(102).GE.2) THEN
9011 MINT(104)=KFV2
9012 PMM(2)=PYMASS(KFV2)
9013 ENDIF
9014 ENDIF
9015 VINT(67)=PMM(1)
9016 VINT(68)=PMM(2)
9017
9018C...Select mass for GVMD states (rejecting previous assignment).
9019 Q0S=4D0*PARP(15)**2
9020 Q1S=4D0*VINT(154)**2
9021 LOOP3=0
9022 230 LOOP3=LOOP3+1
9023 DO 240 JT=1,2
9024 IF(MINT(106+JT).EQ.3) THEN
9025 PS=VINT(2+JT)**2
9026 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9027 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9028 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9029 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9030 ENDIF
9031 240 CONTINUE
9032 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9033 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9034 & GOTO 230
9035 GOTO 100
9036 ENDIF
9037
9038C...Side/sides of diffractive system.
9039 MINT(17)=0
9040 MINT(18)=0
9041 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9042 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9043
9044C...Find masses of particles and minimal masses of diffractive states.
9045 DO 250 JT=1,2
9046 PDIF(JT)=PMM(JT)
9047 VINT(68+JT)=PDIF(JT)
9048 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9049 250 CONTINUE
9050 SH=VINT(2)
9051 SQM1=PMM(1)**2
9052 SQM2=PMM(2)**2
9053 SQM3=PDIF(1)**2
9054 SQM4=PDIF(2)**2
9055 SMRES1=(PMM(1)+PMRC)**2
9056 SMRES2=(PMM(2)+PMRC)**2
9057
9058C...Find elastic slope and lower limit diffractive slope.
9059 IHA=MAX(2,IABS(MINT(103))/110)
9060 IF(IHA.GE.5) IHA=1
9061 IHB=MAX(2,IABS(MINT(104))/110)
9062 IF(IHB.GE.5) IHB=1
9063 IF(ISUB.EQ.91) THEN
9064 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9065 ELSEIF(ISUB.EQ.92) THEN
9066 BMN=MAX(2D0,2D0*BHAD(IHB))
9067 ELSEIF(ISUB.EQ.93) THEN
9068 BMN=MAX(2D0,2D0*BHAD(IHA))
9069 ELSEIF(ISUB.EQ.94) THEN
9070 BMN=2D0*ALP*4D0
9071 ENDIF
9072
9073C...Determine maximum possible t range and coefficient of generation.
9074 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9075 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9076 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9077 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9078 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9079 & (SQM1*SQM4-SQM2*SQM3)/SH
9080 THL=-0.5D0*(THA+THB)
9081 THU=THC/THL
9082 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9083
9084C...Select diffractive mass/masses according to dm^2/m^2.
9085 LOOP3=0
9086 260 LOOP3=LOOP3+1
9087 DO 270 JT=1,2
9088 IF(MINT(16+JT).EQ.0) THEN
9089 PDIF(2+JT)=PDIF(JT)
9090 ELSE
9091 PMMIN=PDIF(JT)
9092 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9093 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9094 ENDIF
9095 270 CONTINUE
9096 SQM3=PDIF(3)**2
9097 SQM4=PDIF(4)**2
9098
9099C..Additional mass factors, including resonance enhancement.
9100 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9101 IF(LOOP3.LT.100) GOTO 260
9102 GOTO 100
9103 ENDIF
9104 IF(ISUB.EQ.92) THEN
9105 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9106 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9107 ELSEIF(ISUB.EQ.93) THEN
9108 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9109 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9110 ELSEIF(ISUB.EQ.94) THEN
9111 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9112 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9113 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9114 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9115 ENDIF
9116
9117C...Select t according to exp(Bmn*t) and correct to right slope.
9118 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9119 IF(ISUB.GE.92) THEN
9120 IF(ISUB.EQ.92) THEN
9121 BADD=2D0*ALP*LOG(SH/SQM3)
9122 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9123 ELSEIF(ISUB.EQ.93) THEN
9124 BADD=2D0*ALP*LOG(SH/SQM4)
9125 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9126 ELSEIF(ISUB.EQ.94) THEN
9127 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9128 ENDIF
9129 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9130 ENDIF
9131
9132C...Check whether m^2 and t choices are consistent.
9133 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9134 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9135 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9136 IF(THB.LE.1D-8) GOTO 260
9137 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9138 & (SQM1*SQM4-SQM2*SQM3)/SH
9139 THLM=-0.5D0*(THA+THB)
9140 THUM=THC/THLM
9141 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9142
9143C...Information to output.
9144 VINT(21)=1D0
9145 VINT(22)=0D0
9146 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9147 VINT(45)=TH
9148 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9149 VINT(63)=PDIF(3)**2
9150 VINT(64)=PDIF(4)**2
9151 VINT(283)=PMM(1)**2/4D0
9152 VINT(284)=PMM(2)**2/4D0
9153
9154C...Note: in the following, by In is meant the integral over the
9155C...quantity multiplying coefficient cn.
9156C...Choose tau according to h1(tau)/tau, where
9157C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9158C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9159C...I1/I5*c5*1/(tau+tau_R') +
9160C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9161C...I1/I7*c7*tau/(1.-tau), and
9162C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9163 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9164 CALL PYKLIM(1)
9165 IF(MINT(51).NE.0) THEN
9166 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9167 IF(MFAIL.EQ.1) THEN
9168 MSTI(61)=1
9169 RETURN
9170 ENDIF
9171 GOTO 100
9172 ENDIF
9173 RTAU=PYR(0)
9174 MTAU=1
9175 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9176 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9177 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9178 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9179 & MTAU=5
9180 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9181 & COEF(ISUB,5)) MTAU=6
9182 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9183 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9184 CALL PYKMAP(1,MTAU,PYR(0))
9185
9186C...2 -> 3, 4 processes:
9187C...Choose tau' according to h4(tau,tau')/tau', where
9188C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9189C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9190 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9191 CALL PYKLIM(4)
9192 IF(MINT(51).NE.0) THEN
9193 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9194 IF(MFAIL.EQ.1) THEN
9195 MSTI(61)=1
9196 RETURN
9197 ENDIF
9198 GOTO 100
9199 ENDIF
9200 RTAUP=PYR(0)
9201 MTAUP=1
9202 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9203 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9204 CALL PYKMAP(4,MTAUP,PYR(0))
9205 ENDIF
9206
9207C...Choose y* according to h2(y*), where
9208C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9209C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9210C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9211C...and c1 + c2 + c3 + c4 + c5 = 1.
9212 CALL PYKLIM(2)
9213 IF(MINT(51).NE.0) THEN
9214 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9215 IF(MFAIL.EQ.1) THEN
9216 MSTI(61)=1
9217 RETURN
9218 ENDIF
9219 GOTO 100
9220 ENDIF
9221 RYST=PYR(0)
9222 MYST=1
9223 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9224 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9225 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9226 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9227 & COEF(ISUB,11)) MYST=5
9228 CALL PYKMAP(2,MYST,PYR(0))
9229
9230C...2 -> 2 processes:
9231C...Choose cos(theta-hat) (cth) according to h3(cth), where
9232C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9233C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9234C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9235C...and c0 + c1 + c2 + c3 + c4 = 1.
9236 CALL PYKLIM(3)
9237 IF(MINT(51).NE.0) THEN
9238 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9239 IF(MFAIL.EQ.1) THEN
9240 MSTI(61)=1
9241 RETURN
9242 ENDIF
9243 GOTO 100
9244 ENDIF
9245 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9246 RCTH=PYR(0)
9247 MCTH=1
9248 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9249 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9250 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9251 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9252 & COEF(ISUB,16)) MCTH=5
9253 CALL PYKMAP(3,MCTH,PYR(0))
9254 ENDIF
9255
9256C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9257 IF(ISTSB.EQ.5) THEN
9258 CALL PYKMAP(5,0,0D0)
9259 IF(MINT(51).NE.0) THEN
9260 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9261 IF(MFAIL.EQ.1) THEN
9262 MSTI(61)=1
9263 RETURN
9264 ENDIF
9265 GOTO 100
9266 ENDIF
9267 ENDIF
9268
9269C...DIS as f + gamma* -> f process: set dummy values.
9270 ELSEIF(ISTSB.EQ.8) THEN
9271 VINT(21)=0.9D0
9272 VINT(22)=0D0
9273 VINT(23)=0D0
9274 VINT(47)=0D0
9275 VINT(48)=0D0
9276
9277C...Low-pT or multiple interactions (first semihard interaction).
9278 ELSEIF(ISTSB.EQ.9) THEN
9279 IF(MINT(35).LE.1) CALL PYMULT(3)
9280 IF(MINT(35).GE.2) CALL PYMIGN(3)
9281 ISUB=MINT(1)
9282
9283C...Study user-defined process: kinematics plus weight.
9284 ELSEIF(ISTSB.EQ.11) THEN
9285 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9286 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9287 MSTI(51)=0
9288 IF(NUP.LE.0) THEN
9289 MINT(51)=2
9290 MSTI(51)=1
9291 IF(MINT(82).EQ.1) THEN
9292 NGEN(0,1)=NGEN(0,1)-1
9293 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9294 ENDIF
9295 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9296 RETURN
9297 ENDIF
9298
9299C...Extract cross section event weight.
9300 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9301 SIGS=1D-9*XWGTUP
9302 ELSE
9303 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9304 ENDIF
9305 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9306 VINT(97)=SIGN(1D0,XWGTUP)
9307 ELSE
9308 VINT(97)=1D-9*XWGTUP
9309 ENDIF
9310
9311C...Construct 'trivial' kinematical variables needed.
9312 KFL1=IDUP(1)
9313 KFL2=IDUP(2)
9314 VINT(41)=PUP(4,1)/EBMUP(1)
9315 VINT(42)=PUP(4,2)/EBMUP(2)
9316 VINT(21)=VINT(41)*VINT(42)
9317 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9318 VINT(44)=VINT(21)*VINT(2)
9319 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9320 VINT(55)=SCALUP
9321 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9322 VINT(56)=VINT(55)**2
9323 VINT(57)=AQEDUP
9324 VINT(58)=AQCDUP
9325
9326C...Construct other kinematical variables needed (approximately).
9327 VINT(23)=0D0
9328 VINT(26)=VINT(21)
9329 VINT(45)=-0.5D0*VINT(44)
9330 VINT(46)=-0.5D0*VINT(44)
9331 VINT(49)=VINT(43)
9332 VINT(50)=VINT(44)
9333 VINT(51)=VINT(55)
9334 VINT(52)=VINT(56)
9335 VINT(53)=VINT(55)
9336 VINT(54)=VINT(56)
9337 VINT(25)=0D0
9338 VINT(48)=0D0
9339 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9340 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9341 DO 280 IUP=3,NUP
9342 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9343 & '(PYRAND:) unacceptable ISTUP code for particles')
9344 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9345 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9346 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9347 & PUP(2,IUP)**2)
9348 280 CONTINUE
9349 VINT(47)=SQRT(VINT(48))
9350 ENDIF
9351
9352C...Choose azimuthal angle.
9353 VINT(24)=0D0
9354 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9355
9356C...Check against user cuts on kinematics at parton level.
9357 MINT(51)=0
9358 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9359 IF(MINT(51).NE.0) THEN
9360 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9361 IF(MFAIL.EQ.1) THEN
9362 MSTI(61)=1
9363 RETURN
9364 ENDIF
9365 GOTO 100
9366 ENDIF
9367 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9368 MCUT=0
9369 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9370 & CALL PYKCUT(MCUT)
9371 IF(MCUT.NE.0) THEN
9372 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9373 IF(MFAIL.EQ.1) THEN
9374 MSTI(61)=1
9375 RETURN
9376 ENDIF
9377 GOTO 100
9378 ENDIF
9379 ENDIF
9380
9381C...Calculate differential cross-section for different subprocesses.
9382 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9383 SIGSOR=SIGS
9384 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9385
9386C...Multiply cross section by lepton -> photon flux factor.
9387 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9388 SIGS=WTGAGA*SIGS
9389 DO 290 ICHN=1,NCHN
9390 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9391 290 CONTINUE
9392 SIGLPT=WTGAGA*SIGLPT
9393 ENDIF
9394
9395C...Multiply cross-section by user-defined weights.
9396 IF(MSTP(173).EQ.1) THEN
9397 SIGS=PARP(173)*SIGS
9398 DO 300 ICHN=1,NCHN
9399 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9400 300 CONTINUE
9401 SIGLPT=PARP(173)*SIGLPT
9402 ENDIF
9403 WTXS=1D0
9404 SIGSWT=SIGS
9405 VINT(99)=1D0
9406 VINT(100)=1D0
9407 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9408 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9409 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9410 SIGSWT=WTXS*SIGS
9411 VINT(99)=WTXS
9412 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9413 ENDIF
9414
9415C...Calculations for Monte Carlo estimate of all cross-sections.
9416 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9417 IF(MSTP(142).LE.1) THEN
9418 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9419 ELSE
9420 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9421 ENDIF
9422 ELSEIF(MINT(82).EQ.1) THEN
9423 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9424 ENDIF
9425 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9426 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9427
9428C...Multiple interactions: store results of cross-section calculation.
9429 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9430 VINT(153)=SIGSOR
9431 IF(MINT(35).LE.1) CALL PYMULT(4)
9432 IF(MINT(35).GE.2) CALL PYMIGN(4)
9433 ENDIF
9434
9435C...Ratio of actual to maximum cross section.
9436 IF(ISTSB.NE.11) THEN
9437 VIOL=SIGSWT/XSEC(ISUB,1)
9438 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9439 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9440 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9441 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9442 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9443 ELSE
9444 VIOL=1D0
9445 ENDIF
9446
9447C...Check that weight not negative.
9448 IF(MSTP(123).LE.0) THEN
9449 IF(VIOL.LT.-1D-3) THEN
9450 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9451 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9452 & VINT(22),VINT(23),VINT(26)
9453 STOP
9454 ENDIF
9455 ELSE
9456 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9457 VINT(109)=VIOL
9458 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9459 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9460 & VINT(22),VINT(23),VINT(26)
9461 ENDIF
9462 ENDIF
9463
9464C...Weighting using estimate of maximum of differential cross-section.
9465 RATND=1D0
9466 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9467 IF(VIOL.LT.PYR(0)) THEN
9468 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9469 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9470 GOTO 100
9471 ENDIF
9472 ELSEIF(MFAIL.EQ.0) THEN
9473 RATND=SIGLPT/XSEC(95,1)
9474 VIOL=VIOL/RATND
9475 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9476 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9477 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9478 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9479 ISUB=0
9480 GOTO 100
9481 ENDIF
9482 IF(VIOL.LT.PYR(0)) THEN
9483 GOTO 140
9484 ENDIF
9485 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9486 IF(VIOL.LT.PYR(0)) THEN
9487 MSTI(61)=1
9488 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9489 RETURN
9490 ENDIF
9491 ELSE
9492 RATND=SIGLPT/XSEC(95,1)
9493 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9494 MSTI(61)=1
9495 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9496 RETURN
9497 ENDIF
9498 VIOL=VIOL/RATND
9499 IF(VIOL.LT.PYR(0)) THEN
9500 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9501 GOTO 100
9502 ENDIF
9503 ENDIF
9504
9505C...Check for possible violation of estimated maximum of differential
9506C...cross-section used in weighting.
9507 IF(MSTP(123).LE.0) THEN
9508 IF(VIOL.GT.1D0) THEN
9509 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9510 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9511 & VINT(22),VINT(23),VINT(26)
9512 STOP
9513 ENDIF
9514 ELSEIF(MSTP(123).EQ.1) THEN
9515 IF(VIOL.GT.VINT(108)) THEN
9516 VINT(108)=VIOL
9517 IF(VIOL.GT.1.0001D0) THEN
9518 MINT(10)=1
9519 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9520 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9521 & VINT(22),VINT(23),VINT(26)
9522 ENDIF
9523 ENDIF
9524 ELSEIF(VIOL.GT.VINT(108)) THEN
9525 VINT(108)=VIOL
9526 IF(VIOL.GT.1D0) THEN
9527 MINT(10)=1
9528 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9529 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9530 & THEN
9531 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9532 IF(KFPR(ISUB,1).LE.9) THEN
9533 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9534 & XMAXUP(KFPR(ISUB,1))
9535 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9536 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9537 & XMAXUP(KFPR(ISUB,1))
9538 ELSE
9539 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9540 & XMAXUP(KFPR(ISUB,1))
9541 ENDIF
9542 ENDIF
9543 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9544 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9545 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9546 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9547 & XSEC(0,1)=XSEC(0,1)+XDIF
9548 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9549 & VINT(22),VINT(23),VINT(26)
9550 IF(ISUB.LE.9) THEN
9551 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9552 ELSEIF(ISUB.LE.99) THEN
9553 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9554 ELSE
9555 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9556 ENDIF
9557 ENDIF
9558 VINT(108)=1D0
9559 ENDIF
9560 ENDIF
9561
9562C...Multiple interactions: choose impact parameter (if not already done).
9563 IF(MINT(39).EQ.0) VINT(148)=1D0
9564 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9565 &MSTP(82).GE.3) THEN
9566 IF(MINT(35).LE.1) CALL PYMULT(5)
9567 IF(MINT(35).GE.2) CALL PYMIGN(5)
9568 IF(VINT(150).LT.PYR(0)) THEN
9569 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9570 IF(MFAIL.EQ.1) THEN
9571 MSTI(61)=1
9572 RETURN
9573 ENDIF
9574 GOTO 100
9575 ENDIF
9576 ENDIF
9577 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9578 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9579 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9580 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9581 ENDIF
9582 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9583
9584C...Choose flavour of reacting partons (and subprocess).
9585 IF(ISTSB.GE.11) GOTO 320
9586 RSIGS=SIGS*PYR(0)
9587 QT2=VINT(48)
9588 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9589 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9590 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9591 &PYR(0).GT.RQQBAR)) THEN
9592 DO 310 ICHN=1,NCHN
9593 KFL1=ISIG(ICHN,1)
9594 KFL2=ISIG(ICHN,2)
9595 MINT(2)=ISIG(ICHN,3)
9596 RSIGS=RSIGS-SIGH(ICHN)
9597 IF(RSIGS.LE.0D0) GOTO 320
9598 310 CONTINUE
9599
9600C...Multiple interactions: choose qqbar preferentially at small pT.
9601 ELSEIF(ISUB.EQ.96) THEN
9602 MINT(105)=MINT(103)
9603 MINT(109)=MINT(107)
9604 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9605 MINT(105)=MINT(104)
9606 MINT(109)=MINT(108)
9607 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
9608 MINT(1)=11
9609 MINT(2)=1
9610 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
9611
9612C...Low-pT: choose string drawing configuration.
9613 ELSE
9614 KFL1=21
9615 KFL2=21
9616 RSIGS=6D0*PYR(0)
9617 MINT(2)=1
9618 IF(RSIGS.GT.1D0) MINT(2)=2
9619 IF(RSIGS.GT.2D0) MINT(2)=3
9620 ENDIF
9621
9622C...Reassign QCD process. Partons before initial state radiation.
9623 320 IF(MINT(2).GT.10) THEN
9624 MINT(1)=MINT(2)/10
9625 MINT(2)=MOD(MINT(2),10)
9626 ENDIF
9627 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
9628 &NGEN(MINT(1),2)+1
9629 MINT(15)=KFL1
9630 MINT(16)=KFL2
9631 MINT(13)=MINT(15)
9632 MINT(14)=MINT(16)
9633 VINT(141)=VINT(41)
9634 VINT(142)=VINT(42)
9635 VINT(151)=0D0
9636 VINT(152)=0D0
9637
9638C...Calculate x value of photon for parton inside photon inside e.
9639 DO 350 JT=1,2
9640 MINT(18+JT)=0
9641 VINT(154+JT)=0D0
9642 MSPLI=0
9643 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
9644 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
9645 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
9646 IF(MSPLI.EQ.2) THEN
9647 KFLH=MINT(14+JT)
9648 XHRD=VINT(140+JT)
9649 Q2HRD=VINT(54)
9650 MINT(105)=MINT(102+JT)
9651 MINT(109)=MINT(106+JT)
9652 VINT(120)=VINT(2+JT)
9653 IF(MSTP(57).LE.1) THEN
9654 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
9655 ELSE
9656 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
9657 ENDIF
9658 WTMX=4D0*XPQ(KFLH)
9659 IF(MSTP(13).EQ.2) THEN
9660 Q2PMS=Q2HRD/PMAS(11,1)**2
9661 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
9662 ENDIF
9663 330 XE=XHRD**PYR(0)
9664 XG=MIN(1D0-1D-10,XHRD/XE)
9665 IF(MSTP(57).LE.1) THEN
9666 CALL PYPDFU(22,XG,Q2HRD,XPQ)
9667 ELSE
9668 CALL PYPDFL(22,XG,Q2HRD,XPQ)
9669 ENDIF
9670 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
9671 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
9672 IF(WT.LT.PYR(0)*WTMX) GOTO 330
9673 MINT(18+JT)=1
9674 VINT(154+JT)=XE
9675 DO 340 KFLS=-25,25
9676 XSFX(JT,KFLS)=XPQ(KFLS)
9677 340 CONTINUE
9678 ENDIF
9679 350 CONTINUE
9680
9681C...Pick scale where photon is resolved.
9682 Q0S=PARP(15)**2
9683 Q1S=VINT(154)**2
9684 VINT(283)=0D0
9685 IF(MINT(107).EQ.3) THEN
9686 IF(MSTP(66).EQ.1) THEN
9687 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
9688 ELSEIF(MSTP(66).EQ.2) THEN
9689 PS=VINT(3)**2
9690 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
9691 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
9692 Q2INT=SQRT(Q0S*Q2EFF)
9693 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
9694 ELSEIF(MSTP(66).EQ.3) THEN
9695 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
9696 ELSEIF(MSTP(66).GE.4) THEN
9697 PS=0.25D0*VINT(3)**2
9698 VINT(283)=(Q0S+PS)*(Q1S+PS)/
9699 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9700 ENDIF
9701 ENDIF
9702 VINT(284)=0D0
9703 IF(MINT(108).EQ.3) THEN
9704 IF(MSTP(66).EQ.1) THEN
9705 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
9706 ELSEIF(MSTP(66).EQ.2) THEN
9707 PS=VINT(4)**2
9708 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
9709 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
9710 Q2INT=SQRT(Q0S*Q2EFF)
9711 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
9712 ELSEIF(MSTP(66).EQ.3) THEN
9713 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
9714 ELSEIF(MSTP(66).GE.4) THEN
9715 PS=0.25D0*VINT(4)**2
9716 VINT(284)=(Q0S+PS)*(Q1S+PS)/
9717 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9718 ENDIF
9719 ENDIF
9720 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9721
9722C...Format statements for differential cross-section maximum violations.
9723 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
9724 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
9725 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
9726 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
9727 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
9728 &'in event',1X,I7)
9729 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
9730 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
9731 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
9732 &'in event',1X,I7)
9733 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
9734 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
9735 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
9736 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
9737 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
9738 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
9739
9740 RETURN
9741 END
9742
9743C*********************************************************************
9744
9745C...PYSCAT
9746C...Finds outgoing flavours and event type; sets up the kinematics
9747C...and colour flow of the hard scattering
9748
9749 SUBROUTINE PYSCAT
9750
9751C...Double precision and integer declarations
9752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9753 IMPLICIT INTEGER(I-N)
9754 INTEGER PYK,PYCHGE,PYCOMP
9755C...Parameter statement to help give large particle numbers.
9756 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9757 &KEXCIT=4000000,KDIMEN=5000000)
9758C...Parameter statement for maximum size of showers.
9759 PARAMETER (MAXNUR=1000)
9760
9761C...User process event common block.
9762 INTEGER MAXNUP
9763 PARAMETER (MAXNUP=500)
9764 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9765 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9766 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9767 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9768 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9769 SAVE /HEPEUP/
9770
9771C...Commonblocks.
9772 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
9773 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
9774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9775 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9776 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9777 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9778 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9779 COMMON/PYINT1/MINT(400),VINT(400)
9780 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9781 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9782 COMMON/PYINT4/MWID(500),WIDS(500,5)
9783 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9784 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
9785 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
9786 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
9787 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
9788 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
9789 &/PYTCSM/
9790C...Local arrays and saved variables
9791 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
9792 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
9793 SAVE VINTSV
9794
9795C...Read out process
9796 ISUB=MINT(1)
9797 ISUBSV=ISUB
9798
9799C...Restore information for low-pT processes
9800 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
9801 DO 100 J=41,66
9802 100 VINT(J)=VINTSV(J)
9803 ENDIF
9804
9805C...Convert H' or A process into equivalent H one
9806 IHIGG=1
9807 KFHIGG=25
9808 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
9809 &ISUB.LE.190)) THEN
9810 IHIGG=2
9811 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
9812 KFHIGG=33+IHIGG
9813 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
9814 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
9815 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
9816 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
9817 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
9818 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
9819 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
9820 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
9821 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
9822 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
9823 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
9824 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
9825 ENDIF
9826
9827 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
9828
9829C...Convert bottomonium process into equivalent charmonium ones.
9830 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
9831
9832C...Choice of subprocess, number of documentation lines
9833 IDOC=6+ISET(ISUB)
9834 IF(ISUB.EQ.95) IDOC=8
9835 IF(ISET(ISUB).EQ.5) IDOC=9
9836 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
9837 MINT(3)=IDOC-6
9838 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
9839 MINT(4)=IDOC
9840 IPU1=MINT(84)+1
9841 IPU2=MINT(84)+2
9842 IPU3=MINT(84)+3
9843 IPU4=MINT(84)+4
9844 IPU5=MINT(84)+5
9845 IPU6=MINT(84)+6
9846
9847C...Reset K, P and V vectors. Store incoming particles
9848 DO 120 JT=1,MSTP(126)+100
9849 I=MINT(83)+JT
9850 IF(I.GT.MSTU(4)) GOTO 120
9851 DO 110 J=1,5
9852 K(I,J)=0
9853 P(I,J)=0D0
9854 V(I,J)=0D0
9855 110 CONTINUE
9856 120 CONTINUE
9857 DO 140 JT=1,2
9858 I=MINT(83)+JT
9859 K(I,1)=21
9860 K(I,2)=MINT(10+JT)
9861 DO 130 J=1,5
9862 P(I,J)=VINT(285+5*JT+J)
9863 130 CONTINUE
9864 140 CONTINUE
9865 MINT(6)=2
9866 KFRES=0
9867
9868C...Store incoming partons in their CM-frame. Save pdf value.
9869 SH=VINT(44)
9870 SHR=SQRT(SH)
9871 SHP=VINT(26)*VINT(2)
9872 SHPR=SQRT(SHP)
9873 SHUSER=SHR
9874 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
9875 DO 150 JT=1,2
9876 I=MINT(84)+JT
9877 K(I,1)=14
9878 K(I,2)=MINT(14+JT)
9879 K(I,3)=MINT(83)+2+JT
9880 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
9881 P(I,4)=0.5D0*SHUSER
9882 VINT(38+JT)=XSFX(JT,MINT(14+JT))
9883 150 CONTINUE
9884
9885C...Copy incoming partons to documentation lines
9886 DO 170 JT=1,2
9887 I1=MINT(83)+4+JT
9888 I2=MINT(84)+JT
9889 K(I1,1)=21
9890 K(I1,2)=K(I2,2)
9891 K(I1,3)=I1-2
9892 DO 160 J=1,5
9893 P(I1,J)=P(I2,J)
9894 160 CONTINUE
9895 170 CONTINUE
9896
9897C...Choose new quark/lepton flavour for relevant annihilation graphs
9898 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
9899 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
9900 IGLGA=21
9901 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
9902 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
9903 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
9904 DO 190 I=1,MDCY(IGLGA,3)
9905 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
9906 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
9907 IF(RKFL.LE.0D0) GOTO 200
9908 190 CONTINUE
9909 200 CONTINUE
9910 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
9911 IF(KFLF.GE.4) GOTO 180
9912 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
9913 KFLF=4
9914 MINT(2)=MINT(2)-2
9915 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
9916 KFLF=5
9917 MINT(2)=MINT(2)-4
9918 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
9919 & .AND.IABS(KFLF).GE.3) THEN
9920 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
9921 & VINT(44)**2
9922 FACCIB=VINT(46)**2/RTCM(41)**4
9923 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
9924 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
9925 KFLF=5
9926 MINT(2)=1
9927 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
9928 IF(KFLF.EQ.5) GOTO 180
9929 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
9930 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
9931 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
9932 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
9933 ENDIF
9934 ENDIF
9935
9936C...Final state flavours and colour flow: default values
9937 JS=1
9938 MINT(21)=MINT(15)
9939 MINT(22)=MINT(16)
9940 MINT(23)=0
9941 MINT(24)=0
9942 KCC=20
9943 KCS=ISIGN(1,MINT(15))
9944
9945 IF(ISET(ISUB).EQ.11) THEN
9946C...User-defined processes: find products
9947 MINT(3)=0
9948 DO 210 IUP=3,NUP
9949 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
9950 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
9951 MINT(21+IUP)=IDUP(IUP)
9952 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
9953 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
9954 ELSEIF(IDUP(IUP).EQ.0) THEN
9955 ELSE
9956 MINT(3)=MINT(3)+1
9957 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
9958 ENDIF
9959 210 CONTINUE
9960
9961 ELSEIF(ISUB.LE.10) THEN
9962 IF(ISUB.EQ.1) THEN
9963C...f + fbar -> gamma*/Z0
9964 KFRES=23
9965
9966 ELSEIF(ISUB.EQ.2) THEN
9967C...f + fbar' -> W+/-
9968 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
9969 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
9970 KFRES=ISIGN(24,KCH1+KCH2)
9971
9972 ELSEIF(ISUB.EQ.3) THEN
9973C...f + fbar -> h0 (or H0, or A0)
9974 KFRES=KFHIGG
9975
9976 ELSEIF(ISUB.EQ.4) THEN
9977C...gamma + W+/- -> W+/-
9978
9979 ELSEIF(ISUB.EQ.5) THEN
9980C...Z0 + Z0 -> h0
9981 XH=SH/SHP
9982 MINT(21)=MINT(15)
9983 MINT(22)=MINT(16)
9984 PMQ(1)=PYMASS(MINT(21))
9985 PMQ(2)=PYMASS(MINT(22))
9986 220 JT=INT(1.5D0+PYR(0))
9987 ZMIN=2D0*PMQ(JT)/SHPR
9988 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
9989 & (SHPR*(SHPR-PMQ(3-JT)))
9990 ZMAX=MIN(1D0-XH,ZMAX)
9991 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
9992 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
9993 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
9994 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
9995 IF(SQC1.LT.1D-8) GOTO 220
9996 C1=SQRT(SQC1)
9997 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
9998 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
9999 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10000 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10001 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10002 IF(SQC1.LT.1D-8) GOTO 220
10003 C1=SQRT(SQC1)
10004 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10005 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10006 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10007 PHIR=PARU(2)*PYR(0)
10008 CPHI=COS(PHIR)
10009 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10010 & SQRT(1D0-CTHE(2)**2)*CPHI
10011 Z1=2D0-Z(JT)
10012 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10013 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10014 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10015 & PMQ(3-JT)**2/SHP))
10016 ZMIN=2D0*PMQ(3-JT)/SHPR
10017 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10018 ZMAX=MIN(1D0-XH,ZMAX)
10019 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10020 KCC=22
10021 KFRES=25
10022
10023 ELSEIF(ISUB.EQ.6) THEN
10024C...Z0 + W+/- -> W+/-
10025
10026 ELSEIF(ISUB.EQ.7) THEN
10027C...W+ + W- -> Z0
10028
10029 ELSEIF(ISUB.EQ.8) THEN
10030C...W+ + W- -> h0
10031 XH=SH/SHP
10032 230 DO 260 JT=1,2
10033 I=MINT(14+JT)
10034 IA=IABS(I)
10035 IF(IA.LE.10) THEN
10036 RVCKM=VINT(180+I)*PYR(0)
10037 DO 240 J=1,MSTP(1)
10038 IB=2*J-1+MOD(IA,2)
10039 IPM=(5-ISIGN(1,I))/2
10040 IDC=J+MDCY(IA,2)+2
10041 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10042 MINT(20+JT)=ISIGN(IB,I)
10043 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10044 IF(RVCKM.LE.0D0) GOTO 250
10045 240 CONTINUE
10046 ELSE
10047 IB=2*((IA+1)/2)-1+MOD(IA,2)
10048 MINT(20+JT)=ISIGN(IB,I)
10049 ENDIF
10050 250 PMQ(JT)=PYMASS(MINT(20+JT))
10051 260 CONTINUE
10052 JT=INT(1.5D0+PYR(0))
10053 ZMIN=2D0*PMQ(JT)/SHPR
10054 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10055 & (SHPR*(SHPR-PMQ(3-JT)))
10056 ZMAX=MIN(1D0-XH,ZMAX)
10057 IF(ZMIN.GE.ZMAX) GOTO 230
10058 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10059 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10060 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10061 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10062 IF(SQC1.LT.1D-8) GOTO 230
10063 C1=SQRT(SQC1)
10064 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10065 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10066 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10067 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10068 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10069 IF(SQC1.LT.1D-8) GOTO 230
10070 C1=SQRT(SQC1)
10071 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10072 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10073 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10074 PHIR=PARU(2)*PYR(0)
10075 CPHI=COS(PHIR)
10076 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10077 & SQRT(1D0-CTHE(2)**2)*CPHI
10078 Z1=2D0-Z(JT)
10079 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10080 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10081 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10082 & PMQ(3-JT)**2/SHP))
10083 ZMIN=2D0*PMQ(3-JT)/SHPR
10084 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10085 ZMAX=MIN(1D0-XH,ZMAX)
10086 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10087 KCC=22
10088 KFRES=25
10089
10090 ELSEIF(ISUB.EQ.10) THEN
10091C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10092 IF(MINT(2).EQ.1) THEN
10093 KCC=22
10094 ELSE
10095C...W exchange: need to mix flavours according to CKM matrix
10096 DO 280 JT=1,2
10097 I=MINT(14+JT)
10098 IA=IABS(I)
10099 IF(IA.LE.10) THEN
10100 RVCKM=VINT(180+I)*PYR(0)
10101 DO 270 J=1,MSTP(1)
10102 IB=2*J-1+MOD(IA,2)
10103 IPM=(5-ISIGN(1,I))/2
10104 IDC=J+MDCY(IA,2)+2
10105 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10106 MINT(20+JT)=ISIGN(IB,I)
10107 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10108 IF(RVCKM.LE.0D0) GOTO 280
10109 270 CONTINUE
10110 ELSE
10111 IB=2*((IA+1)/2)-1+MOD(IA,2)
10112 MINT(20+JT)=ISIGN(IB,I)
10113 ENDIF
10114 280 CONTINUE
10115 KCC=22
10116 ENDIF
10117 ENDIF
10118
10119 ELSEIF(ISUB.LE.20) THEN
10120 IF(ISUB.EQ.11) THEN
10121C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10122 KCC=MINT(2)
10123 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10124
10125 ELSEIF(ISUB.EQ.12) THEN
10126C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10127 MINT(21)=ISIGN(KFLF,MINT(15))
10128 MINT(22)=-MINT(21)
10129 KCC=4
10130
10131 ELSEIF(ISUB.EQ.13) THEN
10132C...f + fbar -> g + g; th arbitrary
10133 MINT(21)=21
10134 MINT(22)=21
10135 KCC=MINT(2)+4
10136
10137 ELSEIF(ISUB.EQ.14) THEN
10138C...f + fbar -> g + gamma; th arbitrary
10139 IF(PYR(0).GT.0.5D0) JS=2
10140 MINT(20+JS)=21
10141 MINT(23-JS)=22
10142 KCC=17+JS
10143
10144 ELSEIF(ISUB.EQ.15) THEN
10145C...f + fbar -> g + Z0; th arbitrary
10146 IF(PYR(0).GT.0.5D0) JS=2
10147 MINT(20+JS)=21
10148 MINT(23-JS)=23
10149 KCC=17+JS
10150
10151 ELSEIF(ISUB.EQ.16) THEN
10152C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10153 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10154 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10155 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10156 MINT(20+JS)=21
10157 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10158 KCC=17+JS
10159
10160 ELSEIF(ISUB.EQ.17) THEN
10161C...f + fbar -> g + h0; th arbitrary
10162 IF(PYR(0).GT.0.5D0) JS=2
10163 MINT(20+JS)=21
10164 MINT(23-JS)=25
10165 KCC=17+JS
10166
10167 ELSEIF(ISUB.EQ.18) THEN
10168C...f + fbar -> gamma + gamma; th arbitrary
10169 MINT(21)=22
10170 MINT(22)=22
10171
10172 ELSEIF(ISUB.EQ.19) THEN
10173C...f + fbar -> gamma + Z0; th arbitrary
10174 IF(PYR(0).GT.0.5D0) JS=2
10175 MINT(20+JS)=22
10176 MINT(23-JS)=23
10177
10178 ELSEIF(ISUB.EQ.20) THEN
10179C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10180C...(p(fbar')-p(W+))**2
10181 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10182 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10183 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10184 MINT(20+JS)=22
10185 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10186 ENDIF
10187
10188 ELSEIF(ISUB.LE.30) THEN
10189 IF(ISUB.EQ.21) THEN
10190C...f + fbar -> gamma + h0; th arbitrary
10191 IF(PYR(0).GT.0.5D0) JS=2
10192 MINT(20+JS)=22
10193 MINT(23-JS)=25
10194
10195 ELSEIF(ISUB.EQ.22) THEN
10196C...f + fbar -> Z0 + Z0; th arbitrary
10197 MINT(21)=23
10198 MINT(22)=23
10199
10200 ELSEIF(ISUB.EQ.23) THEN
10201C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10202 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10203 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10204 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10205 MINT(20+JS)=23
10206 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10207
10208 ELSEIF(ISUB.EQ.24) THEN
10209C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10210 IF(PYR(0).GT.0.5D0) JS=2
10211 MINT(20+JS)=23
10212 MINT(23-JS)=KFHIGG
10213
10214 ELSEIF(ISUB.EQ.25) THEN
10215C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10216 MINT(21)=-ISIGN(24,MINT(15))
10217 MINT(22)=-MINT(21)
10218
10219 ELSEIF(ISUB.EQ.26) THEN
10220C...f + fbar' -> W+/- + h0 (or H0, or A0);
10221C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10222 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10223 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10224 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10225 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10226 MINT(23-JS)=KFHIGG
10227
10228 ELSEIF(ISUB.EQ.27) THEN
10229C...f + fbar -> h0 + h0
10230
10231 ELSEIF(ISUB.EQ.28) THEN
10232C...f + g -> f + g; th = (p(f)-p(f))**2
10233 IF(MINT(15).EQ.21) JS=2
10234 KCC=MINT(2)+6
10235 IF(MINT(15).EQ.21) KCC=KCC+2
10236 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10237 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10238
10239 ELSEIF(ISUB.EQ.29) THEN
10240C...f + g -> f + gamma; th = (p(f)-p(f))**2
10241 IF(MINT(15).EQ.21) JS=2
10242 MINT(23-JS)=22
10243 KCC=15+JS
10244 KCS=ISIGN(1,MINT(14+JS))
10245
10246 ELSEIF(ISUB.EQ.30) THEN
10247C...f + g -> f + Z0; th = (p(f)-p(f))**2
10248 IF(MINT(15).EQ.21) JS=2
10249 MINT(23-JS)=23
10250 KCC=15+JS
10251 KCS=ISIGN(1,MINT(14+JS))
10252 ENDIF
10253
10254 ELSEIF(ISUB.LE.40) THEN
10255 IF(ISUB.EQ.31) THEN
10256C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10257 IF(MINT(15).EQ.21) JS=2
10258 I=MINT(14+JS)
10259 IA=IABS(I)
10260 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10261 RVCKM=VINT(180+I)*PYR(0)
10262 DO 290 J=1,MSTP(1)
10263 IB=2*J-1+MOD(IA,2)
10264 IPM=(5-ISIGN(1,I))/2
10265 IDC=J+MDCY(IA,2)+2
10266 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10267 MINT(20+JS)=ISIGN(IB,I)
10268 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10269 IF(RVCKM.LE.0D0) GOTO 300
10270 290 CONTINUE
10271 300 KCC=15+JS
10272 KCS=ISIGN(1,MINT(14+JS))
10273
10274 ELSEIF(ISUB.EQ.32) THEN
10275C...f + g -> f + h0; th = (p(f)-p(f))**2
10276 IF(MINT(15).EQ.21) JS=2
10277 MINT(23-JS)=25
10278 KCC=15+JS
10279 KCS=ISIGN(1,MINT(14+JS))
10280
10281 ELSEIF(ISUB.EQ.33) THEN
10282C...f + gamma -> f + g; th=(p(f)-p(f))**2
10283 IF(MINT(15).EQ.22) JS=2
10284 MINT(23-JS)=21
10285 KCC=24+JS
10286 KCS=ISIGN(1,MINT(14+JS))
10287
10288 ELSEIF(ISUB.EQ.34) THEN
10289C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10290 IF(MINT(15).EQ.22) JS=2
10291 KCC=22
10292 KCS=ISIGN(1,MINT(14+JS))
10293
10294 ELSEIF(ISUB.EQ.35) THEN
10295C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10296 IF(MINT(15).EQ.22) JS=2
10297 MINT(23-JS)=23
10298 KCC=22
10299
10300 ELSEIF(ISUB.EQ.36) THEN
10301C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10302 IF(MINT(15).EQ.22) JS=2
10303 I=MINT(14+JS)
10304 IA=IABS(I)
10305 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10306 IF(IA.LE.10) THEN
10307 RVCKM=VINT(180+I)*PYR(0)
10308 DO 310 J=1,MSTP(1)
10309 IB=2*J-1+MOD(IA,2)
10310 IPM=(5-ISIGN(1,I))/2
10311 IDC=J+MDCY(IA,2)+2
10312 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10313 MINT(20+JS)=ISIGN(IB,I)
10314 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10315 IF(RVCKM.LE.0D0) GOTO 320
10316 310 CONTINUE
10317 ELSE
10318 IB=2*((IA+1)/2)-1+MOD(IA,2)
10319 MINT(20+JS)=ISIGN(IB,I)
10320 ENDIF
10321 320 KCC=22
10322
10323 ELSEIF(ISUB.EQ.37) THEN
10324C...f + gamma -> f + h0
10325
10326 ELSEIF(ISUB.EQ.38) THEN
10327C...f + Z0 -> f + g
10328
10329 ELSEIF(ISUB.EQ.39) THEN
10330C...f + Z0 -> f + gamma
10331
10332 ELSEIF(ISUB.EQ.40) THEN
10333C...f + Z0 -> f + Z0
10334 ENDIF
10335
10336 ELSEIF(ISUB.LE.50) THEN
10337 IF(ISUB.EQ.41) THEN
10338C...f + Z0 -> f' + W+/-
10339
10340 ELSEIF(ISUB.EQ.42) THEN
10341C...f + Z0 -> f + h0
10342
10343 ELSEIF(ISUB.EQ.43) THEN
10344C...f + W+/- -> f' + g
10345
10346 ELSEIF(ISUB.EQ.44) THEN
10347C...f + W+/- -> f' + gamma
10348
10349 ELSEIF(ISUB.EQ.45) THEN
10350C...f + W+/- -> f' + Z0
10351
10352 ELSEIF(ISUB.EQ.46) THEN
10353C...f + W+/- -> f' + W+/-
10354
10355 ELSEIF(ISUB.EQ.47) THEN
10356C...f + W+/- -> f' + h0
10357
10358 ELSEIF(ISUB.EQ.48) THEN
10359C...f + h0 -> f + g
10360
10361 ELSEIF(ISUB.EQ.49) THEN
10362C...f + h0 -> f + gamma
10363
10364 ELSEIF(ISUB.EQ.50) THEN
10365C...f + h0 -> f + Z0
10366 ENDIF
10367
10368 ELSEIF(ISUB.LE.60) THEN
10369 IF(ISUB.EQ.51) THEN
10370C...f + h0 -> f' + W+/-
10371
10372 ELSEIF(ISUB.EQ.52) THEN
10373C...f + h0 -> f + h0
10374
10375 ELSEIF(ISUB.EQ.53) THEN
10376C...g + g -> f + fbar; th arbitrary
10377 KCS=(-1)**INT(1.5D0+PYR(0))
10378 MINT(21)=ISIGN(KFLF,KCS)
10379 MINT(22)=-MINT(21)
10380 KCC=MINT(2)+10
10381
10382 ELSEIF(ISUB.EQ.54) THEN
10383C...g + gamma -> f + fbar; th arbitrary
10384 KCS=(-1)**INT(1.5D0+PYR(0))
10385 MINT(21)=ISIGN(KFLF,KCS)
10386 MINT(22)=-MINT(21)
10387 KCC=27
10388 IF(MINT(16).EQ.21) KCC=28
10389
10390 ELSEIF(ISUB.EQ.55) THEN
10391C...g + Z0 -> f + fbar
10392
10393 ELSEIF(ISUB.EQ.56) THEN
10394C...g + W+/- -> f + fbar'
10395
10396 ELSEIF(ISUB.EQ.57) THEN
10397C...g + h0 -> f + fbar
10398
10399 ELSEIF(ISUB.EQ.58) THEN
10400C...gamma + gamma -> f + fbar; th arbitrary
10401 KCS=(-1)**INT(1.5D0+PYR(0))
10402 MINT(21)=ISIGN(KFLF,KCS)
10403 MINT(22)=-MINT(21)
10404 KCC=21
10405
10406 ELSEIF(ISUB.EQ.59) THEN
10407C...gamma + Z0 -> f + fbar
10408
10409 ELSEIF(ISUB.EQ.60) THEN
10410C...gamma + W+/- -> f + fbar'
10411 ENDIF
10412
10413 ELSEIF(ISUB.LE.70) THEN
10414 IF(ISUB.EQ.61) THEN
10415C...gamma + h0 -> f + fbar
10416
10417 ELSEIF(ISUB.EQ.62) THEN
10418C...Z0 + Z0 -> f + fbar
10419
10420 ELSEIF(ISUB.EQ.63) THEN
10421C...Z0 + W+/- -> f + fbar'
10422
10423 ELSEIF(ISUB.EQ.64) THEN
10424C...Z0 + h0 -> f + fbar
10425
10426 ELSEIF(ISUB.EQ.65) THEN
10427C...W+ + W- -> f + fbar
10428
10429 ELSEIF(ISUB.EQ.66) THEN
10430C...W+/- + h0 -> f + fbar'
10431
10432 ELSEIF(ISUB.EQ.67) THEN
10433C...h0 + h0 -> f + fbar
10434
10435 ELSEIF(ISUB.EQ.68) THEN
10436C...g + g -> g + g; th arbitrary
10437 KCC=MINT(2)+12
10438 KCS=(-1)**INT(1.5D0+PYR(0))
10439
10440 ELSEIF(ISUB.EQ.69) THEN
10441C...gamma + gamma -> W+ + W-; th arbitrary
10442 MINT(21)=24
10443 MINT(22)=-24
10444 KCC=21
10445
10446 ELSEIF(ISUB.EQ.70) THEN
10447C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10448 IF(MINT(15).EQ.22) MINT(21)=23
10449 IF(MINT(16).EQ.22) MINT(22)=23
10450 KCC=21
10451 ENDIF
10452
10453 ELSEIF(ISUB.LE.80) THEN
10454 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10455C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10456 XH=SH/SHP
10457 MINT(21)=MINT(15)
10458 MINT(22)=MINT(16)
10459 PMQ(1)=PYMASS(MINT(21))
10460 PMQ(2)=PYMASS(MINT(22))
10461 330 JT=INT(1.5D0+PYR(0))
10462 ZMIN=2D0*PMQ(JT)/SHPR
10463 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10464 & (SHPR*(SHPR-PMQ(3-JT)))
10465 ZMAX=MIN(1D0-XH,ZMAX)
10466 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10467 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10468 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10469 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10470 IF(SQC1.LT.1D-8) GOTO 330
10471 C1=SQRT(SQC1)
10472 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10473 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10474 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10475 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10476 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10477 IF(SQC1.LT.1D-8) GOTO 330
10478 C1=SQRT(SQC1)
10479 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10480 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10481 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10482 PHIR=PARU(2)*PYR(0)
10483 CPHI=COS(PHIR)
10484 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10485 & SQRT(1D0-CTHE(2)**2)*CPHI
10486 Z1=2D0-Z(JT)
10487 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10488 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10489 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10490 & PMQ(3-JT)**2/SHP))
10491 ZMIN=2D0*PMQ(3-JT)/SHPR
10492 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10493 ZMAX=MIN(1D0-XH,ZMAX)
10494 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10495 KCC=22
10496
10497 ELSEIF(ISUB.EQ.73) THEN
10498C...Z0 + W+/- -> Z0 + W+/-
10499 JS=MINT(2)
10500 XH=SH/SHP
10501 340 JT=3-MINT(2)
10502 I=MINT(14+JT)
10503 IA=IABS(I)
10504 IF(IA.LE.10) THEN
10505 RVCKM=VINT(180+I)*PYR(0)
10506 DO 350 J=1,MSTP(1)
10507 IB=2*J-1+MOD(IA,2)
10508 IPM=(5-ISIGN(1,I))/2
10509 IDC=J+MDCY(IA,2)+2
10510 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10511 MINT(20+JT)=ISIGN(IB,I)
10512 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10513 IF(RVCKM.LE.0D0) GOTO 360
10514 350 CONTINUE
10515 ELSE
10516 IB=2*((IA+1)/2)-1+MOD(IA,2)
10517 MINT(20+JT)=ISIGN(IB,I)
10518 ENDIF
10519 360 PMQ(JT)=PYMASS(MINT(20+JT))
10520 MINT(23-JT)=MINT(17-JT)
10521 PMQ(3-JT)=PYMASS(MINT(23-JT))
10522 JT=INT(1.5D0+PYR(0))
10523 ZMIN=2D0*PMQ(JT)/SHPR
10524 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10525 & (SHPR*(SHPR-PMQ(3-JT)))
10526 ZMAX=MIN(1D0-XH,ZMAX)
10527 IF(ZMIN.GE.ZMAX) GOTO 340
10528 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10529 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10530 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10531 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10532 IF(SQC1.LT.1D-8) GOTO 340
10533 C1=SQRT(SQC1)
10534 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10535 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10536 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10537 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10538 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10539 IF(SQC1.LT.1D-8) GOTO 340
10540 C1=SQRT(SQC1)
10541 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10542 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10543 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10544 PHIR=PARU(2)*PYR(0)
10545 CPHI=COS(PHIR)
10546 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10547 & SQRT(1D0-CTHE(2)**2)*CPHI
10548 Z1=2D0-Z(JT)
10549 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10550 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10551 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10552 & PMQ(3-JT)**2/SHP))
10553 ZMIN=2D0*PMQ(3-JT)/SHPR
10554 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10555 ZMAX=MIN(1D0-XH,ZMAX)
10556 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10557 KCC=22
10558
10559 ELSEIF(ISUB.EQ.74) THEN
10560C...Z0 + h0 -> Z0 + h0
10561
10562 ELSEIF(ISUB.EQ.75) THEN
10563C...W+ + W- -> gamma + gamma
10564
10565 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10566C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10567 XH=SH/SHP
10568 370 DO 400 JT=1,2
10569 I=MINT(14+JT)
10570 IA=IABS(I)
10571 IF(IA.LE.10) THEN
10572 RVCKM=VINT(180+I)*PYR(0)
10573 DO 380 J=1,MSTP(1)
10574 IB=2*J-1+MOD(IA,2)
10575 IPM=(5-ISIGN(1,I))/2
10576 IDC=J+MDCY(IA,2)+2
10577 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10578 MINT(20+JT)=ISIGN(IB,I)
10579 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10580 IF(RVCKM.LE.0D0) GOTO 390
10581 380 CONTINUE
10582 ELSE
10583 IB=2*((IA+1)/2)-1+MOD(IA,2)
10584 MINT(20+JT)=ISIGN(IB,I)
10585 ENDIF
10586 390 PMQ(JT)=PYMASS(MINT(20+JT))
10587 400 CONTINUE
10588 JT=INT(1.5D0+PYR(0))
10589 ZMIN=2D0*PMQ(JT)/SHPR
10590 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10591 & (SHPR*(SHPR-PMQ(3-JT)))
10592 ZMAX=MIN(1D0-XH,ZMAX)
10593 IF(ZMIN.GE.ZMAX) GOTO 370
10594 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10595 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10596 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10597 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10598 IF(SQC1.LT.1D-8) GOTO 370
10599 C1=SQRT(SQC1)
10600 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10601 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10602 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10603 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10604 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10605 IF(SQC1.LT.1D-8) GOTO 370
10606 C1=SQRT(SQC1)
10607 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10608 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10609 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10610 PHIR=PARU(2)*PYR(0)
10611 CPHI=COS(PHIR)
10612 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10613 & SQRT(1D0-CTHE(2)**2)*CPHI
10614 Z1=2D0-Z(JT)
10615 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10616 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10617 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10618 & PMQ(3-JT)**2/SHP))
10619 ZMIN=2D0*PMQ(3-JT)/SHPR
10620 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10621 ZMAX=MIN(1D0-XH,ZMAX)
10622 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
10623 KCC=22
10624
10625 ELSEIF(ISUB.EQ.78) THEN
10626C...W+/- + h0 -> W+/- + h0
10627
10628 ELSEIF(ISUB.EQ.79) THEN
10629C...h0 + h0 -> h0 + h0
10630
10631 ELSEIF(ISUB.EQ.80) THEN
10632C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
10633 IF(MINT(15).EQ.22) JS=2
10634 I=MINT(14+JS)
10635 IA=IABS(I)
10636 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
10637 IB=3-IA
10638 MINT(20+JS)=ISIGN(IB,I)
10639 KCC=22
10640 ENDIF
10641
10642 ELSEIF(ISUB.LE.90) THEN
10643 IF(ISUB.EQ.81) THEN
10644C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
10645 MINT(21)=ISIGN(MINT(55),MINT(15))
10646 MINT(22)=-MINT(21)
10647 KCC=4
10648
10649 ELSEIF(ISUB.EQ.82) THEN
10650C...g + g -> Q + Qbar; th arbitrary
10651 KCS=(-1)**INT(1.5D0+PYR(0))
10652 MINT(21)=ISIGN(MINT(55),KCS)
10653 MINT(22)=-MINT(21)
10654 KCC=MINT(2)+10
10655
10656 ELSEIF(ISUB.EQ.83) THEN
10657C...f + q -> f' + Q; th = (p(f) - p(f'))**2
10658 KFOLD=MINT(16)
10659 IF(MINT(2).EQ.2) KFOLD=MINT(15)
10660 KFAOLD=IABS(KFOLD)
10661 IF(KFAOLD.GT.10) THEN
10662 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
10663 ELSE
10664 RCKM=VINT(180+KFOLD)*PYR(0)
10665 IPM=(5-ISIGN(1,KFOLD))/2
10666 KFANEW=-MOD(KFAOLD+1,2)
10667 410 KFANEW=KFANEW+2
10668 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
10669 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
10670 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
10671 & VCKM(KFAOLD/2,(KFANEW+1)/2)
10672 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
10673 & VCKM(KFANEW/2,(KFAOLD+1)/2)
10674 ENDIF
10675 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
10676 ENDIF
10677 IF(MINT(2).EQ.1) THEN
10678 MINT(21)=ISIGN(MINT(55),MINT(15))
10679 MINT(22)=ISIGN(KFANEW,MINT(16))
10680 ELSE
10681 MINT(21)=ISIGN(KFANEW,MINT(15))
10682 MINT(22)=ISIGN(MINT(55),MINT(16))
10683 JS=2
10684 ENDIF
10685 KCC=22
10686
10687 ELSEIF(ISUB.EQ.84) THEN
10688C...g + gamma -> Q + Qbar; th arbitary
10689 KCS=(-1)**INT(1.5D0+PYR(0))
10690 MINT(21)=ISIGN(MINT(55),KCS)
10691 MINT(22)=-MINT(21)
10692 KCC=27
10693 IF(MINT(16).EQ.21) KCC=28
10694
10695 ELSEIF(ISUB.EQ.85) THEN
10696C...gamma + gamma -> F + Fbar; th arbitary
10697 KCS=(-1)**INT(1.5D0+PYR(0))
10698 MINT(21)=ISIGN(MINT(56),KCS)
10699 MINT(22)=-MINT(21)
10700 KCC=21
10701
10702 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
10703C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
10704 MINT(21)=KFPR(ISUB,1)
10705 MINT(22)=KFPR(ISUB,2)
10706 KCC=24
10707 KCS=(-1)**INT(1.5D0+PYR(0))
10708 ENDIF
10709
10710 ELSEIF(ISUB.LE.100) THEN
10711 IF(ISUB.EQ.95) THEN
10712C...Low-pT ( = energyless g + g -> g + g)
10713 KCC=MINT(2)+12
10714 KCS=(-1)**INT(1.5D0+PYR(0))
10715
10716 ELSEIF(ISUB.EQ.96) THEN
10717C...Multiple interactions (should be reassigned to QCD process)
10718 ENDIF
10719
10720 ELSEIF(ISUB.LE.110) THEN
10721 IF(ISUB.EQ.101) THEN
10722C...g + g -> gamma*/Z0
10723 KCC=21
10724 KFRES=22
10725
10726 ELSEIF(ISUB.EQ.102) THEN
10727C...g + g -> h0 (or H0, or A0)
10728 KCC=21
10729 KFRES=KFHIGG
10730
10731 ELSEIF(ISUB.EQ.103) THEN
10732C...gamma + gamma -> h0 (or H0, or A0)
10733 KCC=21
10734 KFRES=KFHIGG
10735
10736 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
10737C...g + g -> chi_0c or chi_2c.
10738 KCC=21
10739 KFRES=KFPR(ISUB,1)
10740
10741 ELSEIF(ISUB.EQ.106) THEN
10742C...g + g -> J/Psi + gamma
10743 MINT(21)=KFPR(ISUB,1)
10744 MINT(22)=KFPR(ISUB,2)
10745 KCC=21
10746
10747 ELSEIF(ISUB.EQ.107) THEN
10748C...g + gamma -> J/Psi + g
10749 MINT(21)=KFPR(ISUB,1)
10750 MINT(22)=KFPR(ISUB,2)
10751 KCC=22
10752 IF(MINT(16).EQ.22) KCC=33
10753
10754 ELSEIF(ISUB.EQ.108) THEN
10755C...gamma + gamma -> J/Psi + gamma
10756 MINT(21)=KFPR(ISUB,1)
10757 MINT(22)=KFPR(ISUB,2)
10758
10759 ELSEIF(ISUB.EQ.110) THEN
10760C...f + fbar -> gamma + h0; th arbitrary
10761 IF(PYR(0).GT.0.5D0) JS=2
10762 MINT(20+JS)=22
10763 MINT(23-JS)=KFHIGG
10764 ENDIF
10765
10766 ELSEIF(ISUB.LE.120) THEN
10767 IF(ISUB.EQ.111) THEN
10768C...f + fbar -> g + h0; th arbitrary
10769 IF(PYR(0).GT.0.5D0) JS=2
10770 MINT(20+JS)=21
10771 MINT(23-JS)=KFHIGG
10772 KCC=17+JS
10773
10774 ELSEIF(ISUB.EQ.112) THEN
10775C...f + g -> f + h0; th = (p(f) - p(f))**2
10776 IF(MINT(15).EQ.21) JS=2
10777 MINT(23-JS)=KFHIGG
10778 KCC=15+JS
10779 KCS=ISIGN(1,MINT(14+JS))
10780
10781 ELSEIF(ISUB.EQ.113) THEN
10782C...g + g -> g + h0; th arbitrary
10783 IF(PYR(0).GT.0.5D0) JS=2
10784 MINT(23-JS)=KFHIGG
10785 KCC=22+JS
10786 KCS=(-1)**INT(1.5D0+PYR(0))
10787
10788 ELSEIF(ISUB.EQ.114) THEN
10789C...g + g -> gamma + gamma; th arbitrary
10790 IF(PYR(0).GT.0.5D0) JS=2
10791 MINT(21)=22
10792 MINT(22)=22
10793 KCC=21
10794
10795 ELSEIF(ISUB.EQ.115) THEN
10796C...g + g -> g + gamma; th arbitrary
10797 IF(PYR(0).GT.0.5D0) JS=2
10798 MINT(23-JS)=22
10799 KCC=22+JS
10800 KCS=(-1)**INT(1.5D0+PYR(0))
10801
10802 ELSEIF(ISUB.EQ.116) THEN
10803C...g + g -> gamma + Z0
10804
10805 ELSEIF(ISUB.EQ.117) THEN
10806C...g + g -> Z0 + Z0
10807
10808 ELSEIF(ISUB.EQ.118) THEN
10809C...g + g -> W+ + W-
10810 ENDIF
10811
10812 ELSEIF(ISUB.LE.140) THEN
10813 IF(ISUB.EQ.121) THEN
10814C...g + g -> Q + Qbar + h0
10815 KCS=(-1)**INT(1.5D0+PYR(0))
10816 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
10817 MINT(22)=-MINT(21)
10818 KCC=11+INT(0.5D0+PYR(0))
10819 KFRES=KFHIGG
10820
10821 ELSEIF(ISUB.EQ.122) THEN
10822C...q + qbar -> Q + Qbar + h0
10823 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
10824 MINT(22)=-MINT(21)
10825 KCC=4
10826 KFRES=KFHIGG
10827
10828 ELSEIF(ISUB.EQ.123) THEN
10829C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
10830C...inner process)
10831 KCC=22
10832 KFRES=KFHIGG
10833
10834 ELSEIF(ISUB.EQ.124) THEN
10835C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
10836C...inner process)
10837 DO 430 JT=1,2
10838 I=MINT(14+JT)
10839 IA=IABS(I)
10840 IF(IA.LE.10) THEN
10841 RVCKM=VINT(180+I)*PYR(0)
10842 DO 420 J=1,MSTP(1)
10843 IB=2*J-1+MOD(IA,2)
10844 IPM=(5-ISIGN(1,I))/2
10845 IDC=J+MDCY(IA,2)+2
10846 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
10847 MINT(20+JT)=ISIGN(IB,I)
10848 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10849 IF(RVCKM.LE.0D0) GOTO 430
10850 420 CONTINUE
10851 ELSE
10852 IB=2*((IA+1)/2)-1+MOD(IA,2)
10853 MINT(20+JT)=ISIGN(IB,I)
10854 ENDIF
10855 430 CONTINUE
10856 KCC=22
10857 KFRES=KFHIGG
10858
10859 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
10860C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
10861 IF(MINT(15).EQ.22) JS=2
10862 MINT(23-JS)=21
10863 KCC=24+JS
10864 KCS=ISIGN(1,MINT(14+JS))
10865
10866 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
10867C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
10868 IF(MINT(15).EQ.22) JS=2
10869 KCC=22
10870 KCS=ISIGN(1,MINT(14+JS))
10871
10872 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10873C...g + gamma*_(T,L) -> f + fbar; th arbitrary
10874 KCS=(-1)**INT(1.5D0+PYR(0))
10875 MINT(21)=ISIGN(KFLF,KCS)
10876 MINT(22)=-MINT(21)
10877 KCC=27
10878 IF(MINT(16).EQ.21) KCC=28
10879
10880 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
10881C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
10882 KCS=(-1)**INT(1.5D0+PYR(0))
10883 MINT(21)=ISIGN(KFLF,KCS)
10884 MINT(22)=-MINT(21)
10885 KCC=21
10886
10887 ENDIF
10888
10889 ELSEIF(ISUB.LE.160) THEN
10890 IF(ISUB.EQ.141) THEN
10891C...f + fbar -> gamma*/Z0/Z'0
10892 KFRES=32
10893
10894 ELSEIF(ISUB.EQ.142) THEN
10895C...f + fbar' -> W'+/-
10896 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10897 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10898 KFRES=ISIGN(34,KCH1+KCH2)
10899
10900 ELSEIF(ISUB.EQ.143) THEN
10901C...f + fbar' -> H+/-
10902 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10903 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10904 KFRES=ISIGN(37,KCH1+KCH2)
10905
10906 ELSEIF(ISUB.EQ.144) THEN
10907C...f + fbar' -> R
10908 KFRES=ISIGN(41,MINT(15)+MINT(16))
10909
10910 ELSEIF(ISUB.EQ.145) THEN
10911C...q + l -> LQ (leptoquark)
10912 IF(IABS(MINT(16)).LE.8) JS=2
10913 KFRES=ISIGN(42,MINT(14+JS))
10914 KCC=28+JS
10915 KCS=ISIGN(1,MINT(14+JS))
10916
10917 ELSEIF(ISUB.EQ.146) THEN
10918C...e + gamma -> e* (excited lepton)
10919 IF(MINT(15).EQ.22) JS=2
10920 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
10921 KCC=22
10922
10923 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
10924C...q + g -> q* (excited quark)
10925 IF(MINT(15).EQ.21) JS=2
10926 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
10927 KCC=30+JS
10928 KCS=ISIGN(1,MINT(14+JS))
10929
10930 ELSEIF(ISUB.EQ.149) THEN
10931C...g + g -> eta_tc
10932 KFRES=KTECHN+331
10933 KCC=23
10934 KCS=(-1)**INT(1.5D0+PYR(0))
10935 ENDIF
10936
10937 ELSEIF(ISUB.LE.200) THEN
10938 IF(ISUB.EQ.161) THEN
10939C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
10940 IF(MINT(15).EQ.21) JS=2
10941 I=MINT(14+JS)
10942 IA=IABS(I)
10943 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
10944 IB=IA+MOD(IA,2)-MOD(IA+1,2)
10945 MINT(20+JS)=ISIGN(IB,I)
10946 KCC=15+JS
10947 KCS=ISIGN(1,MINT(14+JS))
10948
10949 ELSEIF(ISUB.EQ.162) THEN
10950C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
10951 IF(MINT(15).EQ.21) JS=2
10952 MINT(20+JS)=ISIGN(42,MINT(14+JS))
10953 KFLQL=KFDP(MDCY(42,2),2)
10954 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
10955 KCC=15+JS
10956 KCS=ISIGN(1,MINT(14+JS))
10957
10958 ELSEIF(ISUB.EQ.163) THEN
10959C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
10960 KCS=(-1)**INT(1.5D0+PYR(0))
10961 MINT(21)=ISIGN(42,KCS)
10962 MINT(22)=-MINT(21)
10963 KCC=MINT(2)+10
10964
10965 ELSEIF(ISUB.EQ.164) THEN
10966C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
10967 MINT(21)=ISIGN(42,MINT(15))
10968 MINT(22)=-MINT(21)
10969 KCC=4
10970
10971 ELSEIF(ISUB.EQ.165) THEN
10972C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
10973 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10974 MINT(22)=-MINT(21)
10975
10976 ELSEIF(ISUB.EQ.166) THEN
10977C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
10978 IF(MOD(MINT(15),2).EQ.0) THEN
10979 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
10980 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
10981 ELSE
10982 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
10983 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
10984 ENDIF
10985
10986 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
10987C...q + q' -> q" + q* (excited quark)
10988 KFQSTR=KFPR(ISUB,2)
10989 KFQEXC=MOD(KFQSTR,KEXCIT)
10990 JS=MINT(2)
10991 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
10992 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
10993 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
10994 KCC=22
10995 JS=3-JS
10996
10997 ELSEIF(ISUB.EQ.169) THEN
10998C...q + qbar -> e + e* (excited lepton)
10999 KFQSTR=KFPR(ISUB,2)
11000 KFQEXC=MOD(KFQSTR,KEXCIT)
11001 JS=MINT(2)
11002 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11003 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11004 JS=3-JS
11005
11006 ELSEIF(ISUB.EQ.191) THEN
11007C...f + fbar -> rho_tc0.
11008 KFRES=KTECHN+113
11009
11010 ELSEIF(ISUB.EQ.192) THEN
11011C...f + fbar' -> rho_tc+/-
11012 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11013 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11014 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11015
11016 ELSEIF(ISUB.EQ.193) THEN
11017C...f + fbar -> omega_tc0.
11018 KFRES=KTECHN+223
11019
11020 ELSEIF(ISUB.EQ.194) THEN
11021C...f + fbar -> f' + fbar' via mixture of s-channel
11022C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11023 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11024 MINT(22)=-MINT(21)
11025
11026 ELSEIF(ISUB.EQ.195) THEN
11027C...f + fbar' -> f'' + fbar''' via s-channel
11028C...rho_tc+ th=(p(f)-p(f'))**2
11029C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11030 IF(MOD(MINT(15),2).EQ.0) THEN
11031 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11032 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11033 ELSE
11034 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11035 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11036 ENDIF
11037 ENDIF
11038
11039CMRENNA++
11040 ELSEIF(ISUB.LE.215) THEN
11041 IF(ISUB.EQ.201) THEN
11042C...f + fbar -> ~e_L + ~e_Lbar
11043 MINT(21)=ISIGN(KSUSY1+11,KCS)
11044 MINT(22)=-MINT(21)
11045
11046 ELSEIF(ISUB.EQ.202) THEN
11047C...f + fbar -> ~e_R + ~e_Rbar
11048 MINT(21)=ISIGN(KSUSY2+11,KCS)
11049 MINT(22)=-MINT(21)
11050
11051 ELSEIF(ISUB.EQ.203) THEN
11052C...f + fbar -> ~e_L + ~e_Rbar
11053 IF(MINT(15).LT.0) JS=2
11054 IF(MINT(2).EQ.1) THEN
11055 MINT(20+JS)=KFPR(ISUB,1)
11056 MINT(23-JS)=-KFPR(ISUB,2)
11057 ELSE
11058 MINT(20+JS)=-KFPR(ISUB,1)
11059 MINT(23-JS)=KFPR(ISUB,2)
11060 ENDIF
11061
11062 ELSEIF(ISUB.EQ.204) THEN
11063C...f + fbar -> ~mu_L + ~mu_Lbar
11064 MINT(21)=ISIGN(KSUSY1+13,KCS)
11065 MINT(22)=-MINT(21)
11066
11067 ELSEIF(ISUB.EQ.205) THEN
11068C...f + fbar -> ~mu_R + ~mu_Rbar
11069 MINT(21)=ISIGN(KSUSY2+13,KCS)
11070 MINT(22)=-MINT(21)
11071
11072 ELSEIF(ISUB.EQ.206) THEN
11073C...f + fbar -> ~mu_L + ~mu_Rbar
11074 IF(MINT(15).LT.0) JS=2
11075 IF(MINT(2).EQ.1) THEN
11076 MINT(20+JS)=KFPR(ISUB,1)
11077 MINT(23-JS)=-KFPR(ISUB,2)
11078 ELSE
11079 MINT(20+JS)=-KFPR(ISUB,1)
11080 MINT(23-JS)=KFPR(ISUB,2)
11081 ENDIF
11082
11083 ELSEIF(ISUB.EQ.207) THEN
11084C...f + fbar -> ~tau_1 + ~tau_1bar
11085 MINT(21)=ISIGN(KSUSY1+15,KCS)
11086 MINT(22)=-MINT(21)
11087
11088 ELSEIF(ISUB.EQ.208) THEN
11089C...f + fbar -> ~tau_2 + ~tau_2bar
11090 MINT(21)=ISIGN(KSUSY2+15,KCS)
11091 MINT(22)=-MINT(21)
11092
11093 ELSEIF(ISUB.EQ.209) THEN
11094C...f + fbar -> ~tau_1 + ~tau_2bar
11095 IF(MINT(15).LT.0) JS=2
11096 IF(MINT(2).EQ.1) THEN
11097 MINT(20+JS)=KFPR(ISUB,1)
11098 MINT(23-JS)=-KFPR(ISUB,2)
11099 ELSE
11100 MINT(20+JS)=-KFPR(ISUB,1)
11101 MINT(23-JS)=KFPR(ISUB,2)
11102 ENDIF
11103
11104 ELSEIF(ISUB.EQ.210) THEN
11105C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11106 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11107 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11108 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11109 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11110
11111 ELSEIF(ISUB.EQ.211) THEN
11112C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11113 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11114 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11115 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11116 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11117
11118 ELSEIF(ISUB.EQ.212) THEN
11119C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11120 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11121 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11122 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11123 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11124
11125 ELSEIF(ISUB.EQ.213) THEN
11126C...f + fbar -> ~nul + ~nulbar
11127 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11128 MINT(22)=-MINT(21)
11129
11130 ELSEIF(ISUB.EQ.214) THEN
11131C...f + fbar -> ~nutau + ~nutaubar
11132 MINT(21)=ISIGN(KSUSY1+16,KCS)
11133 MINT(22)=-MINT(21)
11134 ENDIF
11135
11136 ELSEIF(ISUB.LE.225) THEN
11137 IF(ISUB.EQ.216) THEN
11138C...f + fbar -> ~chi01 + ~chi01
11139 MINT(21)=KSUSY1+22
11140 MINT(22)=KSUSY1+22
11141
11142 ELSEIF(ISUB.EQ.217) THEN
11143C...f + fbar -> ~chi02 + ~chi02
11144 MINT(21)=KSUSY1+23
11145 MINT(22)=KSUSY1+23
11146
11147 ELSEIF(ISUB.EQ.218 ) THEN
11148C...f + fbar -> ~chi03 + ~chi03
11149 MINT(21)=KSUSY1+25
11150 MINT(22)=KSUSY1+25
11151
11152 ELSEIF(ISUB.EQ.219 ) THEN
11153C...f + fbar -> ~chi04 + ~chi04
11154 MINT(21)=KSUSY1+35
11155 MINT(22)=KSUSY1+35
11156
11157 ELSEIF(ISUB.EQ.220 ) THEN
11158C...f + fbar -> ~chi01 + ~chi02
11159 IF(MINT(15).LT.0) JS=2
11160C IF(PYR(0).GT.0.5D0) JS=2
11161 MINT(20+JS)=KSUSY1+22
11162 MINT(23-JS)=KSUSY1+23
11163
11164 ELSEIF(ISUB.EQ.221 ) THEN
11165C...f + fbar -> ~chi01 + ~chi03
11166 IF(MINT(15).LT.0) JS=2
11167C IF(PYR(0).GT.0.5D0) JS=2
11168 MINT(20+JS)=KSUSY1+22
11169 MINT(23-JS)=KSUSY1+25
11170
11171 ELSEIF(ISUB.EQ.222) THEN
11172C...f + fbar -> ~chi01 + ~chi04
11173 IF(MINT(15).LT.0) JS=2
11174C IF(PYR(0).GT.0.5D0) JS=2
11175 MINT(20+JS)=KSUSY1+22
11176 MINT(23-JS)=KSUSY1+35
11177
11178 ELSEIF(ISUB.EQ.223) THEN
11179C...f + fbar -> ~chi02 + ~chi03
11180 IF(MINT(15).LT.0) JS=2
11181C IF(PYR(0).GT.0.5D0) JS=2
11182 MINT(20+JS)=KSUSY1+23
11183 MINT(23-JS)=KSUSY1+25
11184
11185 ELSEIF(ISUB.EQ.224) THEN
11186C...f + fbar -> ~chi02 + ~chi04
11187 IF(MINT(15).LT.0) JS=2
11188C IF(PYR(0).GT.0.5D0) JS=2
11189 MINT(20+JS)=KSUSY1+23
11190 MINT(23-JS)=KSUSY1+35
11191
11192 ELSEIF(ISUB.EQ.225) THEN
11193C...f + fbar -> ~chi03 + ~chi04
11194 IF(MINT(15).LT.0) JS=2
11195C IF(PYR(0).GT.0.5D0) JS=2
11196 MINT(20+JS)=KSUSY1+25
11197 MINT(23-JS)=KSUSY1+35
11198 ENDIF
11199
11200 ELSEIF(ISUB.LE.236) THEN
11201 IF(ISUB.EQ.226) THEN
11202C...f + fbar -> ~chi+-1 + ~chi-+1
11203C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11204 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11205 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11206 MINT(22)=-MINT(21)
11207
11208 ELSEIF(ISUB.EQ.227) THEN
11209C...f + fbar -> ~chi+-2 + ~chi-+2
11210 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11211 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11212 MINT(22)=-MINT(21)
11213
11214 ELSEIF(ISUB.EQ.228) THEN
11215C...f + fbar -> ~chi+-1 + ~chi-+2
11216C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11217C...js=1 if pyr<.5, js=2 if pyr>.5
11218C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11219C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11220C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11221C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11222 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11223 KCH2=INT(1-KCH1)/2
11224 IF(MINT(2).EQ.1) THEN
11225 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11226 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11227c IF(KCH2.EQ.0) JS=2
11228 ELSE
11229 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11230 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11231 JS=2
11232c IF(KCH2.EQ.1) JS=2
11233 ENDIF
11234
11235 ELSEIF(ISUB.EQ.229) THEN
11236C...q + qbar' -> ~chi01 + ~chi+-1
11237C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11238 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11239 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11240C...CHECK THIS
11241 IF(MOD(MINT(15),2).EQ.0) JS=2
11242 MINT(20+JS)=KSUSY1+22
11243 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11244
11245 ELSEIF(ISUB.EQ.230) THEN
11246C...q + qbar' -> ~chi02 + ~chi+-1
11247 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11248 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11249 IF(MOD(MINT(15),2).EQ.0) JS=2
11250 MINT(20+JS)=KSUSY1+23
11251 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11252
11253 ELSEIF(ISUB.EQ.231) THEN
11254C...q + qbar' -> ~chi03 + ~chi+-1
11255 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11256 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11257 IF(MOD(MINT(15),2).EQ.0) JS=2
11258 MINT(20+JS)=KSUSY1+25
11259 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11260
11261 ELSEIF(ISUB.EQ.232) THEN
11262C...q + qbar' -> ~chi04 + ~chi+-1
11263 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11264 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11265 IF(MOD(MINT(15),2).EQ.0) JS=2
11266 MINT(20+JS)=KSUSY1+35
11267 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11268
11269 ELSEIF(ISUB.EQ.233) THEN
11270C...q + qbar' -> ~chi01 + ~chi+-2
11271 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11272 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11273 IF(MOD(MINT(15),2).EQ.0) JS=2
11274 MINT(20+JS)=KSUSY1+22
11275 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11276
11277 ELSEIF(ISUB.EQ.234) THEN
11278C...q + qbar' -> ~chi02 + ~chi+-2
11279 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11280 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11281 IF(MOD(MINT(15),2).EQ.0) JS=2
11282 MINT(20+JS)=KSUSY1+23
11283 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11284
11285 ELSEIF(ISUB.EQ.235) THEN
11286C...q + qbar' -> ~chi03 + ~chi+-2
11287 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11288 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11289 IF(MOD(MINT(15),2).EQ.0) JS=2
11290 MINT(20+JS)=KSUSY1+25
11291 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11292
11293 ELSEIF(ISUB.EQ.236) THEN
11294C...q + qbar' -> ~chi04 + ~chi+-2
11295 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11296 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11297 IF(MOD(MINT(15),2).EQ.0) JS=2
11298 MINT(20+JS)=KSUSY1+35
11299 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11300 ENDIF
11301
11302 ELSEIF(ISUB.LE.245) THEN
11303 IF(ISUB.EQ.237) THEN
11304C...q + qbar -> ~chi01 + ~g
11305C...th arbitrary
11306 IF(PYR(0).GT.0.5D0) JS=2
11307 MINT(20+JS)=KSUSY1+21
11308 MINT(23-JS)=KSUSY1+22
11309 KCC=17+JS
11310
11311 ELSEIF(ISUB.EQ.238) THEN
11312C...q + qbar -> ~chi02 + ~g
11313C...th arbitrary
11314 IF(PYR(0).GT.0.5D0) JS=2
11315 MINT(20+JS)=KSUSY1+21
11316 MINT(23-JS)=KSUSY1+23
11317 KCC=17+JS
11318
11319 ELSEIF(ISUB.EQ.239) THEN
11320C...q + qbar -> ~chi03 + ~g
11321C...th arbitrary
11322 IF(PYR(0).GT.0.5D0) JS=2
11323 MINT(20+JS)=KSUSY1+21
11324 MINT(23-JS)=KSUSY1+25
11325 KCC=17+JS
11326
11327 ELSEIF(ISUB.EQ.240) THEN
11328C...q + qbar -> ~chi04 + ~g
11329C...th arbitrary
11330 IF(PYR(0).GT.0.5D0) JS=2
11331 MINT(20+JS)=KSUSY1+21
11332 MINT(23-JS)=KSUSY1+35
11333 KCC=17+JS
11334
11335 ELSEIF(ISUB.EQ.241) THEN
11336C...q + qbar' -> ~chi+-1 + ~g
11337C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11338C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11339C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11340C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11341C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11342 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11343 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11344 JS=1
11345 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11346 MINT(20+JS)=KSUSY1+21
11347 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11348 KCC=17+JS
11349
11350 ELSEIF(ISUB.EQ.242) THEN
11351C...q + qbar' -> ~chi+-2 + ~g
11352C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11353C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11354C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11355C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11356C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11357 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11358 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11359 JS=1
11360 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11361 MINT(20+JS)=KSUSY1+21
11362 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11363 KCC=17+JS
11364
11365 ELSEIF(ISUB.EQ.243) THEN
11366C...q + qbar -> ~g + ~g ; th arbitrary
11367 MINT(21)=KSUSY1+21
11368 MINT(22)=KSUSY1+21
11369 KCC=MINT(2)+4
11370
11371 ELSEIF(ISUB.EQ.244) THEN
11372C...g + g -> ~g + ~g ; th arbitrary
11373 KCC=MINT(2)+12
11374 KCS=(-1)**INT(1.5D0+PYR(0))
11375 MINT(21)=KSUSY1+21
11376 MINT(22)=KSUSY1+21
11377 ENDIF
11378
11379 ELSEIF(ISUB.LE.260) THEN
11380 IF(ISUB.EQ.246) THEN
11381C...qj + g -> ~qj_L + ~chi01
11382 IF(MINT(15).EQ.21) JS=2
11383 I=MINT(14+JS)
11384 IA=IABS(I)
11385 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11386 MINT(23-JS)=KSUSY1+22
11387 KCC=15+JS
11388 KCS=ISIGN(1,MINT(14+JS))
11389
11390 ELSEIF(ISUB.EQ.247) THEN
11391C...qj + g -> ~qj_R + ~chi01
11392 IF(MINT(15).EQ.21) JS=2
11393 I=MINT(14+JS)
11394 IA=IABS(I)
11395 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11396 MINT(23-JS)=KSUSY1+22
11397 KCC=15+JS
11398 KCS=ISIGN(1,MINT(14+JS))
11399
11400 ELSEIF(ISUB.EQ.248) THEN
11401C...qj + g -> ~qj_L + ~chi02
11402 IF(MINT(15).EQ.21) JS=2
11403 I=MINT(14+JS)
11404 IA=IABS(I)
11405 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11406 MINT(23-JS)=KSUSY1+23
11407 KCC=15+JS
11408 KCS=ISIGN(1,MINT(14+JS))
11409
11410 ELSEIF(ISUB.EQ.249) THEN
11411C...qj + g -> ~qj_R + ~chi02
11412 IF(MINT(15).EQ.21) JS=2
11413 I=MINT(14+JS)
11414 IA=IABS(I)
11415 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11416 MINT(23-JS)=KSUSY1+23
11417 KCC=15+JS
11418 KCS=ISIGN(1,MINT(14+JS))
11419
11420 ELSEIF(ISUB.EQ.250) THEN
11421C...qj + g -> ~qj_L + ~chi03
11422 IF(MINT(15).EQ.21) JS=2
11423 I=MINT(14+JS)
11424 IA=IABS(I)
11425 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11426 MINT(23-JS)=KSUSY1+25
11427 KCC=15+JS
11428 KCS=ISIGN(1,MINT(14+JS))
11429
11430 ELSEIF(ISUB.EQ.251) THEN
11431C...qj + g -> ~qj_R + ~chi03
11432 IF(MINT(15).EQ.21) JS=2
11433 I=MINT(14+JS)
11434 IA=IABS(I)
11435 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11436 MINT(23-JS)=KSUSY1+25
11437 KCC=15+JS
11438 KCS=ISIGN(1,MINT(14+JS))
11439
11440 ELSEIF(ISUB.EQ.252) THEN
11441C...qj + g -> ~qj_L + ~chi04
11442 IF(MINT(15).EQ.21) JS=2
11443 I=MINT(14+JS)
11444 IA=IABS(I)
11445 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11446 MINT(23-JS)=KSUSY1+35
11447 KCC=15+JS
11448 KCS=ISIGN(1,MINT(14+JS))
11449
11450 ELSEIF(ISUB.EQ.253) THEN
11451C...qj + g -> ~qj_R + ~chi04
11452 IF(MINT(15).EQ.21) JS=2
11453 I=MINT(14+JS)
11454 IA=IABS(I)
11455 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11456 MINT(23-JS)=KSUSY1+35
11457 KCC=15+JS
11458 KCS=ISIGN(1,MINT(14+JS))
11459
11460 ELSEIF(ISUB.EQ.254) THEN
11461C...qj + g -> ~qk_L + ~chi+-1
11462 IF(MINT(15).EQ.21) JS=2
11463 I=MINT(14+JS)
11464 IA=IABS(I)
11465 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11466 IB=-IA+INT((IA+1)/2)*4-1
11467 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11468 KCC=15+JS
11469 KCS=ISIGN(1,MINT(14+JS))
11470
11471 ELSEIF(ISUB.EQ.255) THEN
11472C...qj + g -> ~qk_L + ~chi+-1
11473 IF(MINT(15).EQ.21) JS=2
11474 I=MINT(14+JS)
11475 IA=IABS(I)
11476 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11477 IB=-IA+INT((IA+1)/2)*4-1
11478 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11479 KCC=15+JS
11480 KCS=ISIGN(1,MINT(14+JS))
11481
11482 ELSEIF(ISUB.EQ.256) THEN
11483C...qj + g -> ~qk_L + ~chi+-2
11484 IF(MINT(15).EQ.21) JS=2
11485 I=MINT(14+JS)
11486 IA=IABS(I)
11487 IB=-IA+INT((IA+1)/2)*4-1
11488 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11489 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11490 KCC=15+JS
11491 KCS=ISIGN(1,MINT(14+JS))
11492
11493 ELSEIF(ISUB.EQ.257) THEN
11494C...qj + g -> ~qk_R + ~chi+-2
11495 IF(MINT(15).EQ.21) JS=2
11496 I=MINT(14+JS)
11497 IA=IABS(I)
11498 IB=-IA+INT((IA+1)/2)*4-1
11499 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11500 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11501 KCC=15+JS
11502 KCS=ISIGN(1,MINT(14+JS))
11503
11504 ELSEIF(ISUB.EQ.258) THEN
11505C...qj + g -> ~qj_L + ~g
11506 IF(MINT(15).EQ.21) JS=2
11507 I=MINT(14+JS)
11508 IA=IABS(I)
11509 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11510 MINT(23-JS)=KSUSY1+21
11511 KCC=MINT(2)+6
11512 IF(JS.EQ.2) KCC=KCC+2
11513 KCS=ISIGN(1,I)
11514
11515 ELSEIF(ISUB.EQ.259) THEN
11516C...qj + g -> ~qj_R + ~g
11517 IF(MINT(15).EQ.21) JS=2
11518 I=MINT(14+JS)
11519 IA=IABS(I)
11520 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11521 MINT(23-JS)=KSUSY1+21
11522 KCC=MINT(2)+6
11523 IF(JS.EQ.2) KCC=KCC+2
11524 KCS=ISIGN(1,I)
11525 ENDIF
11526
11527 ELSEIF(ISUB.LE.270) THEN
11528 IF(ISUB.EQ.261) THEN
11529C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11530 ISGN=1
11531 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11532 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11533 MINT(22)=-MINT(21)
11534C...Correct color combination
11535 IF(MINT(43).EQ.4) KCC=4
11536
11537 ELSEIF(ISUB.EQ.262) THEN
11538C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11539 ISGN=1
11540 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11541 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11542 MINT(22)=-MINT(21)
11543C...Correct color combination
11544 IF(MINT(43).EQ.4) KCC=4
11545
11546 ELSEIF(ISUB.EQ.263) THEN
11547C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11548 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11549 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11550 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11551 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11552 ELSE
11553 JS=2
11554 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11555 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11556 ENDIF
11557C...Correct color combination
11558 IF(MINT(43).EQ.4) KCC=4
11559
11560 ELSEIF(ISUB.EQ.264) THEN
11561C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11562 KCS=(-1)**INT(1.5D0+PYR(0))
11563 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11564 MINT(22)=-MINT(21)
11565 KCC=MINT(2)+10
11566
11567 ELSEIF(ISUB.EQ.265) THEN
11568C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11569 KCS=(-1)**INT(1.5D0+PYR(0))
11570 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11571 MINT(22)=-MINT(21)
11572 KCC=MINT(2)+10
11573 ENDIF
11574
11575 ELSEIF(ISUB.LE.296) THEN
11576 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11577C...qi + qj -> ~qi_L + ~qj_L
11578 KCC=MINT(2)
11579 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11580 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11581 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11582
11583 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11584C...qi + qj -> ~qi_R + ~qj_R
11585 KCC=MINT(2)
11586 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11587 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11588 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11589
11590 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11591C...qi + qj -> ~qi_L + ~qj_R
11592 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11593 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11594 KCC=MINT(2)
11595 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11596
11597 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11598C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11599 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11600 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11601 KCC=MINT(2)
11602 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11603
11604 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11605C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11606 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11607 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11608 KCC=MINT(2)
11609 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11610
11611 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
11612C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11613 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11614 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11615 KCC=MINT(2)
11616 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11617
11618 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
11619C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
11620 ISGN=1
11621 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11622 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11623 MINT(22)=-MINT(21)
11624 IF(MINT(43).EQ.4) KCC=4
11625
11626 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
11627C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
11628 ISGN=1
11629 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11630 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11631 MINT(22)=-MINT(21)
11632 IF(MINT(43).EQ.4) KCC=4
11633
11634 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
11635C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
11636C...pure LL + RR
11637 KCS=(-1)**INT(1.5D0+PYR(0))
11638 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11639 MINT(22)=-MINT(21)
11640 KCC=MINT(2)+10
11641
11642 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
11643C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
11644 KCS=(-1)**INT(1.5D0+PYR(0))
11645 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11646 MINT(22)=-MINT(21)
11647 KCC=MINT(2)+10
11648
11649 ELSEIF(ISUB.EQ.294) THEN
11650C...qj + g -> ~qj_L + ~g
11651 IF(MINT(15).EQ.21) JS=2
11652 I=MINT(14+JS)
11653 IA=IABS(I)
11654 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11655 MINT(23-JS)=KSUSY1+21
11656 KCC=MINT(2)+6
11657 IF(JS.EQ.2) KCC=KCC+2
11658 KCS=ISIGN(1,I)
11659
11660 ELSEIF(ISUB.EQ.295) THEN
11661C...qj + g -> ~qj_R + ~g
11662 IF(MINT(15).EQ.21) JS=2
11663 I=MINT(14+JS)
11664 IA=IABS(I)
11665 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11666 MINT(23-JS)=KSUSY1+21
11667 KCC=MINT(2)+6
11668 IF(JS.EQ.2) KCC=KCC+2
11669 KCS=ISIGN(1,I)
11670 ENDIF
11671
11672 ELSEIF(ISUB.LE.340) THEN
11673
11674 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
11675C...q + qbar' -> H+ + H0
11676 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11677 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11678 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11679 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
11680 MINT(23-JS)=KFPR(ISUB,2)
11681 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
11682C...f + fbar -> A0 + H0; th arbitrary
11683 IF(PYR(0).GT.0.5D0) JS=2
11684 MINT(20+JS)=KFPR(ISUB,1)
11685 MINT(23-JS)=KFPR(ISUB,2)
11686 ELSEIF(ISUB.EQ.301) THEN
11687C...f + fbar -> H+ H-
11688 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11689 MINT(22)=-MINT(21)
11690 ENDIF
11691CMRENNA--
11692
11693 ELSEIF(ISUB.LE.360) THEN
11694
11695 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
11696C...l + l -> H_L++/--, H_R++/--
11697 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11698 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11699 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11700
11701 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
11702C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
11703 IF(MINT(15).EQ.22) JS=2
11704 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
11705 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
11706 KCC=22
11707
11708 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
11709C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
11710 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
11711 MINT(22)=-MINT(21)
11712
11713 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
11714C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
11715C...as inner process).
11716 DO 450 JT=1,2
11717 I=MINT(14+JT)
11718 IA=IABS(I)
11719 IF(IA.LE.10) THEN
11720 RVCKM=VINT(180+I)*PYR(0)
11721 DO 440 J=1,MSTP(1)
11722 IB=2*J-1+MOD(IA,2)
11723 IPM=(5-ISIGN(1,I))/2
11724 IDC=J+MDCY(IA,2)+2
11725 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
11726 MINT(20+JT)=ISIGN(IB,I)
11727 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11728 IF(RVCKM.LE.0D0) GOTO 450
11729 440 CONTINUE
11730 ELSE
11731 IB=2*((IA+1)/2)-1+MOD(IA,2)
11732 MINT(20+JT)=ISIGN(IB,I)
11733 ENDIF
11734 450 CONTINUE
11735 KCC=22
11736 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
11737 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
11738
11739 ELSEIF(ISUB.EQ.353) THEN
11740C...f + fbar -> Z_R0
11741 KFRES=KFPR(ISUB,1)
11742
11743 ELSEIF(ISUB.EQ.354) THEN
11744C...f + fbar' -> W+/-
11745 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11746 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11747 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11748
11749 ENDIF
11750
11751 ELSEIF(ISUB.LE.380) THEN
11752
11753 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
11754C...f + fbar -> charged+ charged- technicolor
11755 KSW=(-1)**INT(1.5D0+PYR(0))
11756 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
11757 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
11758
11759 ELSEIF(ISUB.LE.367) THEN
11760C...f + fbar -> neutral neutral technicolor
11761 MINT(21)=KFPR(ISUB,1)
11762 MINT(22)=KFPR(ISUB,2)
11763
11764 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN
11765C...f + fbar' -> neutral charged technicolor
11766 IN=1
11767 IC=2
11768 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11769 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11770 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11771 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
11772 MINT(20+JS)=KFPR(ISUB,IN)
11773
11774 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
11775C...f + fbar' -> charged neutral technicolor
11776 IN=2
11777 IC=1
11778 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11779 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11780 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11781 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
11782 MINT(23-JS)=KFPR(ISUB,IN)
11783 ENDIF
11784
11785 ELSEIF(ISUB.LE.400) THEN
11786 IF(ISUB.EQ.381) THEN
11787C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
11788 KCC=MINT(2)
11789 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11790
11791 ELSEIF(ISUB.EQ.382) THEN
11792C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
11793 MINT(21)=ISIGN(KFLF,MINT(15))
11794 MINT(22)=-MINT(21)
11795 KCC=4
11796
11797 ELSEIF(ISUB.EQ.383) THEN
11798C...f + fbar -> g + g; th arbitrary, TC extensions
11799 MINT(21)=21
11800 MINT(22)=21
11801 KCC=MINT(2)+4
11802
11803 ELSEIF(ISUB.EQ.384) THEN
11804C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
11805 IF(MINT(15).EQ.21) JS=2
11806 KCC=MINT(2)+6
11807 IF(MINT(15).EQ.21) KCC=KCC+2
11808 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11809 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11810
11811 ELSEIF(ISUB.EQ.385) THEN
11812C...g + g -> f + fbar; th arbitrary, TC extensions
11813 KCS=(-1)**INT(1.5D0+PYR(0))
11814 MINT(21)=ISIGN(KFLF,KCS)
11815 MINT(22)=-MINT(21)
11816 KCC=MINT(2)+10
11817
11818 ELSEIF(ISUB.EQ.386) THEN
11819C...g + g -> g + g; th arbitrary, TC extensions
11820 KCC=MINT(2)+12
11821 KCS=(-1)**INT(1.5D0+PYR(0))
11822
11823 ELSEIF(ISUB.EQ.387) THEN
11824C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
11825 MINT(21)=ISIGN(MINT(55),MINT(15))
11826 MINT(22)=-MINT(21)
11827 KCC=4
11828
11829 ELSEIF(ISUB.EQ.388) THEN
11830C...g + g -> Q + Qbar; th arbitrary, TC extensions
11831 KCS=(-1)**INT(1.5D0+PYR(0))
11832 MINT(21)=ISIGN(MINT(55),KCS)
11833 MINT(22)=-MINT(21)
11834 KCC=MINT(2)+10
11835
11836 ELSEIF(ISUB.EQ.391) THEN
11837C...f + fbar -> G*.
11838 KFRES=KFPR(ISUB,1)
11839
11840 ELSEIF(ISUB.EQ.392) THEN
11841C...g + g -> G*.
11842 KCC=21
11843 KFRES=KFPR(ISUB,1)
11844
11845 ELSEIF(ISUB.EQ.393) THEN
11846C...q + qbar -> g + G*; th arbitrary.
11847 IF(PYR(0).GT.0.5D0) JS=2
11848 MINT(20+JS)=KFPR(ISUB,1)
11849 MINT(23-JS)=KFPR(ISUB,2)
11850 KCC=17+JS
11851
11852 ELSEIF(ISUB.EQ.394) THEN
11853C...q + g -> q + G*; th = (p(f) - p(f))**2
11854 IF(MINT(15).EQ.21) JS=2
11855 MINT(23-JS)=KFPR(ISUB,2)
11856 KCC=15+JS
11857 KCS=ISIGN(1,MINT(14+JS))
11858
11859 ELSEIF(ISUB.EQ.395) THEN
11860C...g + g -> G* + g; th arbitrary.
11861 IF(PYR(0).GT.0.5D0) JS=2
11862 MINT(23-JS)=KFPR(ISUB,2)
11863 KCC=22+JS
11864 ENDIF
11865
11866 ELSEIF(ISUB.LE.420) THEN
11867 IF(ISUB.EQ.401) THEN
11868C...g + g -> t + b + H+/-
11869 KCS=(-1)**INT(1.5D0+PYR(0))
11870 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11871 MINT(22)=ISIGN(5,-KCS)
11872 KCC=11+INT(0.5D0+PYR(0))
11873 KFRES=ISIGN(KFHIGG,-KCS)
11874
11875 ELSEIF(ISUB.EQ.402) THEN
11876C...q + qbar -> t + b + H+/-
11877 KFL=(-1)**INT(1.5D0+PYR(0))
11878 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
11879 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
11880 KCC=4
11881 KFRES=ISIGN(KFHIGG,-KFL*KCS)
11882 ENDIF
11883
11884C...QUARKONIA+++
11885C...Additional code by Stefan Wolf
11886 ELSEIF(ISUB.LE.430) THEN
11887 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
11888C...g + g -> QQ~[n] + g
11889C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
11890C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11891C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
11892C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11893C...or from ISUB.EQ.68 (for ISUB.NE.421)
11894C...[g + g -> g + g; th arbitrary]
11895 MINT(21)=KFPR(ISUBSV,1)
11896 MINT(22)=KFPR(ISUBSV,2)
11897 IF(ISUB.EQ.421) THEN
11898 KCC=24
11899 KCS=(-1)**INT(1.5D0+PYR(0))
11900 ELSE
11901 KCC=MINT(2)+12
11902 KCS=(-1)**INT(1.5D0+PYR(0))
11903 ENDIF
11904
11905 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
11906C...q + g -> q + QQ~[n]
11907C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
11908C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
11909C...KCC copied from ISUB.EQ.28
11910C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
11911 IF(MINT(15).EQ.21) JS=2
11912 MINT(23-JS)=KFPR(ISUBSV,2)
11913 KCC=MINT(2)+6
11914 IF(MINT(15).EQ.21) KCC=KCC+2
11915 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11916 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11917
11918 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
11919C...q + q~ -> g + QQ~[n]
11920C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
11921C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
11922C...KCC copied from ISUB.EQ.13
11923C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
11924 IF(PYR(0).GT.0.5) JS=2
11925 MINT(20+JS)=21
11926 MINT(23-JS)=KFPR(ISUBSV,2)
11927 KCC=MINT(2)+4
11928 ENDIF
11929
11930 ELSEIF(ISUB.LE.440) THEN
11931 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
11932C...g + g -> QQ~[n] + g
11933C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
11934C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11935C...KCC and KCS copied from ISUB.EQ.86-89
11936C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
11937 MINT(21)=KFPR(ISUBSV,1)
11938 MINT(22)=KFPR(ISUBSV,2)
11939 KCC=24
11940 KCS=(-1)**INT(1.5D0+PYR(0))
11941
11942 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
11943C...q + g -> q + QQ~[n]
11944C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
11945C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
11946C...KCC and KCS copied from ISUB.EQ.112
11947C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
11948 IF(MINT(15).EQ.21) JS=2
11949 MINT(23-JS)=KFPR(ISUBSV,2)
11950 KCC=15+JS
11951 KCS=ISIGN(1,MINT(14+JS))
11952
11953 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
11954C...q + q~ -> g + QQ~[n]
11955C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
11956C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
11957C...KCC copied from ISUB.EQ.111
11958C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
11959 IF(PYR(0).GT.0.5) JS=2
11960 MINT(20+JS)=21
11961 MINT(23-JS)=KFPR(ISUBSV,2)
11962 KCC=17+JS
11963 ENDIF
11964C...QUARKONIA---
11965
11966 ENDIF
11967
11968 IF(ISET(ISUB).EQ.11) THEN
11969C...Store documentation for user-defined processes
11970 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
11971 KUPPO(1)=MINT(83)+5
11972 KUPPO(2)=MINT(83)+6
11973 I=MINT(83)+6
11974 DO 470 IUP=3,NUP
11975 KUPPO(IUP)=0
11976 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
11977 IDOC=IDOC-1
11978 MINT(4)=MINT(4)-1
11979 GOTO 470
11980 ENDIF
11981 I=I+1
11982 KUPPO(IUP)=I
11983 K(I,1)=21
11984 K(I,2)=IDUP(IUP)
11985 IF(IDUP(IUP).EQ.0) K(I,2)=90
11986 K(I,3)=0
11987 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
11988 K(I,4)=0
11989 K(I,5)=0
11990 DO 460 J=1,5
11991 P(I,J)=PUP(J,IUP)
11992 460 CONTINUE
11993 V(I,5)=VTIMUP(IUP)
11994 470 CONTINUE
11995 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
11996 & -BEZUP)
11997
11998C...Store final state partons for user-defined processes
11999 N=IPU2
12000 DO 490 IUP=3,NUP
12001 N=N+1
12002 K(N,1)=1
12003 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12004 K(N,2)=IDUP(IUP)
12005 IF(IDUP(IUP).EQ.0) K(N,2)=90
12006 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12007 K(N,3)=KUPPO(IUP)
12008 ELSE
12009 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12010 ENDIF
12011 K(N,4)=0
12012 K(N,5)=0
12013C...Search for daughters of intermediate colourless particles.
12014 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12015 DO 475 IUPDAU=IUP+1,NUP
12016 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12017 & N+IUPDAU-IUP
12018 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12019 475 CONTINUE
12020 ENDIF
12021 DO 480 J=1,5
12022 P(N,J)=PUP(J,IUP)
12023 480 CONTINUE
12024 V(N,5)=VTIMUP(IUP)
12025 490 CONTINUE
12026 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12027
12028C...Arrange colour flow for user-defined processes
12029 NLBL=0
12030 DO 540 IUP1=1,NUP
12031 I1=MINT(84)+IUP1
12032 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12033 IF(K(I1,1).EQ.1) K(I1,1)=3
12034 IF(K(I1,1).EQ.11) K(I1,1)=14
12035C...Find a not yet considered colour/anticolour line.
12036 DO 530 ISDE1=1,2
12037 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12038 NMAT=0
12039 DO 500 ILBL=1,NLBL
12040 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12041 500 CONTINUE
12042 IF(NMAT.EQ.0) THEN
12043 NLBL=NLBL+1
12044 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12045C...Find all others belonging to same line.
12046 I3=I1
12047 I4=0
12048 DO 520 IUP2=IUP1+1,NUP
12049 I2=MINT(84)+IUP2
12050 DO 510 ISDE2=1,2
12051 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12052 IF(ISDE2.EQ.ISDE1) THEN
12053 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12054 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12055 I3=I2
12056 ELSEIF(I4.NE.0) THEN
12057 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12058 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12059 I4=I2
12060 ELSEIF(IUP2.LE.2) THEN
12061 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12062 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12063 I4=I2
12064 ELSE
12065 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12066 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12067 I4=I2
12068 ENDIF
12069 ENDIF
12070 510 CONTINUE
12071 520 CONTINUE
12072 ENDIF
12073 530 CONTINUE
12074 540 CONTINUE
12075
12076 ELSEIF(IDOC.EQ.7) THEN
12077C...Resonance not decaying; store kinematics
12078 I=MINT(83)+7
12079 K(IPU3,1)=1
12080 K(IPU3,2)=KFRES
12081 K(IPU3,3)=I
12082 P(IPU3,4)=SHUSER
12083 P(IPU3,5)=SHUSER
12084 K(I,1)=21
12085 K(I,2)=KFRES
12086 P(I,4)=SHUSER
12087 P(I,5)=SHUSER
12088 N=IPU3
12089 MINT(21)=KFRES
12090 MINT(22)=0
12091
12092C...Special cases: colour flow in coloured resonances
12093 KCRES=PYCOMP(KFRES)
12094 IF(KCHG(KCRES,2).NE.0) THEN
12095 K(IPU3,1)=3
12096 DO 550 J=1,2
12097 JC=J
12098 IF(KCS.EQ.-1) JC=3-J
12099 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12100 & MINT(84)+ICOL(KCC,1,JC)
12101 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12102 & MINT(84)+ICOL(KCC,2,JC)
12103 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12104 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12105 550 CONTINUE
12106 ELSE
12107 K(IPU1,4)=IPU2
12108 K(IPU1,5)=IPU2
12109 K(IPU2,4)=IPU1
12110 K(IPU2,5)=IPU1
12111 ENDIF
12112
12113 ELSEIF(IDOC.EQ.8) THEN
12114C...2 -> 2 processes: store outgoing partons in their CM-frame
12115 DO 560 JT=1,2
12116 I=MINT(84)+2+JT
12117 KCA=PYCOMP(MINT(20+JT))
12118 K(I,1)=1
12119 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12120 K(I,2)=MINT(20+JT)
12121 K(I,3)=MINT(83)+IDOC+JT-2
12122 KFAA=IABS(K(I,2))
12123 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12124 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12125 ELSE
12126 P(I,5)=PYMASS(K(I,2))
12127 ENDIF
12128 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12129 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12130 560 CONTINUE
12131 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12132 KFA1=IABS(MINT(21))
12133 KFA2=IABS(MINT(22))
12134 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12135 & THEN
12136 MINT(51)=1
12137 RETURN
12138 ENDIF
12139 P(IPU3,5)=0D0
12140 P(IPU4,5)=0D0
12141 ENDIF
12142 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12143 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12144 P(IPU4,4)=SHR-P(IPU3,4)
12145 P(IPU4,3)=-P(IPU3,3)
12146 N=IPU4
12147 MINT(7)=MINT(83)+7
12148 MINT(8)=MINT(83)+8
12149
12150C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12151 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12152
12153 ELSEIF(IDOC.EQ.9) THEN
12154C...2 -> 3 processes: store outgoing partons in their CM frame
12155 DO 570 JT=1,2
12156 I=MINT(84)+2+JT
12157 KCA=PYCOMP(MINT(20+JT))
12158 K(I,1)=1
12159 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12160 K(I,2)=MINT(20+JT)
12161 K(I,3)=MINT(83)+IDOC+JT-3
12162 JTA=JT
12163C...t and b in opposide order in event list as compared to
12164C...matrix element?
12165 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12166 IF(IABS(K(I,2)).LE.22) THEN
12167 P(I,5)=PYMASS(K(I,2))
12168 ELSE
12169 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12170 ENDIF
12171 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12172 P(I,1)=PT*COS(VINT(198+5*JTA))
12173 P(I,2)=PT*SIN(VINT(198+5*JTA))
12174 570 CONTINUE
12175 K(IPU5,1)=1
12176 K(IPU5,2)=KFRES
12177 K(IPU5,3)=MINT(83)+IDOC
12178 P(IPU5,5)=SHR
12179 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12180 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12181 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12182 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12183 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12184 PMT3=SQRT(PMS3)
12185 P(IPU5,3)=PMT3*SINH(VINT(211))
12186 P(IPU5,4)=PMT3*COSH(VINT(211))
12187 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12188 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12189 IF(SQL12.LE.0D0) THEN
12190 MINT(51)=1
12191 RETURN
12192 ENDIF
12193 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12194 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12195 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12196 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12197C...t and b in opposide order in event list as compared to
12198C...matrix element
12199 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12200 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12201 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12202 END IF
12203 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12204 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12205 MINT(23)=KFRES
12206 N=IPU5
12207 MINT(7)=MINT(83)+7
12208 MINT(8)=MINT(83)+8
12209
12210 ELSEIF(IDOC.EQ.11) THEN
12211C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12212 PHI(1)=PARU(2)*PYR(0)
12213 PHI(2)=PHI(1)-PHIR
12214 DO 580 JT=1,2
12215 I=MINT(84)+2+JT
12216 K(I,1)=1
12217 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12218 K(I,2)=MINT(20+JT)
12219 K(I,3)=MINT(83)+IDOC+JT-2
12220 P(I,5)=PYMASS(K(I,2))
12221 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12222 MINT(51)=1
12223 RETURN
12224 ENDIF
12225 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12226 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12227 P(I,1)=PTABS*COS(PHI(JT))
12228 P(I,2)=PTABS*SIN(PHI(JT))
12229 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12230 P(I,4)=0.5D0*SHPR*Z(JT)
12231 IZW=MINT(83)+6+JT
12232 K(IZW,1)=21
12233 K(IZW,2)=23
12234 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12235 K(IZW,3)=IZW-2
12236 P(IZW,1)=-P(I,1)
12237 P(IZW,2)=-P(I,2)
12238 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12239 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12240 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12241 580 CONTINUE
12242 I=MINT(83)+9
12243 K(IPU5,1)=1
12244 K(IPU5,2)=KFRES
12245 K(IPU5,3)=I
12246 P(IPU5,5)=SHR
12247 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12248 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12249 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12250 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12251 K(I,1)=21
12252 K(I,2)=KFRES
12253 DO 590 J=1,5
12254 P(I,J)=P(IPU5,J)
12255 590 CONTINUE
12256 N=IPU5
12257 MINT(23)=KFRES
12258
12259 ELSEIF(IDOC.EQ.12) THEN
12260C...Z0 and W+/- scattering: store bosons and outgoing partons
12261 PHI(1)=PARU(2)*PYR(0)
12262 PHI(2)=PHI(1)-PHIR
12263 JTRAN=INT(1.5D0+PYR(0))
12264 DO 600 JT=1,2
12265 I=MINT(84)+2+JT
12266 K(I,1)=1
12267 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12268 K(I,2)=MINT(20+JT)
12269 K(I,3)=MINT(83)+IDOC+JT-2
12270 P(I,5)=PYMASS(K(I,2))
12271 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12272 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12273 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12274 P(I,1)=PTABS*COS(PHI(JT))
12275 P(I,2)=PTABS*SIN(PHI(JT))
12276 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12277 P(I,4)=0.5D0*SHPR*Z(JT)
12278 IZW=MINT(83)+6+JT
12279 K(IZW,1)=21
12280 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12281 K(IZW,2)=23
12282 ELSE
12283 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12284 ENDIF
12285 K(IZW,3)=IZW-2
12286 P(IZW,1)=-P(I,1)
12287 P(IZW,2)=-P(I,2)
12288 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12289 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12290 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12291 IPU=MINT(84)+4+JT
12292 K(IPU,1)=3
12293 K(IPU,2)=KFPR(ISUB,JT)
12294 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12295 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12296 K(IPU,3)=MINT(83)+8+JT
12297 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12298 P(IPU,5)=PYMASS(K(IPU,2))
12299 ELSE
12300 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12301 ENDIF
12302 MINT(22+JT)=K(IPU,2)
12303 600 CONTINUE
12304C...Find rotation and boost for hard scattering subsystem
12305 I1=MINT(83)+7
12306 I2=MINT(83)+8
12307 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12308 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12309 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12310 GAMCM=(P(I1,4)+P(I2,4))/SHR
12311 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12312 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12313 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12314 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12315 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12316 PHICM=PYANGL(PX,PY)
12317C...Store hard scattering subsystem. Rotate and boost it
12318 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12319 & P(IPU6,5)**2
12320 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12321 CTHWZ=VINT(23)
12322 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12323 PHIWZ=VINT(24)-PHICM
12324 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12325 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12326 P(IPU5,3)=PABS*CTHWZ
12327 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12328 P(IPU6,1)=-P(IPU5,1)
12329 P(IPU6,2)=-P(IPU5,2)
12330 P(IPU6,3)=-P(IPU5,3)
12331 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12332 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12333 DO 620 JT=1,2
12334 I1=MINT(83)+8+JT
12335 I2=MINT(84)+4+JT
12336 K(I1,1)=21
12337 K(I1,2)=K(I2,2)
12338 DO 610 J=1,5
12339 P(I1,J)=P(I2,J)
12340 610 CONTINUE
12341 620 CONTINUE
12342 N=IPU6
12343 MINT(7)=MINT(83)+9
12344 MINT(8)=MINT(83)+10
12345 ENDIF
12346
12347 IF(ISET(ISUB).EQ.11) THEN
12348 ELSEIF(IDOC.GE.8) THEN
12349C...Store colour connection indices
12350 DO 630 J=1,2
12351 JC=J
12352 IF(KCS.EQ.-1) JC=3-J
12353 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12354 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12355 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12356 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12357 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12358 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12359 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12360 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12361 630 CONTINUE
12362
12363C...Copy outgoing partons to documentation lines
12364 IMAX=2
12365 IF(IDOC.EQ.9) IMAX=3
12366 DO 650 I=1,IMAX
12367 I1=MINT(83)+IDOC-IMAX+I
12368 I2=MINT(84)+2+I
12369 K(I1,1)=21
12370 K(I1,2)=K(I2,2)
12371 IF(IDOC.LE.9) K(I1,3)=0
12372 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12373 DO 640 J=1,5
12374 P(I1,J)=P(I2,J)
12375 640 CONTINUE
12376 650 CONTINUE
12377
12378 ELSEIF(IDOC.EQ.9) THEN
12379C...Store colour connection indices
12380 DO 660 J=1,2
12381 JC=J
12382 IF(KCS.EQ.-1) JC=3-J
12383 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12384 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12385 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12386 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12387 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12388 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12389 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12390 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12391 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12392 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12393 660 CONTINUE
12394
12395C...Copy outgoing partons to documentation lines
12396 DO 680 I=1,3
12397 I1=MINT(83)+IDOC-3+I
12398 I2=MINT(84)+2+I
12399 K(I1,1)=21
12400 K(I1,2)=K(I2,2)
12401 K(I1,3)=0
12402 DO 670 J=1,5
12403 P(I1,J)=P(I2,J)
12404 670 CONTINUE
12405 680 CONTINUE
12406 ENDIF
12407
12408C...Copy outgoing partons to list of allowed radiators.
12409 NPART=0
12410 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12411 DO 690 I=MINT(84)+3,N
12412 NPART=NPART+1
12413 IPART(NPART)=I
12414 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12415 690 CONTINUE
12416 ENDIF
12417
12418C...Low-pT events: remove gluons used for string drawing purposes
12419 IF(ISUB.EQ.95) THEN
12420 IF(MINT(35).LE.1) THEN
12421 K(IPU3,1)=K(IPU3,1)+10
12422 K(IPU4,1)=K(IPU4,1)+10
12423 ENDIF
12424 DO 700 J=41,66
12425 VINTSV(J)=VINT(J)
12426 VINT(J)=0D0
12427 700 CONTINUE
12428 DO 720 I=MINT(83)+5,MINT(83)+8
12429 DO 710 J=1,5
12430 P(I,J)=0D0
12431 710 CONTINUE
12432 720 CONTINUE
12433 ENDIF
12434
12435 RETURN
12436 END
12437
12438C***********************************************************************
12439
12440C...PYEVOL
12441C...Handles intertwined pT-ordered spacelike initial-state parton
12442C...and multiple interactions.
12443
12444 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12445C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12446C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12447C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12448
12449C...Double precision and integer declarations.
12450 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12451 IMPLICIT INTEGER(I-N)
12452 INTEGER PYK,PYCHGE,PYCOMP
12453C...External
12454 EXTERNAL PYALPS
12455 DOUBLE PRECISION PYALPS
12456C...Parameter statement for maximum size of showers.
12457 PARAMETER (MAXNUR=1000)
12458C...Commonblocks.
12459 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12460 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12461 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12462 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12463 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12464 COMMON/PYINT1/MINT(400),VINT(400)
12465 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12466 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12467 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12468 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12469 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12470 COMMON/PYCTAG/NCT,MCT(4000,2)
12471 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12472 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12473 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12474C...Local arrays and saved variables.
12475 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12476 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12477 & ,PSAV,KSAV,VSAV
12478
12479 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12480 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12481
12482C----------------------------------------------------------------------
12483C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12484C...done only once per event, while MODE=0 is repeated each time the
12485C...evolution needs to be restarted.
12486 IF (MODE.EQ.-1) THEN
12487 ISUBHD=MINT(1)
12488 NSAV=N
12489 NPARTS=NPART
12490C...Store hard scattering variables
12491 M15SV=MINT(15)
12492 M16SV=MINT(16)
12493 M21SV=MINT(21)
12494 M22SV=MINT(22)
12495 DO 100 J=11,80
12496 VINTSV(J)=VINT(J)
12497 100 CONTINUE
12498 DO 120 J=1,5
12499 DO 110 IS=1,4
12500 I=IS+MINT(84)
12501 PSAV(IS,J)=P(I,J)
12502 KSAV(IS,J)=K(I,J)
12503 VSAV(IS,J)=V(I,J)
12504 110 CONTINUE
12505 120 CONTINUE
12506
12507C...Set shat for hardest scattering
12508 SHAT(1)=VINT(44)
12509 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12510 & *VINT(2)
12511
12512C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12513 RMC=PMAS(4,1)
12514 RMB=PMAS(5,1)
12515 ALAM4=PARP(61)
12516 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12517 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12518 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12519
12520C----------------------------------------------------------------------
12521C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12522C...interaction initiators, with no previous evolution. Check the input
12523C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12524C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12525C...smaller than the CM energy / 2.)
12526 ELSEIF (MODE.EQ.0) THEN
12527C...Reset counters and switches
12528 N=NSAV
12529 NPART=NPARTS
12530 MINT(30)=0
12531 MINT(31)=1
12532 MINT(36)=1
12533C...Reset hard scattering variables
12534 MINT(1)=ISUBHD
12535 DO 130 J=11,80
12536 VINT(J)=VINTSV(J)
12537 130 CONTINUE
12538 DO 150 J=1,5
12539 DO 140 IS=1,4
12540 I=IS+MINT(84)
12541 P(I,J)=PSAV(IS,J)
12542 K(I,J)=KSAV(IS,J)
12543 V(I,J)=VSAV(IS,J)
12544 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12545 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12546 140 CONTINUE
12547 150 CONTINUE
12548C...Reset statistics on activity in event.
12549 DO 160 J=351,359
12550 MINT(J)=0
12551 VINT(J)=0D0
12552 160 CONTINUE
12553C...Reset extra companion reweighting factor
12554 VINT(140)=1D0
12555
12556C...We do not generate MI for soft process (ISUB=95), but the
12557C...initialization must be done regardless, for later purposes.
12558 MINT(36)=1
12559
12560C...Initialize multiple interactions.
12561 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12562 IF(MINT(51).NE.0) RETURN
12563
12564C...Decide whether quarks in hard scattering were valence or sea
12565 PT2HD=VINT(54)
12566 DO 170 JS=1,2
12567 MINT(30)=JS
12568 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12569 IF(MINT(51).NE.0) RETURN
12570 170 CONTINUE
12571
12572C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12573 VINT(18)=0D0
12574 IF(MSTP(70).EQ.0) THEN
12575 PT20=PARP(62)**2
12576 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12577 ELSEIF(MSTP(70).EQ.1) THEN
12578 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12579 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12580 ELSE
12581 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12582 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12583 ENDIF
12584C...Also store PT2MIN in VINT(17).
12585 180 VINT(17)=PT2MIN
12586
12587C...Set FS masses zero now.
12588 VINT(63)=0D0
12589 VINT(64)=0D0
12590
12591C...Initialize IS showers with VINT(56) as max scale.
12592 PT2ISR=VINT(56)
12593 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12594 IF(MINT(51).NE.0) RETURN
12595
12596 RETURN
12597
12598C----------------------------------------------------------------------
12599C...MODE= 1: Evolve event from PTMAX to PTMIN.
12600 ELSEIF (MODE.EQ.1) THEN
12601
12602C...Skip if no phase space.
12603 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12604
12605C...Starting pT2 max scale (to be udpated successively).
12606 PT2CMX=PT2MAX
12607
12608C...Evolve two sides of the event to find which branches at highest pT.
12609 200 JSMX=-1
12610 MIMX=0
12611 PT2MX=0D0
12612
12613C...Loop over current shower initiators.
12614 IF (MSTP(61).GE.1) THEN
12615 DO 230 MI=1,MINT(31)
12616 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
12617 ISUB=96
12618 IF (MI.EQ.1) ISUB=ISUBHD
12619 MINT(1)=ISUB
12620 MINT(36)=MI
12621C...Set up shat, initiator x values, and x remaining in BR.
12622 VINT(44)=SHAT(MI)
12623 VINT(141)=XMI(1,MI)
12624 VINT(142)=XMI(2,MI)
12625 VINT(143)=1D0
12626 VINT(144)=1D0
12627 DO 210 JI=1,MINT(31)
12628 IF (JI.EQ.MINT(36)) GOTO 210
12629 VINT(143)=VINT(143)-XMI(1,JI)
12630 VINT(144)=VINT(144)-XMI(2,JI)
12631 210 CONTINUE
12632C...Loop over sides.
12633C...Generate trial branchings for this interaction. The hardest
12634C...branching so far is automatically updated if necessary in /PYISMX/.
12635 DO 220 JS=1,2
12636 MINT(30)=JS
12637 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
12638 IF (MINT(51).NE.0) RETURN
12639 220 CONTINUE
12640 230 CONTINUE
12641 ENDIF
12642
12643C...Generate trial additional interaction.
12644 MINT(36)=MINT(31)+1
12645 240 IF (MOD(MSTP(81),10).GE.1) THEN
12646 MINT(1)=96
12647C...Set up X remaining in BR.
12648 VINT(143)=1D0
12649 VINT(144)=1D0
12650 DO 250 JI=1,MINT(31)
12651 VINT(143)=VINT(143)-XMI(1,JI)
12652 VINT(144)=VINT(144)-XMI(2,JI)
12653 250 CONTINUE
12654C...Generate trial interaction
12655 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
12656 IF (MINT(51).EQ.1) RETURN
12657 ENDIF
12658
12659C...And the winner is:
12660 IF (PT2MX.LT.PT2MIN) THEN
12661 GOTO 330
12662 ELSEIF (JSMX.EQ.0) THEN
12663C...Accept additional interaction (may still fail).
12664 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
12665 IF(MINT(51).NE.0) RETURN
12666 IF (IFAIL.EQ.0) THEN
12667 SHAT(MINT(36))=VINT(44)
12668C...Decide on flavours (valence/sea/companion).
12669 DO 270 JS=1,2
12670 MINT(30)=JS
12671 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
12672 IF(MINT(51).NE.0) RETURN
12673 270 CONTINUE
12674 ENDIF
12675 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
12676C...Reconstruct kinematics of acceptable ISR branching.
12677C...Set up shat, initiator x values, and x remaining in BR.
12678 MINT(30)=JSMX
12679 MINT(36)=MIMX
12680 VINT(44)=SHAT(MINT(36))
12681 VINT(141)=XMI(1,MINT(36))
12682 VINT(142)=XMI(2,MINT(36))
12683 VINT(143)=1D0
12684 VINT(144)=1D0
12685 DO 280 JI=1,MINT(31)
12686 IF (JI.EQ.MINT(36)) GOTO 280
12687 VINT(143)=VINT(143)-XMI(1,JI)
12688 VINT(144)=VINT(144)-XMI(2,JI)
12689 280 CONTINUE
12690 PT2NEW=PT2MX
12691 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
12692 IF (MINT(51).EQ.1) RETURN
12693 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
12694C...Bookeep joining. Cannot (yet) be constructed kinematically.
12695 MINT(354)=MINT(354)+1
12696 VINT(354)=VINT(354)+SQRT(PT2MX)
12697 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
12698 MJOIND(JSMX-2,MJN1MX)=MJN2MX
12699 MJOIND(JSMX-2,MJN2MX)=MJN1MX
12700 ENDIF
12701
12702C...Update PT2 iteration scale.
12703 PT2CMX=PT2MX
12704
12705C...Loop back to continue evolution.
12706 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
12707 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
12708 ELSE
12709 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
12710 ENDIF
12711
12712C----------------------------------------------------------------------
12713C...MODE= 2: (Re-)store user information on hardest interaction etc.
12714 ELSEIF (MODE.EQ.2) THEN
12715
12716C...Revert to "ordinary" meanings of some parameters.
12717 290 DO 310 JS=1,2
12718 MINT(12+JS)=K(IMI(JS,1,1),2)
12719 VINT(140+JS)=XMI(JS,1)
12720 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
12721 VINT(142+JS)=1D0
12722 DO 300 MI=1,MINT(31)
12723 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
12724 300 CONTINUE
12725 310 CONTINUE
12726
12727C...Restore saved quantities for hardest interaction.
12728 MINT(1)=ISUBHD
12729 MINT(15)=M15SV
12730 MINT(16)=M16SV
12731 MINT(21)=M21SV
12732 MINT(22)=M22SV
12733 DO 320 J=11,80
12734 VINT(J)=VINTSV(J)
12735 320 CONTINUE
12736
12737 ENDIF
12738
12739 330 RETURN
12740 END
12741
12742C*********************************************************************
12743
12744C...PYSSPA
12745C...Generates spacelike parton showers.
12746
12747 SUBROUTINE PYSSPA(IPU1,IPU2)
12748
12749C...Double precision and integer declarations.
12750 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12751 IMPLICIT INTEGER(I-N)
12752 INTEGER PYK,PYCHGE,PYCOMP
12753C...Commonblocks.
12754 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12755 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12756 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12757 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
12758 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12759 COMMON/PYINT1/MINT(400),VINT(400)
12760 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12761 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12762 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
12763 &/PYINT2/,/PYINT3/
12764C...Local arrays and data.
12765 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
12766 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
12767 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
12768 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
12769 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
12770 DATA IS/2*0/
12771
12772C...Read out basic information; set global Q^2 scale.
12773 IPUS1=IPU1
12774 IPUS2=IPU2
12775 ISUB=MINT(1)
12776 Q2MX=VINT(56)
12777 VINT2R=VINT(2)*VINT(143)*VINT(144)
12778 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
12779 &MIN(VINT2R,PARP(67)*VINT(56))
12780 FCQ2MX=1D0
12781
12782C...Define which processes ME corrections have been implemented for.
12783 MECOR=0
12784 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
12785 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
12786 & ISUB.EQ.144) MECOR=1
12787 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
12788 ENDIF
12789
12790C...Initialize QCD evolution and check phase space.
12791 Q2MNC=PARP(62)**2
12792 Q2MNCS(1)=Q2MNC
12793 Q2MNCS(2)=Q2MNC
12794 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
12795 Q0S=PARP(15)**2
12796 PS=VINT(3)**2
12797 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
12798 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
12799 Q2INT=SQRT(Q0S*Q2EFF)
12800 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
12801 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
12802 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
12803 ENDIF
12804 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
12805 Q0S=PARP(15)**2
12806 PS=VINT(4)**2
12807 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
12808 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
12809 Q2INT=SQRT(Q0S*Q2EFF)
12810 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
12811 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
12812 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
12813 ENDIF
12814 MCEV=0
12815 ALAMS=PARU(112)
12816 PARU(112)=PARP(61)
12817 FQ2C=1D0
12818 TCMX=0D0
12819 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
12820 MCEV=1
12821 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
12822 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
12823 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
12824 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
12825 & MCEV=0
12826 ENDIF
12827
12828C...Initialize QED evolution and check phase space.
12829 MEEV=0
12830 XEE=1D-10
12831 SPME=PMAS(11,1)**2
12832 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
12833 &SPME=PMAS(13,1)**2
12834 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
12835 &SPME=PMAS(15,1)**2
12836 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
12837 TEMX=0D0
12838 FWTE=10D0
12839 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
12840 MEEV=1
12841 TEMX=LOG(Q2MX/SPME)
12842 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
12843 ENDIF
12844 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
12845 MEEV=2
12846 TEMX=TCMX
12847 FWTE=1D0
12848 ENDIF
12849 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
12850
12851C...Loopback point in case of failure to reconstruct kinematics.
12852 NS=N
12853 LOOP=0
12854 MNT352=MINT(352)
12855 MNT353=MINT(353)
12856 VNT352=VINT(352)
12857 VNT353=VINT(353)
12858 100 LOOP=LOOP+1
12859 IF(LOOP.GT.100) THEN
12860 MINT(51)=1
12861 RETURN
12862 ENDIF
12863 N=NS
12864 MINT(352)=MNT352
12865 MINT(353)=MNT353
12866 VINT(352)=VNT352
12867 VINT(353)=VNT353
12868
12869C...Initial values: flavours, momenta, virtualities.
12870 DO 120 JT=1,2
12871 MORE(JT)=1
12872 KFBEAM(JT)=MINT(10+JT)
12873 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
12874 KFLS(JT)=MINT(14+JT)
12875 KFLS(JT+2)=KFLS(JT)
12876 XS(JT)=VINT(40+JT)
12877 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
12878 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
12879 ZS(JT)=1D0
12880 Q2S(JT)=FCQ2MX*Q2MX
12881 DQ2(JT)=0D0
12882 TEVCSV(JT)=TCMX
12883 ALAM(JT)=PARP(61)
12884 THE2(JT)=1D0
12885 TEVESV(JT)=TEMX
12886 MCESV(JT)=0
12887C...Calculate initial parton distribution weights.
12888 MINT(105)=MINT(102+JT)
12889 MINT(109)=MINT(106+JT)
12890 VINT(120)=VINT(2+JT)
12891 IF(XS(JT).LT.1D0-XEE) THEN
12892 IF(MINT(31).GE.2) MINT(30)=JT
12893 IF(MSTP(57).LE.1) THEN
12894 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
12895 ELSE
12896 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
12897 ENDIF
12898 ENDIF
12899 DO 110 KFL=-25,25
12900 XFS(JT,KFL)=XFB(KFL)
12901 110 CONTINUE
12902C...Special kinematics check for c/b quarks (that g -> c cbar or
12903C...b bbar kinematically possible).
12904 KFLCB=IABS(KFLS(JT))
12905 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
12906 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
12907 MINT(51)=1
12908 RETURN
12909 ENDIF
12910 ENDIF
12911 120 CONTINUE
12912 DSH=VINT(44)
12913 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
12914
12915C...Find if interference with final state partons.
12916 MFIS=0
12917 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
12918 IF(MFIS.NE.0) THEN
12919 DO 140 I=1,2
12920 KCFI(I)=0
12921 KCA=PYCOMP(IABS(KFLS(I)))
12922 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
12923 NFIS(I)=0
12924 IF(KCFI(I).NE.0) THEN
12925 IF(I.EQ.1) IPFS=IPUS1
12926 IF(I.EQ.2) IPFS=IPUS2
12927 DO 130 J=1,2
12928 ICSI=MOD(K(IPFS,3+J),MSTU(5))
12929 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
12930 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
12931 NFIS(I)=NFIS(I)+1
12932 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
12933 & P(ICSI,2)**2))
12934 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
12935 ENDIF
12936 130 CONTINUE
12937 ENDIF
12938 140 CONTINUE
12939 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
12940 ENDIF
12941
12942C...Pick up leg with highest virtuality.
12943 JTOLD=1
12944 150 N=N+1
12945 JT=1
12946 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
12947 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
12948 IF(MORE(JT).EQ.0) JT=3-JT
12949 JTOLD=JT
12950 KFLB=KFLS(JT)
12951 XB=XS(JT)
12952 DO 160 KFL=-25,25
12953 XFB(KFL)=XFS(JT,KFL)
12954 160 CONTINUE
12955 DSHR=2D0*SQRT(DSH)
12956 DSHZ=DSH/ZS(JT)
12957
12958C...Check if allowed to branch.
12959 MCEV=0
12960 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
12961 MCEV=1
12962 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
12963 IF(XB.GE.1D0-2D0*XEC) MCEV=0
12964 ENDIF
12965 MEEV=0
12966 IF(MINT(44+JT).EQ.3) THEN
12967 MEEV=1
12968 IF(XB.GE.1D0-2D0*XEE) MEEV=0
12969 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
12970 & MEEV=0
12971C***Currently kill QED shower for resolved photoproduction.
12972 IF(MINT(18+JT).EQ.1) MEEV=0
12973C***Currently kill shower for W inside electron.
12974 IF(IABS(KFLB).EQ.24) THEN
12975 MCEV=0
12976 MEEV=0
12977 ENDIF
12978 ENDIF
12979 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
12980 &MEEV=2
12981 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
12982 Q2B=0D0
12983 GOTO 260
12984 ENDIF
12985
12986C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
12987 Q2B=Q2S(JT)
12988 TEVCB=TEVCSV(JT)
12989 TEVEB=TEVESV(JT)
12990 IF(MSTP(62).LE.1) THEN
12991 IF(ZS(JT).GT.0.99999D0) THEN
12992 Q2B=Q2S(JT)
12993 ELSE
12994 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
12995 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
12996 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
12997 ENDIF
12998 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
12999 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13000 ENDIF
13001 IF(MCEV.EQ.1) THEN
13002 ALSDUM=PYALPS(FQ2C*Q2B)
13003 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13004 ALAM(JT)=PARU(117)
13005 B0=(33D0-2D0*MSTU(118))/6D0
13006 ENDIF
13007 IF(MEEV.EQ.2) TEVEB=TEVCB
13008 TEVCBS=TEVCB
13009 TEVEBS=TEVEB
13010
13011C...Select side for interference with final state partons.
13012 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13013 IFI=N-NS
13014 ISFI(IFI)=0
13015 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13016 ISFI(IFI)=1
13017 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13018 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13019 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13020 ISFI(IFI)=1
13021 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13022 ENDIF
13023 ENDIF
13024
13025C...Calculate preweighting factor for ME-corrected processes.
13026 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13027
13028C...Calculate Altarelli-Parisi weights.
13029 DO 170 KFL=-25,25
13030 WTAPC(KFL)=0D0
13031 WTAPE(KFL)=0D0
13032 WTSF(KFL)=0D0
13033 170 CONTINUE
13034C...q -> q (g or gamma emission), g -> q.
13035 IF(IABS(KFLB).LE.10) THEN
13036 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13037 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13038 EQ2=1D0/9D0
13039 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13040 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13041 & (XEC*(1D0-XEC)))
13042 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13043 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13044 WTAPC(21)=WTGF*WTAPC(21)
13045 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13046 ENDIF
13047C...f -> f, gamma -> f.
13048 ELSEIF(IABS(KFLB).LE.20) THEN
13049 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13050 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13051 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13052 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13053 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13054 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13055 WTAPE(22)=WTGF*WTAPE(22)
13056 ENDIF
13057C...f -> g, g -> g.
13058 ELSEIF(KFLB.EQ.21) THEN
13059 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13060 DO 180 KFL=1,MSTP(58)
13061 WTAPC(KFL)=WTAPQ
13062 WTAPC(-KFL)=WTAPQ
13063 180 CONTINUE
13064 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13065 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13066 DO 190 KFL=1,MSTP(58)
13067 WTAPC(KFL)=WTFG*WTAPC(KFL)
13068 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13069 190 CONTINUE
13070 WTAPC(21)=WTGG*WTAPC(21)
13071 ENDIF
13072C...f -> gamma, W+, W-.
13073 ELSEIF(KFLB.EQ.22) THEN
13074 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13075 WTAPE(11)=WTAPF
13076 WTAPE(-11)=WTAPF
13077 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13078 WTAPE(11)=WTFG*WTAPE(11)
13079 WTAPE(-11)=WTFG*WTAPE(-11)
13080 ENDIF
13081 ELSEIF(KFLB.EQ.24) THEN
13082 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13083 & (XEE*(XB+XEE)))/XB
13084 ELSEIF(KFLB.EQ.-24) THEN
13085 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13086 & (XEE*(XB+XEE)))/XB
13087 ENDIF
13088
13089C...Calculate parton distribution weights and sum.
13090 NTRY=0
13091 200 NTRY=NTRY+1
13092 IF(NTRY.GT.500) THEN
13093 MINT(51)=1
13094 RETURN
13095 ENDIF
13096 WTSUMC=0D0
13097 WTSUME=0D0
13098 XFBO=MAX(1D-10,XFB(KFLB))
13099 DO 210 KFL=-25,25
13100 WTSF(KFL)=XFB(KFL)/XFBO
13101 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13102 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13103 210 CONTINUE
13104 WTSUMC=MAX(0.0001D0,WTSUMC)
13105 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13106
13107C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13108 NTRY2=0
13109 220 NTRY2=NTRY2+1
13110 IF(NTRY2.GT.500) THEN
13111 MINT(51)=1
13112 RETURN
13113 ENDIF
13114 IF(MCEV.EQ.1) THEN
13115 IF(MSTP(64).LE.0) THEN
13116 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13117 ELSEIF(MSTP(64).EQ.1) THEN
13118 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13119 ELSE
13120 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13121 ENDIF
13122 ENDIF
13123 IF(MEEV.EQ.1) THEN
13124 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13125 & (PARU(101)*FWTE*WTSUME*TEMX)))
13126 ELSEIF(MEEV.EQ.2) THEN
13127 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13128 ENDIF
13129
13130C...Translate t into Q2 scale; choose between QCD and QED evolution.
13131 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13132 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13133 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13134C...Ensure that Q2 is above threshold for charm/bottom.
13135 KFLCB=IABS(KFLB)
13136 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13137 &MCEV.EQ.1) THEN
13138 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13139 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13140 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13141 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13142 ENDIF
13143 ENDIF
13144 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13145 &MEEV.EQ.2) THEN
13146 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13147 ENDIF
13148 MCE=0
13149 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13150 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13151 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13152 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13153 IF(Q2EB.GT.Q2MNE) MCE=2
13154 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13155 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13156 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13157 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13158 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13159 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13160 MCE=1
13161 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13162 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13163 ELSE
13164 MCE=2
13165 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13166 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13167 ENDIF
13168
13169C...Evolution possibly ended. Update t values.
13170 IF(MCE.EQ.0) THEN
13171 Q2B=0D0
13172 GOTO 260
13173 ELSEIF(MCE.EQ.1) THEN
13174 Q2B=Q2CB
13175 Q2REF=FQ2C*Q2B
13176 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13177 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13178 ELSE
13179 Q2B=Q2EB
13180 Q2REF=Q2B
13181 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13182 ENDIF
13183
13184C...Select flavour for branching parton.
13185 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13186 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13187 KFLA=-25
13188 240 KFLA=KFLA+1
13189 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13190 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13191 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13192 IF(KFLA.EQ.25) THEN
13193 Q2B=0D0
13194 GOTO 260
13195 ENDIF
13196
13197C...Choose z value and corrective weight.
13198 WTZ=0D0
13199C...q -> q + g or q -> q + gamma.
13200 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13201 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13202 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13203 WTZ=0.5D0*(1D0+Z**2)
13204C...q -> g + q.
13205 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13206 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13207 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13208C...f -> f + gamma.
13209 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13210 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13211 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13212 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13213 ELSE
13214 Z=XB+XB*(XEE/(1D0-XEE))*
13215 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13216 ENDIF
13217 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13218C...f -> gamma + f.
13219 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
13220 Z=XB+XB*(XEE/(1D0-XEE))*
13221 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13222 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
13223C...f -> W+- + f.
13224 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13225 Z=XB+XB*(XEE/(1D0-XEE))*
13226 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13227 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13228 & (Q2B/(Q2B+PMAS(24,1)**2))
13229C...g -> q + qbar.
13230 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13231 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13232 WTZ=1D0-2D0*Z*(1D0-Z)
13233C...g -> g + g.
13234 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13235 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13236 WTZ=(1D0-Z*(1D0-Z))**2
13237C...gamma -> f + fbar.
13238 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13239 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13240 WTZ=1D0-2D0*Z*(1D0-Z)
13241 ENDIF
13242 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13243
13244C...Option with resummation of soft gluon emission as effective z shift.
13245 IF(MCE.EQ.1) THEN
13246 IF(MSTP(65).GE.1) THEN
13247 RSOFT=6D0
13248 IF(KFLB.NE.21) RSOFT=8D0/3D0
13249 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13250 IF(Z.LE.XB) GOTO 220
13251 ENDIF
13252
13253C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13254 IF(MSTP(64).GE.2) THEN
13255 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13256 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13257 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13258 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13259 ENDIF
13260 ENDIF
13261
13262C...Remove kinematically impossible branchings.
13263 UHAT=Q2B-DSH*(1D0-Z)/Z
13264 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13265
13266C...Select phi angle of branching at random.
13267 PHIBR=PARU(2)*PYR(0)
13268
13269C...Matrix-element corrections for some processes.
13270 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13271 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13272 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13273 WTZ=WTZ*WTME/WTFF
13274 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13275 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13276 WTZ=WTZ*WTME/WTGF
13277 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13278 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13279 WTZ=WTZ*WTME/WTFG
13280 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13281 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13282 WTZ=WTZ*WTME/WTGG
13283 ENDIF
13284 ENDIF
13285
13286C...Impose angular constraint in first branching from interference
13287C...with final state partons.
13288 IF(MCE.EQ.1) THEN
13289 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13290 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13291 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13292 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13293 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13294 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13295 ENDIF
13296 ENDIF
13297
13298C...Option with angular ordering requirement.
13299 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13300 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13301 IF(THE2T.GT.THE2(JT)) GOTO 220
13302 ENDIF
13303 ENDIF
13304
13305C...Weighting with new parton distributions.
13306 MINT(105)=MINT(102+JT)
13307 MINT(109)=MINT(106+JT)
13308 VINT(120)=VINT(2+JT)
13309 IF(MINT(31).GE.2) MINT(30)=JT
13310 IF(MSTP(57).LE.1) THEN
13311 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13312 ELSE
13313 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13314 ENDIF
13315 XFBN=XFN(KFLB)
13316 IF(XFBN.LT.1D-20) THEN
13317 IF(KFLA.EQ.KFLB) THEN
13318 TEVCB=TEVCBS
13319 TEVEB=TEVEBS
13320 WTAPC(KFLB)=0D0
13321 WTAPE(KFLB)=0D0
13322 GOTO 200
13323 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13324 TEVCB=0.5D0*(TEVCBS+TEVCB)
13325 GOTO 230
13326 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13327 TEVEB=0.5D0*(TEVEBS+TEVEB)
13328 GOTO 230
13329 ELSE
13330 XFBN=1D-10
13331 XFN(KFLB)=XFBN
13332 ENDIF
13333 ENDIF
13334 DO 250 KFL=-25,25
13335 XFB(KFL)=XFN(KFL)
13336 250 CONTINUE
13337 XA=XB/Z
13338 IF(MINT(31).GE.2) MINT(30)=JT
13339 IF(MSTP(57).LE.1) THEN
13340 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13341 ELSE
13342 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13343 ENDIF
13344 XFAN=XFA(KFLA)
13345 IF(XFAN.LT.1D-20) GOTO 200
13346 WTSFA=WTSF(KFLA)
13347 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13348
13349C...Define two hard scatterers in their CM-frame.
13350 260 IF(N.EQ.NS+2) THEN
13351 DQ2(JT)=Q2B
13352 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13353 DO 280 JR=1,2
13354 I=NS+JR
13355 IF(JR.EQ.1) IPO=IPUS1
13356 IF(JR.EQ.2) IPO=IPUS2
13357 DO 270 J=1,5
13358 K(I,J)=0
13359 P(I,J)=0D0
13360 V(I,J)=0D0
13361 270 CONTINUE
13362 K(I,1)=14
13363 K(I,2)=KFLS(JR+2)
13364 K(I,4)=IPO
13365 K(I,5)=IPO
13366 P(I,3)=DPLCM*(-1)**(JR+1)
13367 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13368 P(I,5)=-SQRT(DQ2(JR))
13369 K(IPO,1)=14
13370 K(IPO,3)=I
13371 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13372 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13373 280 CONTINUE
13374
13375C...Find maximum allowed mass of timelike parton.
13376 ELSEIF(N.GT.NS+2) THEN
13377 JR=3-JT
13378 DQ2(3)=Q2B
13379 DPC(1)=P(IS(1),4)
13380 DPC(2)=P(IS(2),4)
13381 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13382 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13383 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13384 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13385 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13386 IKIN=0
13387 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13388 & 1D-10*DPD(1)) IKIN=1
13389 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13390 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13391 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13392 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13393
13394C...Generate timelike parton shower (if required).
13395 IT=N
13396 DO 290 J=1,5
13397 K(IT,J)=0
13398 P(IT,J)=0D0
13399 V(IT,J)=0D0
13400 290 CONTINUE
13401C...f -> f + g (gamma).
13402 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13403 K(IT,2)=21
13404 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13405C...f -> g (gamma, W+-) + f.
13406 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13407 K(IT,2)=KFLB
13408 IF(KFLS(JT+2).EQ.24) THEN
13409 K(IT,2)=-12
13410 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13411 K(IT,2)=12
13412 ENDIF
13413C...g (gamma) -> f + fbar, g + g.
13414 ELSE
13415 K(IT,2)=-KFLS(JT+2)
13416 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13417 ENDIF
13418 K(IT,1)=3
13419 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13420 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13421 P(IT,5)=PYMASS(K(IT,2))
13422 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13423 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13424 MSTJ48=MSTJ(48)
13425 PARJ85=PARJ(85)
13426 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13427 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13428 IF(MSTP(63).EQ.1) THEN
13429 Q2TIM=DMSMA
13430 ELSEIF(MSTP(63).EQ.2) THEN
13431 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13432 ELSE
13433 Q2TIM=DMSMA
13434 MSTJ(48)=1
13435 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13436 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13437 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13438 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13439 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13440 ENDIF
13441 CALL PYSHOW(IT,0,SQRT(Q2TIM))
13442 MSTJ(48)=MSTJ48
13443 PARJ(85)=PARJ85
13444 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13445 ENDIF
13446
13447C...Reconstruct kinematics of branching: timelike parton shower.
13448 DMS=P(IT,5)**2
13449 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13450 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13451 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13452 & (4D0*DSH*DPC(3)**2)
13453 IF(DPT2.LT.0D0) GOTO 100
13454 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13455 & DSHR)/DPC(3)-DPC(3)
13456 P(IT,1)=SQRT(DPT2)
13457 P(IT,3)=DPB(1)*(-1)**(JT+1)
13458 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13459 IF(N.GE.IT+1) THEN
13460 DPB(1)=SQRT(DPB(1)**2+DPT2)
13461 DPB(2)=SQRT(DPB(1)**2+DMS)
13462 DPB(3)=P(IT+1,3)
13463 DPB(4)=SQRT(DPB(3)**2+DMS)
13464 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13465 & DPB(1))
13466 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13467 THE=PYANGL(P(IT,3),P(IT,1))
13468 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13469 ENDIF
13470
13471C...Reconstruct kinematics of branching: spacelike parton.
13472 DO 300 J=1,5
13473 K(N+1,J)=0
13474 P(N+1,J)=0D0
13475 V(N+1,J)=0D0
13476 300 CONTINUE
13477 K(N+1,1)=14
13478 K(N+1,2)=KFLB
13479 P(N+1,1)=P(IT,1)
13480 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13481 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13482 P(N+1,5)=-SQRT(DQ2(3))
13483
13484C...Define colour flow of branching.
13485 K(IS(JT),3)=N+1
13486 K(IT,3)=N+1
13487 IM1=N+1
13488 IM2=N+1
13489C...f -> f + gamma (Z, W).
13490 IF(IABS(K(IT,2)).GE.22) THEN
13491 K(IT,1)=1
13492 ID1=IS(JT)
13493 ID2=IS(JT)
13494C...f -> gamma (Z, W) + f.
13495 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13496 ID1=IT
13497 ID2=IT
13498C...gamma -> q + qbar, g + g.
13499 ELSEIF(K(N+1,2).EQ.22) THEN
13500 ID1=IS(JT)
13501 ID2=IT
13502 IM1=ID2
13503 IM2=ID1
13504C...q -> q + g.
13505 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13506 ID1=IT
13507 ID2=IS(JT)
13508C...q -> g + q.
13509 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13510 ID1=IS(JT)
13511 ID2=IT
13512C...qbar -> qbar + g.
13513 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13514 ID1=IS(JT)
13515 ID2=IT
13516C...qbar -> g + qbar.
13517 ELSEIF(K(N+1,2).LT.0) THEN
13518 ID1=IT
13519 ID2=IS(JT)
13520C...g -> g + g; g -> q + qbar.
13521 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13522 ID1=IS(JT)
13523 ID2=IT
13524 ELSE
13525 ID1=IT
13526 ID2=IS(JT)
13527 ENDIF
13528 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13529 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13530 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13531 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13532 IF(ID1.NE.ID2) THEN
13533 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13534 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13535 ENDIF
13536 N=N+1
13537 IF(K(IT,1).EQ.1) THEN
13538 K(IT,4)=0
13539 K(IT,5)=0
13540 ENDIF
13541
13542C...Boost to new CM-frame.
13543 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13544 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13545 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13546 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13547 IR=N+(JT-1)*(IS(1)-N)
13548 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13549 & 0D0,0D0,0D0)
13550
13551C...Global statistics.
13552 MINT(352)=MINT(352)+1
13553 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13554 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13555 ENDIF
13556
13557C...Update kinematics variables.
13558 IS(JT)=N
13559 DQ2(JT)=Q2B
13560 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T
13561 DSH=DSHZ
13562
13563C...Save quantities; loop back.
13564 Q2S(JT)=Q2B
13565 DPHI(JT)=PHIBR
13566 MCESV(JT)=MCE
13567 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13568 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13569 KFLS(JT+2)=KFLS(JT)
13570 KFLS(JT)=KFLA
13571 XS(JT)=XA
13572 ZS(JT)=Z
13573 DO 310 KFL=-25,25
13574 XFS(JT,KFL)=XFA(KFL)
13575 310 CONTINUE
13576 TEVCSV(JT)=TEVCB
13577 TEVESV(JT)=TEVEB
13578 ELSE
13579 MORE(JT)=0
13580 IF(JT.EQ.1) IPU1=N
13581 IF(JT.EQ.2) IPU2=N
13582 ENDIF
13583 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13584 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13585 IF(MSTU(21).GE.1) N=NS
13586 IF(MSTU(21).GE.1) RETURN
13587 ENDIF
13588 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13589
13590C...Boost hard scattering partons to frame of shower initiators.
13591 DO 320 J=1,3
13592 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13593 320 CONTINUE
13594 K(N+2,1)=1
13595 DO 330 J=1,5
13596 P(N+2,J)=P(NS+1,J)
13597 330 CONTINUE
13598 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
13599 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
13600 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
13601 IMIN=MINT(83)+5
13602 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
13603 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
13604 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
13605
13606C...Store user information. Reset Lambda value.
13607 IF(MINT(31).LE.1) THEN
13608 K(IPU1,3)=MINT(83)+3
13609 K(IPU2,3)=MINT(83)+4
13610 ELSE
13611 K(IPU1,3)=MINT(83)+1
13612 K(IPU2,3)=MINT(83)+2
13613 ENDIF
13614 DO 340 JT=1,2
13615 MINT(12+JT)=KFLS(JT)
13616 VINT(140+JT)=XS(JT)
13617 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
13618 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
13619 340 CONTINUE
13620 PARU(112)=ALAMS
13621
13622 RETURN
13623 END
13624
13625C*********************************************************************
13626
13627C...PYPTIS
13628C...Generates pT-ordered spacelike initial-state parton showers and
13629C...trial joinings.
13630C...MODE=-1: Initialize ISR from scratch, starting from the hardest
13631C... interaction initiators at PT2NOW.
13632C...MODE= 0: Generate a trial branching on interaction MINT(36), side
13633C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
13634C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
13635C... is below PT2CUT.
13636C... (Also generate test joinings if MSTP(96)=1.)
13637C...MODE= 1: Accept stored shower branching. Update event record etc.
13638C...PT2NOW : Starting (max) PT2 scale for evolution.
13639C...PT2CUT : Lower limit for evolution.
13640C...PT2 : Result of evolution. Generated PT2 for trial emission.
13641C...IFAIL : Status return code. IFAIL=0 when all is well.
13642
13643 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
13644
13645C...Double precision and integer declarations.
13646 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13647 IMPLICIT INTEGER(I-N)
13648 INTEGER PYK,PYCHGE,PYCOMP
13649C...Parameter statement for maximum size of showers.
13650 PARAMETER (MAXNUR=1000)
13651C...Commonblocks.
13652 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13653 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13654 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13655 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13656 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13657 COMMON/PYINT1/MINT(400),VINT(400)
13658 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13659 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13660 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13661 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13662 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13663 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13664 COMMON/PYCTAG/NCT,MCT(4000,2)
13665 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13666 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13667 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
13668C...Local variables
13669 DIMENSION ZSAV(2,240),PT2SAV(2,240),
13670 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
13671 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
13672 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
13673 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
13674 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
13675C...For check on excessive weights.
13676 CHARACTER CHWT*12
13677 DATA PTEMAX /0D0/
13678 DATA WTEMAX /0D0/
13679
13680 IFAIL=-1
13681
13682C----------------------------------------------------------------------
13683C...MODE=-1: Initialize initial state showers from scratch, i.e.
13684C...starting from the hardest interaction initiators.
13685 IF (MODE.EQ.-1) THEN
13686C...Set hard scattering SHAT.
13687 SHTNOW(1)=VINT(44)
13688C...Mass thresholds and Lambda for QCD evolution.
13689 AEM2PI=PARU(101)/PARU(2)
13690 RMB=PMAS(5,1)
13691 RMC=PMAS(4,1)
13692 ALAM4=PARP(61)
13693 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13694 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13695 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
13696 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13697 RMB2=RMB**2
13698 RMC2=RMC**2
13699C...Massive quark forced creation threshold (in M**2).
13700 TMIN=1.01D0
13701C...Set upper limit for X (ensures some X left for beam remnant).
13702 XMXC=1D0-2D0*PARP(111)/VINT(1)
13703
13704 IF (MSTP(61).GE.1) THEN
13705C...Initial values: flavours, momenta, virtualities.
13706 DO 100 JS=1,2
13707 NISGEN(JS,1)=0
13708
13709C...Special kinematics check for c/b quarks (that g -> c cbar or
13710C...b bbar kinematically possible).
13711 KFLB=K(IMI(JS,1,1),2)
13712 KFLCB=IABS(KFLB)
13713 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13714C...Check PT2MAX > mQ^2
13715 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
13716 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
13717 & 'No Q creation possible.')
13718 MINT(51)=1
13719 RETURN
13720 ELSE
13721C...Check for physical z values (m == MQ / sqrt(s))
13722C...For creation diagram, x < z < (1-m)/(1+m(1-m))
13723 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
13724 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
13725 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
13726 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
13727 & 'Q creation.')
13728 MINT(51)=1
13729 RETURN
13730 ENDIF
13731 ENDIF
13732 ENDIF
13733 100 CONTINUE
13734 ENDIF
13735
13736 MINT(354)=0
13737C...Zero joining array
13738 DO 110 MJ=1,240
13739 MJOIND(1,MJ)=0
13740 MJOIND(2,MJ)=0
13741 110 CONTINUE
13742
13743C----------------------------------------------------------------------
13744C...MODE= 0: Generate a trial branching on interaction MINT(36) side
13745C...MINT(30). Store if emission PT2 scale is largest so far.
13746C...Also generate test joinings if MSTP(96)=1.
13747 ELSEIF(MODE.EQ.0) THEN
13748 IFAIL=-1
13749 MECOR=0
13750 ISUB=MINT(1)
13751 JS=MINT(30)
13752C...No shower for structureless beam
13753 IF (MINT(44+JS).EQ.1) RETURN
13754 MI=MINT(36)
13755 SHAT=VINT(44)
13756C...Absolute shower max scale = VINT(56)
13757 PT2=MIN(PT2NOW,VINT(56))
13758 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
13759C...Define for which processes ME corrections have been implemented.
13760 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13761 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
13762 & .142.OR.ISUB.EQ.144) MECOR=1
13763 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13764C...Calculate preweighting factor for ME-corrected processes.
13765 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13766 ENDIF
13767C...Basic info on daughter for which to find mother.
13768 KFLB=K(IMI(JS,MI,1),2)
13769 KFLBA=IABS(KFLB)
13770C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
13771C...second companion.
13772 KSVCB=MAX(-1,IMI(JS,MI,2))
13773C...Treat "first" companion of a pair like an ordinary sea quark
13774C...(except that creation diagram is not allowed)
13775 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
13776C...X (rescaled to [0,1])
13777 XB=XMI(JS,MI)/VINT(142+JS)
13778C...Massive quarks (use physical masses.)
13779 RMQ2=0D0
13780 MQMASS=0
13781 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
13782 RMQ2=RMC2
13783 IF (KFLBA.EQ.5) RMQ2=RMB2
13784C...Special threshold treatment for non-photon beams
13785 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
13786 ENDIF
13787
13788C...Flags for parton distribution calls.
13789 MINT(105)=MINT(102+JS)
13790 MINT(109)=MINT(106+JS)
13791 VINT(120)=VINT(2+JS)
13792
13793C...Calculate initial parton distribution weights.
13794 IF(XB.GE.XMXC) THEN
13795 RETURN
13796 ELSEIF(MQMASS.EQ.0) THEN
13797 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
13798 ELSE
13799C...Initialize massive quark PT2 dependent pdf underestimate.
13800 PT20=PT2
13801 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
13802C.!.Tentative treatment of massive valence quarks.
13803 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
13804 XG0=XFB(21)
13805 TPM0=LOG(PT20/RMQ2)
13806 WPDF0=TPM0*XG0/XQ0
13807 ENDIF
13808 IF (KFLB.NE.21) THEN
13809C...For quarks, only include respective sea, val, or cmp part.
13810 IF (KSVCB.LE.0) THEN
13811 XFB(KFLB)=XPSVC(KFLB,KSVCB)
13812 ELSE
13813C...Find companion's companion
13814 MISEA=0
13815 120 MISEA=MISEA+1
13816 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
13817 XS=XMI(JS,MISEA)
13818 XREM=VINT(142+JS)
13819 YS=XS/(XREM+XS)
13820C...Momentum fraction of the companion quark.
13821C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
13822 YB=XB*(1D0-YS)
13823 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
13824 ENDIF
13825 ENDIF
13826
13827C...Determine overestimated z range: switch at c and b masses.
13828 130 IF (PT2.GT.TMIN*RMB2) THEN
13829 IZRG=3
13830 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
13831 B0=23D0/6D0
13832 ALAM2=ALAM5**2
13833 ELSEIF(PT2.GT.TMIN*RMC2) THEN
13834 IZRG=2
13835 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
13836 B0=25D0/6D0
13837 ALAM2=ALAM4**2
13838 ELSE
13839 IZRG=1
13840 PT2MNE=PT2CUT
13841 B0=27D0/6D0
13842 ALAM2=ALAM3**2
13843 ENDIF
13844C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
13845 ALAM2=ALAM2/PARP(64)
13846C...Overestimated ZMAX:
13847 IF (MQMASS.EQ.0) THEN
13848C...Massless
13849 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
13850 & /PT2MNE)-1D0)
13851 ELSE
13852C...Massive (limit for bremsstrahlung diagram > creation)
13853 FMQ=SQRT(RMQ2/SHTNOW(MI))
13854 ZMAX=1D0/(1D0+FMQ)
13855 ENDIF
13856 ZMIN=XB/XMXC
13857
13858C...If kinematically impossible then do not evolve.
13859 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
13860
13861C...Reset Altarelli-Parisi and PDF weights.
13862 DO 140 KFL=-5,5
13863 WTAP(KFL)=0D0
13864 WTPDF(KFL)=0D0
13865 140 CONTINUE
13866 WTAP(21)=0D0
13867 WTPDF(21)=0D0
13868C...Zero joining weights and compute X(partner) and X(mother) values.
13869 IF (MSTP(96).NE.0) THEN
13870 NJN=0
13871 DO 150 MJ=1,MINT(31)
13872 WTAPJ(MJ)=0D0
13873 WTPDFJ(MJ)=0D0
13874 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
13875 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
13876 & +XMI(JS,MI))
13877 150 CONTINUE
13878 ENDIF
13879
13880C...Approximate Altarelli-Parisi weights (integrated AP dz).
13881C...q -> q, g -> q or q -> q + gamma (already set which).
13882 IF(KFLBA.LE.5) THEN
13883C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
13884 IF (KSVCB.LT.0) THEN
13885 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
13886 ELSE
13887 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
13888 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
13889 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
13890 ENDIF
13891 WTAP(21)=0.5D0*(ZMAX-ZMIN)
13892 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
13893 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
13894 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
13895 WTAP(KFLB)=WTFF*WTAP(KFLB)
13896 WTAP(21)=WTGF*WTAP(21)
13897 WTAPE=WTFF*WTAPE
13898 ENDIF
13899 IF (KSVCB.GE.1) THEN
13900C...Kill normal creation but add joining diagrams for cmp quark.
13901 WTAP(21)=0D0
13902 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
13903 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
13904 & " quark here. Not handled yet, giving up!")
13905 PT2=0D0
13906 MINT(51)=1
13907 RETURN
13908 ENDIF
13909C...Check for possible joinings
13910 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
13911C...Find companion's companion.
13912 MJ=0
13913 160 MJ=MJ+1
13914 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
13915 IF (MJOIND(JS,MJ).EQ.0) THEN
13916 Y(MI)=YB+YS
13917 Z=YB/Y(MI)
13918 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
13919 IF (WTAPJ(MJ).GT.1D-6) THEN
13920 NJN=1
13921 ELSE
13922 WTAPJ(MJ)=0D0
13923 ENDIF
13924 ENDIF
13925C...Add trial gluon joinings.
13926 DO 170 MJ=1,MINT(31)
13927 KFLC=K(IMI(JS,MJ,1),2)
13928 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
13929 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
13930 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
13931 IF (WTAPJ(MJ).GT.1D-6) THEN
13932 NJN=NJN+1
13933 ELSE
13934 WTAPJ(MJ)=0D0
13935 ENDIF
13936 170 CONTINUE
13937 ENDIF
13938 ELSEIF (IMI(JS,MI,2).GE.0) THEN
13939C...Kill creation diagram for val quarks and sea quarks with companions.
13940 WTAP(21)=0D0
13941 ELSEIF (MQMASS.EQ.0) THEN
13942C...Extra safety factor for massless sea quark creation.
13943 WTAP(21)=WTAP(21)*1.25D0
13944 ENDIF
13945
13946C... q -> g, g -> g.
13947 ELSEIF(KFLB.EQ.21) THEN
13948C...Here we decide later whether a quark picked up is valence or
13949C...sea, so we maintain the extra factor sqrt(z) since we deal
13950C...with the *sum* of sea and valence in this context.
13951 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
13952C...new: do not allow backwards evol to pick up heavy flavour.
13953 DO 180 KFL=1,MIN(3,MSTP(58))
13954 WTAP(KFL)=WTAPQ
13955 WTAP(-KFL)=WTAPQ
13956 180 CONTINUE
13957 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
13958 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
13959 WTAPQ=WTFG*WTAPQ
13960 WTAP(21)=WTGG*WTAP(21)
13961 ENDIF
13962C...Check for possible joinings (companions handled separately above)
13963 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
13964 & THEN
13965 DO 190 MJ=1,MINT(31)
13966 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
13967 KSVCC=IMI(JS,MJ,2)
13968 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
13969 IF (KSVCC.GE.1) GOTO 190
13970 KFLC=K(IMI(JS,MJ,1),2)
13971C...Only try g -> g + g once.
13972 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
13973 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
13974 IF (KFLC.EQ.21) THEN
13975 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
13976 ELSE
13977 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
13978 ENDIF
13979 IF (WTAPJ(MJ).GT.1D-6) THEN
13980 NJN=NJN+1
13981 ELSE
13982 WTAPJ(MJ)=0D0
13983 ENDIF
13984 190 CONTINUE
13985 ENDIF
13986 ENDIF
13987
13988C...Initialize massive quark evolution
13989 IF (MQMASS.NE.0) THEN
13990 RML=(RMQ2+VINT(18))/ALAM2
13991 TML=LOG(RML)
13992 TPL=LOG((PT2+VINT(18))/ALAM2)
13993 TPM=LOG((PT2+VINT(18))/RMQ2)
13994 WN=WTAP(21)*WPDF0/B0
13995 ENDIF
13996
13997
13998C...Loopback point for iteration
13999 NTRY=0
14000 NTHRES=0
14001 200 NTRY=NTRY+1
14002 IF(NTRY.GT.500) THEN
14003 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14004 MINT(51)=1
14005 RETURN
14006 ENDIF
14007
14008C... Calculate PDF weights and sum for evolution rate.
14009 WTSUM=0D0
14010 XFBO=MAX(1D-10,XFB(KFLB))
14011 DO 210 KFL=-5,5
14012 WTPDF(KFL)=XFB(KFL)/XFBO
14013 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14014 210 CONTINUE
14015C...Only add gluon mother diagram for massless KFLB.
14016 IF(MQMASS.EQ.0) THEN
14017 WTPDF(21)=XFB(21)/XFBO
14018 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14019 ENDIF
14020 WTSUM=MAX(0.0001D0,WTSUM)
14021 WTSUMS=WTSUM
14022C...Add joining diagrams where applicable.
14023 WTJOIN=0D0
14024 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14025 DO 220 MJ=1,MINT(31)
14026 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14027 WTPDFJ(MJ)=1D0/XFBO
14028C...x and x*pdf (+ sea/val) for parton C.
14029 KFLC=K(IMI(JS,MJ,1),2)
14030 KFLCA=IABS(KFLC)
14031 KSVCC=MAX(-1,IMI(JS,MJ,2))
14032 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14033 MINT(30)=JS
14034 MINT(36)=MJ
14035 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14036 MINT(36)=MI
14037 IF (KFLC.NE.21.AND.KSVCC.LE.0) THEN
14038 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14039 ELSEIF (KSVCC.GE.1) THEN
14040 print*, 'error! parton C is companion!'
14041 ENDIF
14042 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14043C...x and x*pdf (+ sea/val) for parton A.
14044 KFLA=21
14045 KSVCA=0
14046 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14047 KFLA=KFLB
14048 KSVCA=KSVCB
14049 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14050 KFLA=KFLC
14051 KSVCA=KSVCC
14052 ENDIF
14053 MINT(30)=JS
14054 IF (KSVCA.LE.0) THEN
14055C...Consider C the "evolved" parton if B is gluon. Val/sea
14056C...counting will then be done correctly in PYPDFU.
14057 IF (KFLBA.EQ.21) MINT(36)=MJ
14058 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14059 MINT(36)=MI
14060 IF (KFLA.NE.21) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14061 ELSE
14062C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14063 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14064 ENDIF
14065 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14066 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14067 220 CONTINUE
14068 ENDIF
14069
14070C...Pick normal pT2 (in overestimated z range).
14071 230 PT2OLD=PT2
14072 WTSUM=WTSUMS
14073 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14074 KFLC=21
14075
14076C...Evolve q -> q gamma separately, pick it if larger pT.
14077 IF(KFLBA.LE.5) THEN
14078 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14079 IF(PT2QED.GT.PT2) THEN
14080 PT2=PT2QED
14081 KFLC=22
14082 KFLA=KFLB
14083 ENDIF
14084 ENDIF
14085
14086C... Evolve massive quark creation separately.
14087 MCRQQ=0
14088 IF (MQMASS.NE.0) THEN
14089 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14090 & -VINT(18)
14091C... Ensure mininimum PT2CR and force creation near threshold.
14092 IF (PT2CR.LT.TMIN*RMQ2) THEN
14093 NTHRES=NTHRES+1
14094 IF (NTHRES.GT.50) THEN
14095 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14096 & 'massive quark creation. Gave up trying.')
14097 MINT(51)=1
14098 RETURN
14099 ENDIF
14100 PT2=0D0
14101 PT2CR=TMIN*RMQ2
14102 MCRQQ=2
14103 ENDIF
14104C... Select largest PT2 (brems or creation):
14105 IF (PT2CR.GT.PT2) THEN
14106 MCRQQ=MAX(MCRQQ,1)
14107 WTSUM=0D0
14108 PT2=PT2CR
14109 KFLA=21
14110 ELSE
14111 MCRQQ=0
14112 KFLA=KFLB
14113 ENDIF
14114C... Compute logarithms for this PT2
14115 TPL=LOG((PT2+VINT(18))/ALAM2)
14116 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14117 WTCRQQ=TPM/LOG(PT2/RMQ2)
14118 ENDIF
14119
14120C...Evolve joining separately
14121 MJOIN=0
14122 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14123 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14124 & -VINT(18)
14125 IF (PT2JN.GE.PT2) THEN
14126 MJOIN=1
14127 PT2=PT2JN
14128 ENDIF
14129 ENDIF
14130
14131C...Loopback if crossed c/b mass thresholds.
14132 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14133 PT2=RMB2
14134 GOTO 130
14135 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14136 PT2=RMC2
14137 GOTO 130
14138 ENDIF
14139
14140C...Speed up shower. Skip if higher-PT acceptable branching
14141C...already found somewhere else.
14142C...Also finish if below lower cutoff.
14143
14144 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14145
14146C...Select parton A flavour (massive Q handled above.)
14147 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14148 WTRAN=PYR(0)*WTSUM
14149 KFLA=-6
14150 240 KFLA=KFLA+1
14151 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14152 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14153 IF(KFLA.EQ.6) KFLA=21
14154 ELSEIF (MJOIN.EQ.1) THEN
14155C...Tentative joining accept/reject.
14156 WTRAN=PYR(0)*WTJOIN
14157 MJ=0
14158 250 MJ=MJ+1
14159 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14160 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14161 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14162 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14163 & ' Rejected.')
14164 GOTO 230
14165 ENDIF
14166C...x*pdf (+ sea/val) at new pT2 for parton B.
14167 IF (KSVCB.LE.0) THEN
14168 MINT(30)=JS
14169 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14170 IF (KFLB.NE.21) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14171 ELSE
14172C...Companion distributions do not evolve.
14173 XFB(KFLB)=XFBO
14174 ENDIF
14175 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14176 KFLC=K(IMI(JS,MJ,1),2)
14177 KFLCA=IABS(KFLC)
14178 KSVCC=MAX(-1,IMI(JS,MJ,2))
14179 IF (KSVCB.GE.1) KSVCC=-1
14180C...x*pdf (+ sea/val) at new pT2 for parton C.
14181 MINT(30)=JS
14182 MINT(36)=MJ
14183 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14184 MINT(36)=MI
14185 IF (KFLC.NE.21.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14186 WTVETO=WTVETO/XFJ(KFLC)
14187C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14188 KFLA=21
14189 KSVCA=0
14190 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14191 KFLA=KFLB
14192 KSVCA=KSVCB
14193 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14194 KFLA=KFLC
14195 KSVCA=KSVCC
14196 ENDIF
14197 IF (KSVCA.LE.0) THEN
14198 MINT(30)=JS
14199 IF (KFLB.EQ.21) MINT(36)=MJ
14200 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14201 MINT(36)=MI
14202 IF (KFLA.NE.21) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14203 ELSE
14204 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14205 ENDIF
14206 WTVETO=WTVETO*XFJ(KFLA)
14207C...Monte Carlo veto.
14208 IF (WTVETO.LT.PYR(0)) GOTO 200
14209C...If accept, save PT2 of this joining.
14210 IF (PT2.GT.PT2MX) THEN
14211 PT2MX=PT2
14212 JSMX=2+JS
14213 MJN1MX=MJ
14214 MJN2MX=MI
14215 WTAPJ(MJ)=0D0
14216 NJN=0
14217 ENDIF
14218C...Exit and continue evolution.
14219 GOTO 380
14220 ENDIF
14221 KFLAA=IABS(KFLA)
14222
14223C...Choose z value (still in overestimated range) and corrective weight.
14224C...Unphysical z will be rejected below when Q2 has is computed.
14225 WTZ=0D0
14226
14227C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14228C...q -> q + g or q -> q + gamma (already set which).
14229 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14230 IF (KSVCB.LT.0) THEN
14231 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14232 ELSE
14233 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14234 Z=((1-ZFAC)/(1+ZFAC))**2
14235 ENDIF
14236 WTZ=0.5D0*(1D0+Z**2)
14237C...Massive weight correction.
14238 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14239C...Valence quark weight correction (extra sqrt)
14240 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14241
14242C...q -> g + q.
14243C...NB: MQ>0 not yet implemented. Forced absent above.
14244 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14245 KFLC=KFLA
14246 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14247 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14248
14249C...g -> q + qbar.
14250 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14251 KFLC=-KFLB
14252 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14253 WTZ=Z**2+(1D0-Z)**2
14254C...Massive correction
14255 IF (MQMASS.NE.0) THEN
14256 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14257C...Extra safety margin for light sea quark creation
14258 ELSEIF (KSVCB.LT.0) THEN
14259 WTZ=WTZ/1.25D0
14260 ENDIF
14261
14262C...g -> g + g.
14263 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14264 KFLC=21
14265 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14266 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14267 WTZ=(1D0-Z*(1D0-Z))**2
14268 ENDIF
14269
14270C...Derive Q2 from pT2.
14271 Q2B=PT2/(1D0-Z)
14272 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14273
14274C...Loopback if outside allowed z range for given pT2.
14275 RM2C=PYMASS(KFLC)**2
14276 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14277 IF (PT2ADJ.LT.1D-6) GOTO 230
14278
14279C...Loopback if nonordered in angle/rapidity.
14280 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14281 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14282 & GOTO 230
14283 ENDIF
14284
14285C...Select phi angle of branching at random.
14286 PHI=PARU(2)*PYR(0)
14287
14288C...Matrix-element corrections for some processes.
14289 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14290 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14291 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14292 WTZ=WTZ*WTME/WTFF
14293 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14294 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14295 WTZ=WTZ*WTME/WTGF
14296 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14297 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14298 WTZ=WTZ*WTME/WTFG
14299 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14300 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14301 WTZ=WTZ*WTME/WTGG
14302 ENDIF
14303 ENDIF
14304
14305C...Parton distributions at new pT2 but old x.
14306 MINT(30)=JS
14307 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14308C...Treat val and cmp separately
14309 IF (KFLB.NE.21.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14310 IF (KSVCB.GE.1)
14311 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14312 XFBN=XFN(KFLB)
14313 IF(XFBN.LT.1D-20) THEN
14314 IF(KFLA.EQ.KFLB) THEN
14315 WTAP(KFLB)=0D0
14316 GOTO 200
14317 ELSE
14318 XFBN=1D-10
14319 XFN(KFLB)=XFBN
14320 ENDIF
14321 ENDIF
14322 DO 260 KFL=-5,5
14323 XFB(KFL)=XFN(KFL)
14324 260 CONTINUE
14325 XFB(21)=XFN(21)
14326
14327C...Parton distributions at new pT2 and new x.
14328 XA=XB/Z
14329 MINT(30)=JS
14330 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14331 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14332C...q -> q + g: only consider respective sea, val, or cmp content.
14333 IF (KSVCB.LE.0) THEN
14334 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14335 ELSE
14336 YA=XA*(1D0-YS)
14337 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14338 ENDIF
14339 ENDIF
14340 XFAN=XFA(KFLA)
14341 IF(XFAN.LT.1D-20) THEN
14342 GOTO 200
14343 ENDIF
14344
14345C...If weighting fails continue evolution.
14346 WTTOT=0D0
14347 IF (MCRQQ.EQ.0) THEN
14348 WTPDFA=1D0/WTPDF(KFLA)
14349 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14350 ELSEIF(MCRQQ.EQ.1) THEN
14351 WTPDFA=TPM/WPDF0
14352 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14353 XBEST=TPM/TPM0*XQ0
14354 ELSEIF(MCRQQ.EQ.2) THEN
14355C...Force massive quark creation.
14356 WTTOT=1D0
14357 ENDIF
14358
14359C...Loop back if trial emission fails.
14360 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14361 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14362 IF(WTTOT.LT.0D0) THEN
14363 WRITE(CHWT,'(1P,E12.4)') WTTOT
14364 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14365 ELSEIF(WTTOT.GT.WTACC) THEN
14366 WRITE(CHWT,'(1P,E12.4)') WTTOT
14367 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14368C...Too high weight: write out as error, but do not update error counter.
14369 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14370 CALL PYERRM(19,
14371 & '(PYPTIS:) Weight '//CHWT//' above unity')
14372 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14373 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14374 ELSE
14375 CALL PYERRM(9,
14376 & '(PYPTIS:) Weight '//CHWT//' above unity')
14377 ENDIF
14378C...Useful for debugging but commented out for distribution:
14379C print*, 'JS, MI',JS, MI
14380C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14381C print*, 'A -> B C',KFLA, KFLB, KFLC
14382C XFAO=XFBO/WTPDFA
14383C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14384 ENDIF
14385
14386C...Save acceptable branching.
14387 IF(PT2.GT.PT2MX) THEN
14388 MIMX=MINT(36)
14389 JSMX=JS
14390 PT2MX=PT2
14391 KFLAMX=KFLA
14392 KFLCMX=KFLC
14393 RM2CMX=RM2C
14394 Q2BMX=Q2B
14395 ZMX=Z
14396 PT2AMX=PT2ADJ
14397 PHIMX=PHI
14398 ENDIF
14399
14400C----------------------------------------------------------------------
14401C...MODE= 1: Accept stored shower branching. Update event record etc.
14402 ELSEIF (MODE.EQ.1) THEN
14403 MI=MIMX
14404 JS=JSMX
14405 SHAT=SHTNOW(MI)
14406 SIDE=3D0-2D0*JS
14407C...Shift down rest of event record to make room for insertion.
14408 IT=IMISEP(MI)+1
14409 IM=IT+1
14410 IS=IMI(JS,MI,1)
14411 DO 280 I=N,IT,-1
14412 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14413 KT1=K(I,4)/MSTU(5)**2
14414 KT2=K(I,5)/MSTU(5)**2
14415 ID1=MOD(K(I,4),MSTU(5))
14416 ID2=MOD(K(I,5),MSTU(5))
14417 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14418 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14419 IF (ID1.GE.IT) ID1=ID1+2
14420 IF (ID2.GE.IT) ID2=ID2+2
14421 IF (IM1.GE.IT) IM1=IM1+2
14422 IF (IM2.GE.IT) IM2=IM2+2
14423 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14424 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14425 DO 270 IX=1,5
14426 K(I+2,IX)=K(I,IX)
14427 P(I+2,IX)=P(I,IX)
14428 V(I+2,IX)=V(I,IX)
14429 270 CONTINUE
14430 MCT(I+2,1)=MCT(I,1)
14431 MCT(I+2,2)=MCT(I,2)
14432 280 CONTINUE
14433 N=N+2
14434C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14435 DO 290 JI=1,MINT(31)
14436 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14437 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14438 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14439 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14440 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14441C...Also update companion pointers to the present mother.
14442 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14443 290 CONTINUE
14444 DO 300 IFS=1,NPART
14445 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14446 300 CONTINUE
14447C...Zero entries dedicated for new timelike and mother partons.
14448 DO 320 I=IT,IT+1
14449 DO 310 J=1,5
14450 K(I,J)=0
14451 P(I,J)=0D0
14452 V(I,J)=0D0
14453 310 CONTINUE
14454 MCT(I,1)=0
14455 MCT(I,2)=0
14456 320 CONTINUE
14457
14458C...Define timelike and new mother partons. History.
14459 K(IT,1)=3
14460 K(IT,2)=KFLCMX
14461 K(IM,1)=14
14462 K(IM,2)=KFLAMX
14463 K(IS,3)=IM
14464 K(IT,3)=IM
14465C...Set mother origin = side.
14466 K(IM,3)=MINT(83)+JS+2
14467 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14468
14469C...Define colour flow of branching.
14470 IM1=IM
14471 IM2=IM
14472C...q -> q + gamma.
14473 IF(K(IT,2).EQ.22) THEN
14474 K(IT,1)=1
14475 ID1=IS
14476 ID2=IS
14477C...q -> q + g.
14478 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14479 ID1=IT
14480 ID2=IS
14481C...q -> g + q.
14482 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14483 ID1=IS
14484 ID2=IT
14485C...qbar -> qbar + g.
14486 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14487 ID1=IS
14488 ID2=IT
14489C...qbar -> g + qbar.
14490 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14491 ID1=IT
14492 ID2=IS
14493C...g -> g + g; g -> q + qbar..
14494 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14495 ID1=IS
14496 ID2=IT
14497 ELSE
14498 ID1=IT
14499 ID2=IS
14500 ENDIF
14501 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14502 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14503 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14504 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14505 IF(ID1.NE.ID2) THEN
14506 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14507 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14508 ENDIF
14509 IF(K(IT,1).EQ.1) THEN
14510 K(IT,4)=0
14511 K(IT,5)=0
14512 ENDIF
14513C...Update IMI and colour tag arrays.
14514 IMI(JS,MI,1)=IM
14515 DO 330 MC=1,2
14516 MCT(IT,MC)=0
14517 MCT(IM,MC)=0
14518 330 CONTINUE
14519 DO 340 JCS=4,5
14520 KCS=JCS
14521C...If mother flag not yet set for spacelike parton, trace it.
14522 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14523 IF(MINT(51).NE.0) RETURN
14524 340 CONTINUE
14525 DO 350 JCS=4,5
14526 KCS=JCS
14527C...If mother flag not yet set for timelike parton, trace it.
14528 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14529 IF(MINT(51).NE.0) RETURN
14530 350 CONTINUE
14531
14532C...Boost recoiling parton to compensate for Q2 scale.
14533C...(Also update recoiler in documentation lines, if necessary.)
14534 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14535 & (1D0+(1D0+Q2BMX/SHAT)**2)
14536 IR=IMI(3-JS,MI,1)
14537 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14538 IF (IR.EQ.MINT(84)+3-JS) CALL PYROBO(MINT(83)+7-JS,MINT(83)
14539 & +7-JS,0D0,0D0,0D0,0D0,BETAZ)
14540
14541C...Rotate back system in phi to compensate for subsequent rotation.
14542C...(not including the just added partons.)
14543 IMIN=IMISEP(MI-1)+1
14544 IF (MI.EQ.1) IMIN=MINT(83)+5
14545 IMAX=IMISEP(MI)-2
14546 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14547
14548C...Define kinematics of new partons in old frame.
14549 IMAX=IMISEP(MI)
14550 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14551 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14552 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14553 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14554 P(IT,1)=P(IM,1)
14555 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14556 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14557 P(IT,5)=SQRT(RM2CMX)
14558
14559C...Boost and rotate to new frame.
14560 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14561 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14562 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14563 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14564 MINT(51)=1
14565 IFAIL=-1
14566 RETURN
14567 ENDIF
14568 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14569 I1=IMI(1,MI,1)
14570 THETA=PYANGL(P(I1,3),P(I1,1))
14571 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14572
14573C...Global statistics.
14574 MINT(352)=MINT(352)+1
14575 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14576 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14577
14578C...Add parton with relevant pT scale for timelike shower.
14579 IF (K(IT,2).NE.22) THEN
14580 NPART=NPART+1
14581 IPART(NPART)=IT
14582 PTPART(NPART)=SQRT(PT2AMX)
14583 ENDIF
14584
14585C...Update saved variables.
14586 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
14587 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
14588 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
14589 PT2SAV(JSMX,MIMX)=PT2MX
14590 ZSAV(JS,MIMX)=ZMX
14591
14592 KSA=IABS(K(IS,2))
14593 KMA=IABS(K(IM,2))
14594 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
14595C...Gluon reconstructs to quark.
14596C...Decide whether newly created quark is valence or sea:
14597 MINT(30)=JS
14598 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
14599 IF(MINT(51).NE.0) RETURN
14600 ENDIF
14601 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
14602C...Quark reconstructs to gluon.
14603C...Now some guy may have lost his companion. Check.
14604 ICMP=IMI(JS,MI,2)
14605 IF (ICMP.GT.0) THEN
14606 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
14607 & //' away. Cannot handle that yet. Giving up.')
14608 MINT(51)=1
14609 RETURN
14610 ELSEIF(ICMP.LT.0) THEN
14611C...A sea quark with companion still in BR was reconstructed to a gluon.
14612C...Companion should now be removed from the beam remnant.
14613C...(Momentum integral is automatically updated in next call to PYPDFU.)
14614 ICMP=-ICMP
14615 IFL=-K(IS,2)
14616 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
14617 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
14618 DO 360 JI=1,MINT(31)
14619 KMI=-IMI(JS,JI,2)
14620 JFL=-K(IMI(JS,JI,1),2)
14621 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
14622 & ,2)+1
14623 360 CONTINUE
14624 370 CONTINUE
14625 NVC(JS,IFL)=NVC(JS,IFL)-1
14626 ENDIF
14627C...Set gluon IMI(JS,MI,2) = 0.
14628 IMI(JS,MI,2)=0
14629 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
14630C...Quark reconstructing to quark. If sea with companion still in BR
14631C...then update associated x value.
14632C...(Momentum integral is automatically updated in next call to PYPDFU.)
14633 IF (IMI(JS,MI,2).LT.0) THEN
14634 ICMP=-IMI(JS,MI,2)
14635 IFL=-K(IS,2)
14636 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
14637 ENDIF
14638 ENDIF
14639
14640 ENDIF
14641
14642C...If reached this point, normal exit.
14643 380 IFAIL=0
14644
14645 RETURN
14646 END
14647
14648C*********************************************************************
14649
14650C...PYMEMX
14651C...Generates maximum ME weight in some initial-state showers.
14652C...Inparameter MECOR: kind of hard scattering process
14653C...Outparameter WTFF: maximum weight for fermion -> fermion
14654C... WTGF: maximum weight for gluon/photon -> fermion
14655C... WTFG: maximum weight for fermion -> gluon/photon
14656C... WTGG: maximum weight for gluon -> gluon
14657
14658 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14659
14660C...Double precision and integer declarations.
14661 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14662 IMPLICIT INTEGER(I-N)
14663 INTEGER PYK,PYCHGE,PYCOMP
14664C...Commonblocks.
14665 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14666 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14667 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14668 COMMON/PYINT1/MINT(400),VINT(400)
14669 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14670 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
14671
14672C...Default maximum weight.
14673 WTFF=1D0
14674 WTGF=1D0
14675 WTFG=1D0
14676 WTGG=1D0
14677
14678C...Select maximum weight by process.
14679 IF(MECOR.EQ.1) THEN
14680 WTFF=1D0
14681 WTGF=3D0
14682 ELSEIF(MECOR.EQ.2) THEN
14683 WTFG=1D0
14684 WTGG=1D0
14685 ENDIF
14686
14687 RETURN
14688 END
14689
14690C*********************************************************************
14691
14692C...PYMEWT
14693C...Calculates actual ME weight in some initial-state showers.
14694C...Inparameter MECOR: kind of hard scattering process
14695C... IFLCB: flavour combination of branching,
14696C... 1 for fermion -> fermion,
14697C... 2 for gluon/photon -> fermion
14698C... 3 for fermion -> gluon/photon,
14699C... 4 for gluon -> gluon
14700C... Q2: Q2 value of shower branching
14701C... Z: Z value of branching
14702C...In+outparameter PHIBR: azimuthal angle of branching
14703C...Outparameter WTME: actual ME weight
14704
14705 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
14706
14707C...Double precision and integer declarations.
14708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14709 IMPLICIT INTEGER(I-N)
14710 INTEGER PYK,PYCHGE,PYCOMP
14711C...Commonblocks.
14712 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14714 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14715 COMMON/PYINT1/MINT(400),VINT(400)
14716 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14717 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
14718
14719C...Default output.
14720 WTME=1D0
14721
14722C...Define kinematics of shower branching in Mandelstam variables.
14723 SQM=VINT(44)
14724 SH=SQM/Z
14725 TH=-Q2
14726 UH=Q2-SQM*(1D0-Z)/Z
14727
14728C...Matrix-element corrections for f + fbar -> s-channel vector boson.
14729 IF(MECOR.EQ.1) THEN
14730 IF(IFLCB.EQ.1) THEN
14731 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
14732 ELSEIF(IFLCB.EQ.2) THEN
14733 WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2)
14734 ENDIF
14735
14736C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
14737 ELSEIF(MECOR.EQ.2) THEN
14738 IF(IFLCB.EQ.3) THEN
14739 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
14740 ELSEIF(IFLCB.EQ.4) THEN
14741 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
14742 ENDIF
14743 ENDIF
14744
14745 RETURN
14746 END
14747
14748C*********************************************************************
14749
14750C...PYPTMI
14751C...Handles the generation of additional interactions in the new
14752C...multiple interactions framework.
14753C...MODE=-1 : Initalize MI from scratch.
14754C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
14755C... Sudakov for PT2, abort if below PT2CUT.
14756C...MODE= 1 : Accept interaction at PT2NOW and store variables.
14757C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
14758C...PT2NOW : Starting (max) PT2 scale for evolution.
14759C...PT2CUT : Lower limit for evolution.
14760C...PT2 : Result of evolution. Generated PT2 for trial interaction.
14761C...IFAIL : Status return code.
14762C... = 0: All is well.
14763C... < 0: Phase space exhausted, generation to be terminated.
14764C... > 0: Additional interaction vetoed, but continue evolution.
14765
14766 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14767C...Double precision and integer declarations.
14768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14769 IMPLICIT INTEGER(I-N)
14770 INTEGER PYK,PYCHGE,PYCOMP
14771C...Parameter statement for maximum size of showers.
14772 PARAMETER (MAXNUR=1000)
14773C...Commonblocks.
14774 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14775 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14776 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14777 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14778 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
14779 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14780 COMMON/PYINT1/MINT(400),VINT(400)
14781 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14782 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
14783 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
14784 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
14785 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14786 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14787 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14788 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14789 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14790 COMMON/PYCTAG/NCT,MCT(4000,2)
14791C...Local arrays and saved variables.
14792 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
14793
14794 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
14795 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
14796 & /PYISMX/,/PYCTAG/
14797 SAVE XT2FAC,SIGS
14798
14799 IFAIL=0
14800C...Set MI subprocess = QCD 2 -> 2.
14801 ISUB=96
14802
14803C----------------------------------------------------------------------
14804C...MODE=-1: Initialize from scratch
14805 IF (MODE.EQ.-1) THEN
14806C...Initialize PT2 array.
14807 PT2MI(1)=VINT(54)
14808C...Initialize list of incoming beams and partons from two sides.
14809 DO 110 JS=1,2
14810 DO 100 MI=1,240
14811 IMI(JS,MI,1)=0
14812 IMI(JS,MI,2)=0
14813 100 CONTINUE
14814 NMI(JS)=1
14815 IMI(JS,1,1)=MINT(84)+JS
14816 IMI(JS,1,2)=0
14817 XMI(JS,1)=VINT(40+JS)
14818C...Rescale x values to fractions of photon energy.
14819 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
14820C...Hard reset: hard interaction initiators motherless by definition.
14821 K(MINT(84)+JS,3)=2+JS
14822 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
14823 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
14824 110 CONTINUE
14825 IMISEP(0)=MINT(84)
14826 IMISEP(1)=N
14827 IF (MOD(MSTP(81),10).GE.1) THEN
14828 IF(MSTP(82).LE.1) THEN
14829 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
14830 & ,5))
14831 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
14832 & VINT(317)/(VINT(318)*VINT(320))
14833 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
14834 ELSE
14835 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
14836 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
14837 ENDIF
14838 ENDIF
14839C...Zero entries relating to scatterings beyond the first.
14840 DO 120 MI=2,240
14841 IMI(1,MI,1)=0
14842 IMI(2,MI,1)=0
14843 IMI(1,MI,2)=0
14844 IMI(2,MI,2)=0
14845 IMISEP(MI)=IMISEP(1)
14846 PT2MI(MI)=0D0
14847 XMI(1,MI)=0D0
14848 XMI(2,MI)=0D0
14849 120 CONTINUE
14850C...Initialize factors for PDF reshaping.
14851 DO 140 JS=1,2
14852 KFBEAM(JS)=MINT(10+JS)
14853 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
14854 KFABM=IABS(KFBEAM(JS))
14855 KFSBM=ISIGN(1,KFBEAM(JS))
14856
14857C...Zero flavour content of incoming beam particle.
14858 KFIVAL(JS,1)=0
14859 KFIVAL(JS,2)=0
14860 KFIVAL(JS,3)=0
14861C... Flavour content of baryon.
14862 IF(KFABM.GT.1000) THEN
14863 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
14864 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
14865 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
14866C... Flavour content of pi+-, K+-.
14867 ELSEIF(KFABM.EQ.211) THEN
14868 KFIVAL(JS,1)=KFSBM*2
14869 KFIVAL(JS,2)=-KFSBM
14870 ELSEIF(KFABM.EQ.321) THEN
14871 KFIVAL(JS,1)=-KFSBM*3
14872 KFIVAL(JS,2)=KFSBM*2
14873C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
14874 ENDIF
14875
14876C...Zero initial valence and companion content.
14877 DO 130 IFL=-6,6
14878 NVC(JS,IFL)=0
14879 130 CONTINUE
14880 140 CONTINUE
14881C...Set up colour line tags starting from hard interaction initiators.
14882 NCT=0
14883C...Reset colour tag array and colour processing flags.
14884 DO 150 I=IMISEP(0)+1,N
14885 MCT(I,1)=0
14886 MCT(I,2)=0
14887 K(I,4)=MOD(K(I,4),MSTU(5)**2)
14888 K(I,5)=MOD(K(I,5),MSTU(5)**2)
14889 150 CONTINUE
14890C... Consider each side in turn.
14891 DO 170 JS=1,2
14892 I1=IMI(JS,1,1)
14893 I2=IMI(3-JS,1,1)
14894 DO 160 JCS=4,5
14895 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
14896 & GOTO 160
14897 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
14898 KCS=JCS
14899 CALL PYCTTR(I1,KCS,I2)
14900 IF(MINT(51).NE.0) RETURN
14901 160 CONTINUE
14902 170 CONTINUE
14903
14904C...Range checking for companion quark pdf large-x param.
14905 IF (MSTP(87).LT.0) THEN
14906 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
14907 & ' MSTP(87)=0')
14908 MSTP(87)=0
14909 ELSEIF (MSTP(87).GT.4) THEN
14910 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
14911 & ' MSTP(87)=4')
14912 MSTP(87)=4
14913 ENDIF
14914
14915C----------------------------------------------------------------------
14916C...MODE=0: Generate trial interaction. Return codes:
14917C...IFAIL < 0: Phase space exhausted, generation to be terminated.
14918C...IFAIL = 0: Additional interaction generated at PT2.
14919C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
14920 ELSEIF (MODE.EQ.0) THEN
14921C...Abolute MI max scale = VINT(62)
14922 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
14923 180 IF(MSTP(82).LE.1) THEN
14924 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
14925 IF(XT2.LT.VINT(149)) IFAIL=-2
14926 ELSE
14927 IF(XT2.LE.0.01001D0*VINT(149)) THEN
14928 IFAIL=-3
14929 ELSE
14930 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
14931 & LOG(PYR(0)))-VINT(149)
14932 ENDIF
14933 ENDIF
14934C...Also exit if below lower limit or if higher trial branching
14935C...already found.
14936 PT2=0.25D0*VINT(2)*XT2
14937 IF (PT2.LE.PT2CUT) IFAIL=-4
14938 IF (PT2.LE.PT2MX) IFAIL=-5
14939 IF (IFAIL.NE.0) THEN
14940 PT2=0D0
14941 RETURN
14942 ENDIF
14943 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
14944 VINT(25)=4D0*PT2/VINT(2)
14945 XT2=VINT(25)
14946
14947C...Choose tau and y*. Calculate cos(theta-hat).
14948 IF(PYR(0).LE.COEF(ISUB,1)) THEN
14949 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
14950 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
14951 ELSE
14952 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
14953 ENDIF
14954 VINT(21)=TAU
14955C...New: require shat > 1.
14956 IF(TAU*VINT(2).LT.1D0) GOTO 180
14957 CALL PYKLIM(2)
14958 RYST=PYR(0)
14959 MYST=1
14960 IF(RYST.GT.COEF(ISUB,8)) MYST=2
14961 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
14962 CALL PYKMAP(2,MYST,PYR(0))
14963 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
14964
14965C...Check that x not used up. Accept or reject kinematical variables.
14966 X1M=SQRT(TAU)*EXP(VINT(22))
14967 X2M=SQRT(TAU)*EXP(-VINT(22))
14968 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
14969 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
14970 CALL PYSIGH(NCHN,SIGS)
14971 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
14972 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
14973 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
14974
14975C...Save if highest PT so far.
14976 IF (PT2.GT.PT2MX) THEN
14977 JSMX=0
14978 MIMX=MINT(31)+1
14979 PT2MX=PT2
14980 ENDIF
14981
14982C----------------------------------------------------------------------
14983C...MODE=1: Generate and save accepted scattering.
14984 ELSEIF (MODE.EQ.1) THEN
14985 PT2=PT2NOW
14986C...Reset K, P, V, and MCT vectors.
14987 DO 200 I=N+1,N+4
14988 DO 190 J=1,5
14989 K(I,J)=0
14990 P(I,J)=0D0
14991 V(I,J)=0D0
14992 190 CONTINUE
14993 MCT(I,1)=0
14994 MCT(I,2)=0
14995 200 CONTINUE
14996
14997 NTRY=0
14998C...Choose flavour of reacting partons (and subprocess).
14999 210 NTRY=NTRY+1
15000 IF (NTRY.GT.50) THEN
15001 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15002 & //'interaction. Giving up!')
15003 MINT(51)=1
15004 RETURN
15005 ENDIF
15006 RSIGS=SIGS*PYR(0)
15007 DO 220 ICHN=1,NCHN
15008 KFL1=ISIG(ICHN,1)
15009 KFL2=ISIG(ICHN,2)
15010 ICONMI=ISIG(ICHN,3)
15011 RSIGS=RSIGS-SIGH(ICHN)
15012 IF(RSIGS.LE.0D0) GOTO 230
15013 220 CONTINUE
15014
15015C...Reassign to appropriate process codes.
15016 230 ISUBMI=ICONMI/10
15017 ICONMI=MOD(ICONMI,10)
15018
15019C...Choose new quark flavour for annihilation graphs
15020 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15021 SH=VINT(21)*VINT(2)
15022 CALL PYWIDT(21,SH,WDTP,WDTE)
15023 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15024 DO 250 I=1,MDCY(21,3)
15025 KFLF=KFDP(I+MDCY(21,2)-1,1)
15026 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15027 IF(RKFL.LE.0D0) GOTO 260
15028 250 CONTINUE
15029 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15030 IF(KFLF.GE.4) GOTO 240
15031 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15032 KFLF=4
15033 ICONMI=ICONMI-2
15034 ELSEIF(ISUBMI.EQ.53) THEN
15035 KFLF=5
15036 ICONMI=ICONMI-4
15037 ENDIF
15038 ENDIF
15039
15040C...Final state flavours and colour flow: default values
15041 JS=1
15042 KFL3=KFL1
15043 KFL4=KFL2
15044 KCC=20
15045 KCS=ISIGN(1,KFL1)
15046
15047 IF(ISUBMI.EQ.11) THEN
15048C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15049 KCC=ICONMI
15050 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15051
15052 ELSEIF(ISUBMI.EQ.12) THEN
15053C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15054 KFL3=ISIGN(KFLF,KFL1)
15055 KFL4=-KFL3
15056 KCC=4
15057
15058 ELSEIF(ISUBMI.EQ.13) THEN
15059C...f + fbar -> g + g; th arbitrary
15060 KFL3=21
15061 KFL4=21
15062 KCC=ICONMI+4
15063
15064 ELSEIF(ISUBMI.EQ.28) THEN
15065C...f + g -> f + g; th = (p(f)-p(f))**2
15066 IF(KFL1.EQ.21) JS=2
15067 KCC=ICONMI+6
15068 IF(KFL1.EQ.21) KCC=KCC+2
15069 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15070 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15071
15072 ELSEIF(ISUBMI.EQ.53) THEN
15073C...g + g -> f + fbar; th arbitrary
15074 KCS=(-1)**INT(1.5D0+PYR(0))
15075 KFL3=ISIGN(KFLF,KCS)
15076 KFL4=-KFL3
15077 KCC=ICONMI+10
15078
15079 ELSEIF(ISUBMI.EQ.68) THEN
15080C...g + g -> g + g; th arbitrary
15081 KCC=ICONMI+12
15082 KCS=(-1)**INT(1.5D0+PYR(0))
15083 ENDIF
15084
15085C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15086 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15087 & .OR.IABS(KFL4).EQ.5) THEN
15088 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15089 IF (PT2.LE.1.05*RMMAX2) THEN
15090 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15091 & //' created below threshold. Rejected.')
15092 GOTO 210
15093 ENDIF
15094 ENDIF
15095
15096C...Store flavours of scattering.
15097 MINT(13)=KFL1
15098 MINT(14)=KFL2
15099 MINT(15)=KFL1
15100 MINT(16)=KFL2
15101 MINT(21)=KFL3
15102 MINT(22)=KFL4
15103
15104C...Set flavours and mothers of scattering partons.
15105 K(N+1,1)=14
15106 K(N+2,1)=14
15107 K(N+3,1)=3
15108 K(N+4,1)=3
15109 K(N+1,2)=KFL1
15110 K(N+2,2)=KFL2
15111 K(N+3,2)=KFL3
15112 K(N+4,2)=KFL4
15113 K(N+1,3)=MINT(83)+1
15114 K(N+2,3)=MINT(83)+2
15115 K(N+3,3)=N+1
15116 K(N+4,3)=N+2
15117
15118C...Store colour connection indices.
15119 DO 270 J=1,2
15120 JC=J
15121 IF(KCS.EQ.-1) JC=3-J
15122 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15123 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15124 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15125 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15126 270 CONTINUE
15127
15128C...Store incoming and outgoing partons in their CM-frame.
15129 SHR=SQRT(VINT(21))*VINT(1)
15130 P(N+1,3)=0.5D0*SHR
15131 P(N+1,4)=0.5D0*SHR
15132 P(N+2,3)=-0.5D0*SHR
15133 P(N+2,4)=0.5D0*SHR
15134 P(N+3,5)=PYMASS(K(N+3,2))
15135 P(N+4,5)=PYMASS(K(N+4,2))
15136 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15137 IFAIL=1
15138 RETURN
15139 ENDIF
15140 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15141 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15142 P(N+4,4)=SHR-P(N+3,4)
15143 P(N+4,3)=-P(N+3,3)
15144
15145C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15146 PHI=PARU(2)*PYR(0)
15147 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15148
15149C...Global statistics.
15150 MINT(351)=MINT(351)+1
15151 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15152 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15153
15154C...Keep track of loose colour ends and information on scattering.
15155 MINT(31)=MINT(31)+1
15156 MINT(36)=MINT(31)
15157 PT2MI(MINT(36))=PT2
15158 IMISEP(MINT(31))=N+4
15159 DO 280 JS=1,2
15160 IMI(JS,MINT(31),1)=N+JS
15161 IMI(JS,MINT(31),2)=0
15162 XMI(JS,MINT(31))=VINT(40+JS)
15163 NMI(JS)=NMI(JS)+1
15164C...Update cumulative counters
15165 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15166 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15167 280 CONTINUE
15168
15169C...Add to list of final state partons
15170 IPART(NPART+1)=N+3
15171 IPART(NPART+2)=N+4
15172 PTPART(NPART+1)=SQRT(PT2)
15173 PTPART(NPART+2)=SQRT(PT2)
15174 NPART=NPART+2
15175
15176C...Initialize ISR
15177 NISGEN(1,MINT(31))=0
15178 NISGEN(2,MINT(31))=0
15179
15180C...Update ER
15181 N=N+4
15182 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15183 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15184 MINT(51)=1
15185 RETURN
15186 ENDIF
15187
15188C...Finally, assign colour tags to new partons
15189 DO 300 JS=1,2
15190 I1=IMI(JS,MINT(31),1)
15191 I2=IMI(3-JS,MINT(31),1)
15192 DO 290 JCS=4,5
15193 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15194 & GOTO 290
15195 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15196 KCS=JCS
15197 CALL PYCTTR(I1,KCS,I2)
15198 IF(MINT(51).NE.0) RETURN
15199 290 CONTINUE
15200 300 CONTINUE
15201
15202C----------------------------------------------------------------------
15203C...MODE=2: Decide whether quarks in last scattering were valence,
15204C...companion, or sea.
15205 ELSEIF (MODE.EQ.2) THEN
15206 JS=MINT(30)
15207 MI=MINT(36)
15208 PT2=PT2NOW
15209 KFSBM=ISIGN(1,MINT(10+JS))
15210 IFL=K(IMI(JS,MI,1),2)
15211 IMI(JS,MI,2)=0
15212 IF (IABS(IFL).GE.6) THEN
15213 IF (IABS(IFL).EQ.6) THEN
15214 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15215 ENDIF
15216 RETURN
15217 ENDIF
15218C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15219C...(Do not include the parton itself in the X rescaling.)
15220 X=XMI(JS,MI)
15221 XRSC=X/(VINT(142+JS)+X)
15222C...Note: XPSVC = x*pdf.
15223 MINT(30)=JS
15224 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15225 SEA=XPSVC(IFL,-1)
15226 VAL=XPSVC(IFL,0)
15227 CMP=0D0
15228 DO 310 IVC=1,NVC(JS,IFL)
15229 CMP=CMP+XPSVC(IFL,IVC)
15230 310 CONTINUE
15231
15232C...Decide (Extra factor x cancels in the dvision).
15233 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15234 IVNOW=1
15235 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15236C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15237 IVNOW=0
15238 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15239 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15240 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15241 IF(KFIVAL(JS,1).EQ.0) THEN
15242 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15243 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15244 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15245 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15246 ELSE
15247C...Count down valence remaining. Do not count current scattering.
15248 DO 340 I1=1,NMI(JS)
15249 IF (I1.EQ.MINT(36)) GOTO 340
15250 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15251 & IVNOW=IVNOW-1
15252 340 CONTINUE
15253 ENDIF
15254 IF(IVNOW.EQ.0) GOTO 330
15255C...Mark valence.
15256 IMI(JS,MI,2)=0
15257C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15258 IF(KFIVAL(JS,1).EQ.0) THEN
15259 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15260 KFIVAL(JS,1)=IFL
15261 KFIVAL(JS,2)=-IFL
15262 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15263 KFIVAL(JS,1)=IFL
15264 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15265 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15266 ENDIF
15267 ENDIF
15268
15269 ELSEIF (RVCS.LE.VAL+SEA) THEN
15270C...If sea, add opposite sign companion parton. Store X and I.
15271 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15272 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15273C...Set pointer to companion
15274 IMI(JS,MI,2)=-NVC(JS,-IFL)
15275
15276 ELSE
15277C...If companion, decide which one.
15278 IF (NVC(JS,IFL).EQ.0) THEN
15279 CMP=0D0
15280 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15281 GOTO 320
15282 ENDIF
15283 CMPSUM=VAL+SEA
15284 ISEL=0
15285 350 ISEL=ISEL+1
15286 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15287 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15288C...Find original sea (anti-)quark. Do not consider current scattering.
15289 IASSOC=0
15290 DO 360 I1=1,NMI(JS)
15291 IF (I1.EQ.MINT(36)) GOTO 360
15292 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15293 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15294 IMI(JS,MI,2)=IMI(JS,I1,1)
15295 IMI(JS,I1,2)=IMI(JS,MI,1)
15296 ENDIF
15297 360 CONTINUE
15298C...Mark companion "out-kicked".
15299 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15300 ENDIF
15301
15302 ENDIF
15303 RETURN
15304 END
15305
15306C*********************************************************************
15307
15308C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15309C...Giving the x*f pdf of a companion quark, with its partner at XS,
15310C...using an approximate gluon density like (1-X)^NPOW/X. The value
15311C...corresponds to an unrescaled range between 0 and 1-X.
15312
15313 FUNCTION PYFCMP(XC,XS,NPOW)
15314 IMPLICIT NONE
15315 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15316 INTEGER NPOW
15317
15318 PYFCMP=0D0
15319C...Parent gluon momentum fraction
15320 Y=XC+XS
15321 IF (Y.GE.1D0) RETURN
15322C...Common factor (includes factor XC, since PYFCMP=x*f)
15323 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15324C...Store normalized companion x*f distribution.
15325 IF (NPOW.LE.0) THEN
15326 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15327 ELSEIF (NPOW.EQ.1) THEN
15328 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15329 ELSEIF (NPOW.EQ.2) THEN
15330 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15331 & +3D0*XS*(1D0+XS)*LOG(XS)))
15332 ELSEIF (NPOW.EQ.3) THEN
15333 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15334 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15335 ELSEIF (NPOW.GE.4) THEN
15336 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15337 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15338 ENDIF
15339 RETURN
15340 END
15341
15342C*********************************************************************
15343
15344C...PYPCMP: Auxiliary to PYPDFU.
15345C...Giving the momentum integral of a companion quark, with its
15346C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15347C...The value corresponds to an unrescaled range between 0 and 1-XS.
15348
15349 FUNCTION PYPCMP(XS,NPOW)
15350 IMPLICIT NONE
15351 DOUBLE PRECISION XS, PYPCMP
15352 INTEGER NPOW
15353 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15354 PYPCMP=0D0
15355 ELSEIF (NPOW.LE.0) THEN
15356 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15357 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15358 ELSEIF (NPOW.EQ.1) THEN
15359 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15360 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15361 ELSEIF (NPOW.EQ.2) THEN
15362 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15363 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15364 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15365 & -3D0*XS*LOG(XS)*(1+XS)))
15366 ELSEIF (NPOW.EQ.3) THEN
15367 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15368 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15369 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15370 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15371 ELSE
15372 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15373 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15374 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15375 & -6D0*XS*LOG(XS)*(1D0+XS)))
15376 ENDIF
15377 RETURN
15378 END
15379
15380C*********************************************************************
15381
15382C...PYUPRE
15383C...Rearranges contents of the HEPEUP commonblock so that
15384C...mothers precede daughters and daughters of a decay are
15385C...listed consecutively.
15386
15387 SUBROUTINE PYUPRE
15388
15389C...Double precision and integer declarations.
15390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15391 IMPLICIT INTEGER(I-N)
15392
15393C...User process event common block.
15394 INTEGER MAXNUP
15395 PARAMETER (MAXNUP=500)
15396 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15397 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15398 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15399 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15400 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15401 SAVE /HEPEUP/
15402
15403C...Local arrays.
15404 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15405 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15406 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15407
15408C...Check whether a rearrangement is required.
15409 NEED=0
15410 DO 100 IUP=1,NUP
15411 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15412 100 CONTINUE
15413 DO 110 IUP=2,NUP
15414 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15415 110 CONTINUE
15416
15417 IF(NEED.NE.0) THEN
15418C...Find the new order that particles should have.
15419 NEWPOS(0)=0
15420 NNEW=0
15421 INEW=-1
15422 120 INEW=INEW+1
15423 DO 130 IUP=1,NUP
15424 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15425 NNEW=NNEW+1
15426 NEWPOS(NNEW)=IUP
15427 ENDIF
15428 130 CONTINUE
15429 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15430 IF(NNEW.NE.NUP) THEN
15431 CALL PYERRM(2,
15432 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15433 RETURN
15434 ENDIF
15435
15436C...Copy old info into temporary storage.
15437 DO 150 I=1,NUP
15438 IDUPT(I)=IDUP(I)
15439 ISTUPT(I)=ISTUP(I)
15440 MOTUPT(1,I)=MOTHUP(1,I)
15441 MOTUPT(2,I)=MOTHUP(2,I)
15442 ICOUPT(1,I)=ICOLUP(1,I)
15443 ICOUPT(2,I)=ICOLUP(2,I)
15444 DO 140 J=1,5
15445 PUPT(J,I)=PUP(J,I)
15446 140 CONTINUE
15447 VTIUPT(I)=VTIMUP(I)
15448 SPIUPT(I)=SPINUP(I)
15449 150 CONTINUE
15450
15451C...Copy info back into HEPEUP in right order.
15452 DO 180 I=1,NUP
15453 IOLD=NEWPOS(I)
15454 IDUP(I)=IDUPT(IOLD)
15455 ISTUP(I)=ISTUPT(IOLD)
15456 MOTHUP(1,I)=0
15457 MOTHUP(2,I)=0
15458 DO 160 IMOT=1,I-1
15459 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15460 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15461 160 CONTINUE
15462 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15463 MOTHSW=MOTHUP(1,I)
15464 MOTHUP(1,I)=MOTHUP(2,I)
15465 MOTHUP(2,I)=MOTHSW
15466 ENDIF
15467 ICOLUP(1,I)=ICOUPT(1,IOLD)
15468 ICOLUP(2,I)=ICOUPT(2,IOLD)
15469 DO 170 J=1,5
15470 PUP(J,I)=PUPT(J,IOLD)
15471 170 CONTINUE
15472 VTIMUP(I)=VTIUPT(IOLD)
15473 SPINUP(I)=SPIUPT(IOLD)
15474 180 CONTINUE
15475 ENDIF
15476
15477c...If incoming particles are massive recalculate to put them massless.
15478 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15479 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15480 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15481 PUP(4,1)=0.5D0*PPLUS
15482 PUP(3,1)=PUP(4,1)
15483 PUP(5,1)=0D0
15484 PUP(4,2)=0.5D0*PMINUS
15485 PUP(3,2)=-PUP(4,2)
15486 PUP(5,2)=0D0
15487 ENDIF
15488
15489 RETURN
15490 END
15491
15492C*********************************************************************
15493
15494C...PYADSH
15495C...Administers the generation of successive final-state showers
15496C...in external processes.
15497
15498 SUBROUTINE PYADSH(NFIN)
15499
15500C...Double precision and integer declarations.
15501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15502 IMPLICIT INTEGER(I-N)
15503 INTEGER PYK,PYCHGE,PYCOMP
15504C...Parameter statement for maximum size of showers.
15505 PARAMETER (MAXNUR=1000)
15506C...Commonblocks.
15507 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15508 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15509 COMMON/PYCTAG/NCT,MCT(4000,2)
15510 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15512 COMMON/PYINT1/MINT(400),VINT(400)
15513 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15514C...Local array.
15515 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15516
15517C...Set primary vertex.
15518 DO 100 J=1,5
15519 V(MINT(83)+5,J)=0D0
15520 V(MINT(83)+6,J)=0D0
15521 V(MINT(84)+1,J)=0D0
15522 V(MINT(84)+2,J)=0D0
15523 100 CONTINUE
15524
15525C...Isolate systems of particles with the same mother.
15526 NSYS=0
15527 IMS=-1
15528 DO 140 I=MINT(84)+3,NFIN
15529 IM=K(I,3)
15530 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15531 IF(IM.NE.IMS) THEN
15532 NSYS=NSYS+1
15533 IBEG(NSYS)=I
15534 IMS=IM
15535 ENDIF
15536
15537C...Set production vertices.
15538 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15539 & THEN
15540 DO 110 J=1,4
15541 V(I,J)=0D0
15542 110 CONTINUE
15543 ELSE
15544 DO 120 J=1,4
15545 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15546 120 CONTINUE
15547 ENDIF
15548 IF(MSTP(125).GE.1) THEN
15549 IDOC=I-MSTP(126)+4
15550 DO 130 J=1,5
15551 V(IDOC,J)=V(I,J)
15552 130 CONTINUE
15553 ENDIF
15554 140 CONTINUE
15555
15556C...End loop over systems. Return if no showers to be performed.
15557 IBEG(NSYS+1)=NFIN+1
15558 IF(MSTP(71).LE.0) RETURN
15559
15560C...Loop through systems of particles; check that sensible size.
15561 DO 270 ISYS=1,NSYS
15562 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15563 IF(MINT(35).LE.1) THEN
15564 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15565 GOTO 270
15566 ELSEIF(NSIZ.LE.1) THEN
15567 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15568 GOTO 270
15569 ELSEIF(NSIZ.GT.80) THEN
15570 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
15571 GOTO 270
15572 ENDIF
15573 ENDIF
15574
15575C...Save status codes and daughters of showering particles; reset them.
15576 DO 150 J=1,4
15577 PSUM(J)=0D0
15578 150 CONTINUE
15579 DO 170 II=1,NSIZ
15580 I=IBEG(ISYS)-1+II
15581 KSAV(II,1)=K(I,1)
15582 IF(K(I,1).GT.10) THEN
15583 K(I,1)=1
15584 IF(KSAV(II,1).EQ.14) K(I,1)=3
15585 ENDIF
15586 IF(KSAV(II,1).LE.10) THEN
15587 ELSEIF(K(I,1).EQ.1) THEN
15588 KSAV(II,4)=K(I,4)
15589 KSAV(II,5)=K(I,5)
15590 K(I,4)=0
15591 K(I,5)=0
15592 ELSE
15593 KSAV(II,4)=MOD(K(I,4),MSTU(5))
15594 KSAV(II,5)=MOD(K(I,5),MSTU(5))
15595 K(I,4)=K(I,4)-KSAV(II,4)
15596 K(I,5)=K(I,5)-KSAV(II,5)
15597 ENDIF
15598 DO 160 J=1,4
15599 PSUM(J)=PSUM(J)+P(I,J)
15600 160 CONTINUE
15601 170 CONTINUE
15602
15603C...Perform shower.
15604 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
15605 & PSUM(3)**2))
15606 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
15607 NSAV=N
15608 IF(MINT(35).LE.1) THEN
15609 IF(NSIZ.EQ.2) THEN
15610 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
15611 ELSE
15612 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
15613 ENDIF
15614
15615C...For external processes, first call, also ISR partons radiate.
15616C...Can use existing PYPART list, removing partons that radiate later.
15617 ELSEIF(ISYS.EQ.1) THEN
15618 NPARTN=0
15619 DO 175 II=1,NPART
15620 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
15621 NPARTN=NPARTN+1
15622 IPART(NPARTN)=IPART(II)
15623 PTPART(NPARTN)=PTPART(II)
15624 ENDIF
15625 175 CONTINUE
15626 NPART=NPARTN
15627 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
15628 ELSE
15629C...For subsequent calls use the systems excluded above.
15630 NPART=NSIZ
15631 NPARTD=0
15632 DO 180 II=1,NSIZ
15633 I=IBEG(ISYS)-1+II
15634 IPART(II)=I
15635 PTPART(II)=0.5D0*QMAX
15636 180 CONTINUE
15637 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
15638 ENDIF
15639
15640C...Look up showered copies of original showering particles.
15641 DO 260 II=1,NSIZ
15642 I=IBEG(ISYS)-1+II
15643 IMV=I
15644C...Particles without daughters need not be studied.
15645 IF(KSAV(II,1).LE.10) GOTO 260
15646 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
15647 ELSEIF(K(I,1).EQ.11) THEN
15648 190 IMV=MOD(K(IMV,4),MSTU(5))
15649 IF(K(IMV,1).EQ.11) GOTO 190
15650 ELSE
15651 KDA1=MOD(K(I,4),MSTU(5))
15652 IF(KDA1.GT.0) THEN
15653 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
15654 ENDIF
15655 KDA2=MOD(K(I,5),MSTU(5))
15656 IF(KDA2.GT.0) THEN
15657 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
15658 ENDIF
15659 DO 200 I3=I+1,N
15660 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
15661 & THEN
15662 IMV=I3
15663 KDA1=MOD(K(I3,4),MSTU(5))
15664 IF(KDA1.GT.0) THEN
15665 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
15666 ENDIF
15667 KDA2=MOD(K(I3,5),MSTU(5))
15668 IF(KDA2.GT.0) THEN
15669 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
15670 ENDIF
15671 ENDIF
15672 200 CONTINUE
15673 ENDIF
15674
15675C...Restore daughter info of original partons to showered copies.
15676 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
15677 IF(KSAV(II,1).LE.10) THEN
15678 ELSEIF(K(I,1).EQ.1) THEN
15679 K(IMV,4)=KSAV(II,4)
15680 K(IMV,5)=KSAV(II,5)
15681 ELSE
15682 K(IMV,4)=K(IMV,4)+KSAV(II,4)
15683 K(IMV,5)=K(IMV,5)+KSAV(II,5)
15684 ENDIF
15685
15686C...Reset mother info of existing daughters to showered copies.
15687 DO 210 I3=IBEG(ISYS+1),NFIN
15688 IF(K(I3,3).EQ.I) K(I3,3)=IMV
15689 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
15690 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
15691 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
15692 ENDIF
15693 210 CONTINUE
15694
15695C...Boost all original daughters to new frame of showered copy.
15696C...Also update their colour tags.
15697 IF(IMV.NE.I) THEN
15698 DO 220 J=1,3
15699 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
15700 220 CONTINUE
15701 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
15702 DO 230 J=1,3
15703 BETA(J)=FAC*BETA(J)
15704 230 CONTINUE
15705 DO 250 I3=IBEG(ISYS+1),NFIN
15706 IMO=I3
15707 240 IMO=K(IMO,3)
15708 IF(MSTP(128).LE.0) THEN
15709 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
15710 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
15711 & THEN
15712 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
15713 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
15714 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
15715 ENDIF
15716 ELSE
15717 IF(IMO.EQ.IMV) THEN
15718 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
15719 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
15720 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
15721 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
15722 GOTO 240
15723 ENDIF
15724 ENDIF
15725 250 CONTINUE
15726 ENDIF
15727 260 CONTINUE
15728
15729C...End of loop over showering systems
15730 270 CONTINUE
15731
15732 RETURN
15733 END
15734
15735C*********************************************************************
15736
15737C...PYVETO
15738C...Interface to UPVETO, which allows user to veto event generation
15739C...on the parton level, after parton showers but before multiple
15740C...interactions, beam remnants and hadronization is added.
15741
15742 SUBROUTINE PYVETO(IVETO)
15743
15744C...All real arithmetic in double precision.
15745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15746C...Three Pythia functions return integers, so need declaring.
15747 INTEGER PYK,PYCHGE,PYCOMP
15748
15749C...PYTHIA commonblocks.
15750 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15751 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15752 COMMON/PYINT1/MINT(400),VINT(400)
15753 SAVE /PYJETS/,/PYPARS/,/PYINT1/
15754C...HEPEVT commonblock.
15755 PARAMETER (NMXHEP=4000)
15756 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
15757 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
15758 DOUBLE PRECISION PHEP,VHEP
15759 SAVE /HEPEVT/
15760C...Local array.
15761 DIMENSION IRESO(100)
15762
15763C...Define longitudinal boost from initiator rest frame to cm frame.
15764 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
15765 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
15766
15767C... Reset counters.
15768 NEVHEP=0
15769 NHEP=0
15770 NRESO=0
15771
15772C...First pass: identify final locations of resonances
15773C...and of their daughters before showering.
15774 DO 150 I=MINT(84)+3,N
15775 ISTORE=0
15776 IMOTH=0
15777
15778C...Skip shower CM frame documentation lines.
15779 IF(K(I,2).EQ.94) THEN
15780
15781C... Store a new intermediate product, when mother in documentation.
15782 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
15783 & K(I,3).LE.MINT(84)) THEN
15784 ISTORE=1
15785 NHEP=NHEP+1
15786 II=NHEP
15787 NRESO=NRESO+1
15788 IRESO(NRESO)=I
15789 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
15790
15791C... Store a new intermediate product, when mother in main section.
15792 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
15793 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
15794 ISTORE=1
15795 NHEP=NHEP+1
15796 II=NHEP
15797 NRESO=NRESO+1
15798 IRESO(NRESO)=I
15799 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
15800
15801C...Update a product when a new copy of it has been created.
15802 ELSE
15803 IHIST=K(I,3)
15804 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(I-1-IHIST)
15805 IR=0
15806 DO 100 IRI=1,NRESO
15807 IF(IHIST.EQ.IRESO(IRI)) IR=IRI
15808 100 CONTINUE
15809C...Flavours must match, and exclude gluon and photon emission.
15810 IF(K(IHIST,2).NE.K(I,2)) IR=0
15811 IF(IR.GT.0.AND.I.LT.N) THEN
15812 IF(K(I+1,3).EQ.K(I,3).AND.(K(I+1,2).EQ.21.OR.
15813 & K(I+1,2).EQ.22)) IR=0
15814 ENDIF
15815 IF(IR.GT.0) THEN
15816 ISTORE=1
15817 II=IR
15818 IRESO(IR)=I
15819 IMOTH=JMOHEP(1,II)
15820 ENDIF
15821 ENDIF
15822
15823 IF(ISTORE.EQ.1) THEN
15824C...Copy parton info, boosting momenta along z axis to cm frame.
15825 ISTHEP(II)=2
15826 IDHEP(II)=K(I,2)
15827 PHEP(1,II)=P(I,1)
15828 PHEP(2,II)=P(I,2)
15829 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
15830 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
15831 PHEP(5,II)=P(I,5)
15832C...Store one mother. Rest of history and vertex info zeroed.
15833 JMOHEP(1,II)=IMOTH
15834 JMOHEP(2,II)=0
15835 JDAHEP(1,II)=0
15836 JDAHEP(2,II)=0
15837 VHEP(1,II)=0D0
15838 VHEP(2,II)=0D0
15839 VHEP(3,II)=0D0
15840 VHEP(4,II)=0D0
15841 ENDIF
15842 150 CONTINUE
15843
15844C...Second pass: identify current set of "final" partons.
15845 DO 200 I=MINT(84)+3,N
15846 ISTORE=0
15847 IMOTH=0
15848
15849C...Store a final parton.
15850 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
15851 ISTORE=1
15852 NHEP=NHEP+1
15853 II=NHEP
15854C..Trace it back through shower, to check if from documented particle.
15855 IHIST=I
15856 ISAVE=IHIST
15857 160 CONTINUE
15858 IF(IHIST.GT.MINT(84)) THEN
15859 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
15860 DO 170 IRI=1,NRESO
15861 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
15862 170 CONTINUE
15863 ISAVE=IHIST
15864 IHIST=K(IHIST,3)
15865 IF(IMOTH.EQ.0) GOTO 160
15866 ENDIF
15867 ENDIF
15868
15869 IF(ISTORE.EQ.1) THEN
15870C...Copy parton info, boosting momenta along z axis to cm frame.
15871 ISTHEP(II)=1
15872 IDHEP(II)=K(I,2)
15873 PHEP(1,II)=P(I,1)
15874 PHEP(2,II)=P(I,2)
15875 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
15876 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
15877 PHEP(5,II)=P(I,5)
15878C...Store one mother. Rest of history and vertex info zeroed.
15879 JMOHEP(1,II)=IMOTH
15880 JMOHEP(2,II)=0
15881 JDAHEP(1,II)=0
15882 JDAHEP(2,II)=0
15883 VHEP(1,II)=0D0
15884 VHEP(2,II)=0D0
15885 VHEP(3,II)=0D0
15886 VHEP(4,II)=0D0
15887 ENDIF
15888 200 CONTINUE
15889
15890C...Call user-written routine to decide whether to keep events.
15891 CALL UPVETO(IVETO)
15892
15893 RETURN
15894 END
15895
15896
15897C*********************************************************************
15898
15899C...PYRESD
15900C...Allows resonances to decay (including parton showers for hadronic
15901C...channels).
15902
15903 SUBROUTINE PYRESD(IRES)
15904
15905C...Double precision and integer declarations.
15906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15907 IMPLICIT INTEGER(I-N)
15908 INTEGER PYK,PYCHGE,PYCOMP
15909C...Parameter statement to help give large particle numbers.
15910 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
15911 &KEXCIT=4000000,KDIMEN=5000000)
15912C...Parameter statement for maximum size of showers.
15913 PARAMETER (MAXNUR=1000)
15914C...Commonblocks.
15915 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15916 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15917 COMMON/PYCTAG/NCT,MCT(4000,2)
15918 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15919 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15920 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15921 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
15922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15923 COMMON/PYINT1/MINT(400),VINT(400)
15924 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15925 COMMON/PYINT4/MWID(500),WIDS(500,5)
15926 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
15927 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
15928C...Local arrays and complex and character variables.
15929 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
15930 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
15931 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
15932 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
15933 &ITJUNC(3),CTM2(3)
15934 COMPLEX FGK,HA(6,6),HC(6,6)
15935 REAL TIR,UIR
15936 CHARACTER CODE*9,MASS*9
15937
15938C...The F, Xi and Xj functions of Gunion and Kunszt
15939C...(Phys. Rev. D33, 665, plus errata from the authors).
15940 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
15941 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
15942 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
15943 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
15944 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
15945 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
15946 &2D0*(D34/D56+D56/D34))
15947
15948C...Some general constants.
15949 XW=PARU(102)
15950 XWV=XW
15951 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
15952 XW1=1D0-XW
15953 SQMZ=PMAS(23,1)**2
15954
15955 GMMZ=PMAS(23,1)*PMAS(23,2)
15956 SQMW=PMAS(24,1)**2
15957 GMMW=PMAS(24,1)*PMAS(24,2)
15958 SH=VINT(44)
15959
15960C...Boost and rotate to rest frame of incoming partons,
15961C...to get proper amount of smearing of decay angles.
15962 IBST=0
15963 IF(IRES.EQ.0) THEN
15964 IBST=1
15965 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
15966 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
15967 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
15968 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
15969 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
15970 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
15971 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
15972 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
15973 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
15974 ENDIF
15975
15976C...Reset original resonance configuration.
15977 DO 100 JT=1,8
15978 IREF(1,JT)=0
15979 100 CONTINUE
15980
15981C...Define initial one, two or three objects for subprocess.
15982 IHDEC=0
15983 IF(IRES.EQ.0) THEN
15984 ISUB=MINT(1)
15985 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
15986 IREF(1,1)=MINT(84)+2+ISET(ISUB)
15987 IREF(1,4)=MINT(83)+6+ISET(ISUB)
15988 JTMAX=1
15989 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
15990 IREF(1,1)=MINT(84)+1+ISET(ISUB)
15991 IREF(1,2)=MINT(84)+2+ISET(ISUB)
15992 IREF(1,4)=MINT(83)+5+ISET(ISUB)
15993 IREF(1,5)=MINT(83)+6+ISET(ISUB)
15994 JTMAX=2
15995 ELSEIF(ISET(ISUB).EQ.5) THEN
15996 IREF(1,1)=MINT(84)+3
15997 IREF(1,2)=MINT(84)+4
15998 IREF(1,3)=MINT(84)+5
15999 IREF(1,4)=MINT(83)+7
16000 IREF(1,5)=MINT(83)+8
16001 IREF(1,6)=MINT(83)+9
16002 JTMAX=3
16003 ENDIF
16004
16005C...Define original resonance for odd cases.
16006 ELSE
16007 ISUB=0
16008 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16009 & IHDEC=1
16010 IF(IHDEC.EQ.1) ISUB=3
16011 IREF(1,1)=IRES
16012 IREF(1,4)=K(IRES,3)
16013 IRESTM=IRES
16014 IF(IREF(1,4).GT.MINT(84)) THEN
16015 110 ITMPMO=IREF(1,4)
16016 IF(K(ITMPMO,2).EQ.94) THEN
16017 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16018 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16019 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16020 IRESTM=ITMPMO
16021 IREF(1,4)=K(ITMPMO,3)
16022 GOTO 110
16023 ENDIF
16024 ENDIF
16025 IF(IREF(1,4).GT.MINT(84)) THEN
16026 EMATCH=1D10
16027 IREF14=IREF(1,4)
16028 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16029 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16030 & EMATCH) THEN
16031 IREF(1,4)=II
16032 EMATCH=ABS(P(II,4)-P(IREF14,4))
16033 ENDIF
16034 120 CONTINUE
16035 ENDIF
16036 JTMAX=1
16037 ENDIF
16038
16039C...Check if initial resonance has been moved (in resonance + jet).
16040 DO 140 JT=1,3
16041 IF(IREF(1,JT).GT.0) THEN
16042 IF(K(IREF(1,JT),1).GT.10) THEN
16043 KFA=IABS(K(IREF(1,JT),2))
16044 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16045 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16046 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16047 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16048 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16049 ENDIF
16050 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16051 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16052 ENDIF
16053 DO 130 I=IREF(1,JT)+1,N
16054 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16055 & I.EQ.KDA2)) THEN
16056 IREF(1,JT)=I
16057 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16058 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16059 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16060 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16061 ENDIF
16062 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16063 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16064 ENDIF
16065 ENDIF
16066 130 CONTINUE
16067 ELSE
16068 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16069 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16070 ENDIF
16071 ENDIF
16072 ENDIF
16073 140 CONTINUE
16074
16075C...Set decay vertex for initial resonances
16076 DO 160 JT=1,JTMAX
16077 DO 150 I=1,4
16078 V(IREF(1,JT),I)=0D0
16079 150 CONTINUE
16080 160 CONTINUE
16081
16082C...Loop over decay history.
16083 NP=1
16084 IP=0
16085 170 IP=IP+1
16086 NINH=0
16087 JTMAX=2
16088 IF(IREF(IP,2).EQ.0) JTMAX=1
16089 IF(IREF(IP,3).NE.0) JTMAX=3
16090 IT4=0
16091 NSAV=N
16092
16093C...Check for Higgs which appears as decay product of user-process.
16094 IF(ISUB.EQ.0) THEN
16095 IHDEC=0
16096 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16097 & .EQ.36) IHDEC=1
16098 IF(IHDEC.EQ.1) ISUB=3
16099 ENDIF
16100
16101C...Start treatment of one, two or three resonances in parallel.
16102 180 N=NSAV
16103 DO 340 JT=1,JTMAX
16104 ID=IREF(IP,JT)
16105 KDCY(JT)=0
16106 KFL1(JT)=0
16107 KFL2(JT)=0
16108 KFL3(JT)=0
16109 KEQL(JT)=0
16110 NSD(JT)=ID
16111 ITJUNC(JT)=0
16112
16113C...Check whether particle can/is allowed to decay.
16114 IF(ID.EQ.0) GOTO 330
16115 KFA=IABS(K(ID,2))
16116 KCA=PYCOMP(KFA)
16117 IF(MWID(KCA).EQ.0) GOTO 330
16118 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16119 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16120 & KFA.EQ.18) IT4=IT4+1
16121 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16122 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16123
16124C...Choose lifetime and determine decay vertex.
16125 IF(K(ID,1).EQ.5) THEN
16126 V(ID,5)=0D0
16127 ELSEIF(K(ID,1).NE.4) THEN
16128 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16129 ENDIF
16130 DO 190 J=1,4
16131 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16132 190 CONTINUE
16133
16134C...Determine whether decay allowed or not.
16135 MOUT=0
16136 IF(MSTJ(22).EQ.2) THEN
16137 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16138 ELSEIF(MSTJ(22).EQ.3) THEN
16139 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16140 ELSEIF(MSTJ(22).EQ.4) THEN
16141 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16142 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16143 ENDIF
16144 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16145 K(ID,1)=4
16146 GOTO 330
16147 ENDIF
16148
16149C...Info for selection of decay channel: sign, pairings.
16150 IF(KCHG(KCA,3).EQ.0) THEN
16151 IPM=2
16152 ELSE
16153 IPM=(5-ISIGN(1,K(ID,2)))/2
16154 ENDIF
16155 KFB=0
16156 IF(JTMAX.EQ.2) THEN
16157 KFB=IABS(K(IREF(IP,3-JT),2))
16158 ELSEIF(JTMAX.EQ.3) THEN
16159 JT2=JT+1-3*(JT/3)
16160 KFB=IABS(K(IREF(IP,JT2),2))
16161 IF(KFB.NE.KFA) THEN
16162 JT2=JT+2-3*((JT+1)/3)
16163 KFB=IABS(K(IREF(IP,JT2),2))
16164 ENDIF
16165 ENDIF
16166
16167C...Select decay channel.
16168 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16169 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16170 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16171 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16172 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16173 IF(WDTE0S.LE.0D0) GOTO 330
16174 RKFL=WDTE0S*PYR(0)
16175 IDL=0
16176 200 IDL=IDL+1
16177 IDC=IDL+MDCY(KCA,2)-1
16178 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16179 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16180 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16181
16182C...Read out flavours and colour charges of decay channel chosen.
16183 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16184 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16185 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16186 KFC1A=PYCOMP(IABS(KFL1(JT)))
16187 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16188 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16189 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16190 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16191 KFC2A=PYCOMP(IABS(KFL2(JT)))
16192 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16193 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16194 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16195 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16196 KCQ3(JT)=0
16197 IF(KFL3(JT).NE.0) THEN
16198 KFC3A=PYCOMP(IABS(KFL3(JT)))
16199 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16200 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16201 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16202 ENDIF
16203
16204C...Set/save further info on channel.
16205 KDCY(JT)=1
16206 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16207 NSD(JT)=N
16208 HGZ(JT,1)=VINT(111)
16209 HGZ(JT,2)=VINT(112)
16210 HGZ(JT,3)=VINT(114)
16211 JTZ=JT
16212
16213C...Select masses; to begin with assume resonances narrow.
16214 DO 220 I=1,3
16215 P(N+I,5)=0D0
16216 PMMN(I)=0D0
16217 IF(I.EQ.1) THEN
16218 KFLW=IABS(KFL1(JT))
16219 KCW=KFC1A
16220 ELSEIF(I.EQ.2) THEN
16221 KFLW=IABS(KFL2(JT))
16222 KCW=KFC2A
16223 ELSEIF(I.EQ.3) THEN
16224 IF(KFL3(JT).EQ.0) GOTO 220
16225 KFLW=IABS(KFL3(JT))
16226 KCW=KFC3A
16227 ENDIF
16228 P(N+I,5)=PMAS(KCW,1)
16229CMRENNA++
16230C...This prevents SUSY/t particles from becoming too light.
16231 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16232 PMMN(I)=PMAS(KCW,1)
16233 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16234 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16235 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16236 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16237 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16238 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16239 PMMN(I)=MIN(PMMN(I),PMSUM)
16240 ENDIF
16241 210 CONTINUE
16242CMRENNA--
16243 ELSEIF(KFLW.EQ.6) THEN
16244 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16245 ENDIF
16246 220 CONTINUE
16247
16248C...Check which two out of three are widest.
16249 IWID1=1
16250 IWID2=2
16251 PWID1=PMAS(KFC1A,2)
16252 PWID2=PMAS(KFC2A,2)
16253 KFLW1=IABS(KFL1(JT))
16254 KFLW2=IABS(KFL2(JT))
16255 IF(KFL3(JT).NE.0) THEN
16256 PWID3=PMAS(KFC3A,2)
16257 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16258 IWID1=3
16259 PWID1=PWID3
16260 KFLW1=IABS(KFL3(JT))
16261 ELSEIF(PWID3.GT.PWID2) THEN
16262 IWID2=3
16263 PWID2=PWID3
16264 KFLW2=IABS(KFL3(JT))
16265 ENDIF
16266 ENDIF
16267
16268C...If all narrow then only check that masses consistent.
16269 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16270 & PWID2.LT.PARP(41))) THEN
16271CMRENNA++
16272C....Handle near degeneracy cases.
16273 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16274 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16275 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16276 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16277 ENDIF
16278 ENDIF
16279CMRENNA--
16280 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16281 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16282 MINT(51)=1
16283 GOTO 720
16284 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16285 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16286 MINT(51)=1
16287 GOTO 720
16288 ENDIF
16289
16290C...For three wide resonances select narrower of three
16291C...according to BW decoupled from rest.
16292 ELSE
16293 PMTOT=P(ID,5)
16294 IF(KFL3(JT).NE.0) THEN
16295 IWID3=6-IWID1-IWID2
16296 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16297 & KFLW1-KFLW2
16298 LOOP=0
16299 230 LOOP=LOOP+1
16300 P(N+IWID3,5)=PYMASS(KFLW3)
16301 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16302 PMTOT=PMTOT-P(N+IWID3,5)
16303 ENDIF
16304C...Select other two correlated within remaining phase space.
16305 IF(IP.EQ.1) THEN
16306 CKIN45=CKIN(45)
16307 CKIN47=CKIN(47)
16308 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16309 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16310 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16311 & P(N+IWID2,5))
16312 CKIN(45)=CKIN45
16313 CKIN(47)=CKIN47
16314 ELSE
16315 CKIN(49)=PMMN(IWID1)
16316 CKIN(50)=PMMN(IWID2)
16317 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16318 & P(N+IWID2,5))
16319 CKIN(49)=0D0
16320 CKIN(50)=0D0
16321 ENDIF
16322 IF(MINT(51).EQ.1) GOTO 720
16323 ENDIF
16324
16325C...Begin fill decay products, with colour flow for coloured objects.
16326 MSTU10=MSTU(10)
16327 MSTU(10)=1
16328 MSTU(19)=1
16329
16330CMRENNA++
16331C...1) Three-body decays of SUSY particles (plus special case top).
16332 IF(KFL3(JT).NE.0) THEN
16333 DO 250 I=N+1,N+3
16334 DO 240 J=1,5
16335 K(I,J)=0
16336 V(I,J)=0D0
16337 240 CONTINUE
16338 MCT(I,1)=0
16339 MCT(I,2)=0
16340 250 CONTINUE
16341 K(N+1,1)=1
16342 K(N+1,2)=KFL1(JT)
16343 K(N+2,1)=1
16344 K(N+2,2)=KFL2(JT)
16345 K(N+3,1)=1
16346 K(N+3,2)=KFL3(JT)
16347 IDIN=ID
16348 CALL PYTBDY(IDIN)
16349
16350C...Set colour flow for t -> W + b + Z.
16351 IF(KFA.EQ.6) THEN
16352 K(N+2,1)=3
16353 ISID=4
16354 IF(KCQM(JT).EQ.-1) ISID=5
16355 IDAU=N+2
16356 K(ID,ISID)=K(ID,ISID)+IDAU
16357 K(IDAU,ISID)=MSTU(5)*ID
16358
16359C...Set colour flow in three-body decays - programmed as special cases.
16360
16361 ELSEIF(KFC2A.LE.6) THEN
16362 K(N+2,1)=3
16363 K(N+3,1)=3
16364 ISID=4
16365 IF(KFL2(JT).LT.0) ISID=5
16366 K(N+2,ISID)=MSTU(5)*(N+3)
16367 K(N+3,9-ISID)=MSTU(5)*(N+2)
16368C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16369 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16370 & .AND.KFL3(JT).NE.0) THEN
16371 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16372C...3-body decays of squarks to colour singlets plus one quark
16373 IF (KQSUMA.EQ.1) THEN
16374C...Find quark
16375 IQ=0
16376 IF (KCQ1(JT).NE.0) IQ=1
16377 IF (KCQ2(JT).NE.0) IQ=2
16378 IF (KCQ3(JT).NE.0) IQ=3
16379 ISID=4
16380 IF (K(N+IQ,2).LT.0) ISID=5
16381 K(N+IQ,1)=3
16382 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16383 K(N+IQ,ISID)=MSTU(5)*ID
16384 ENDIF
16385C...PS--
16386 ENDIF
16387 IF(KFL1(JT).EQ.KSUSY1+21) THEN
16388 K(N+1,1)=3
16389 K(N+2,1)=3
16390 K(N+3,1)=3
16391 ISID=4
16392 IF(KFL2(JT).LT.0) ISID=5
16393 K(N+1,ISID)=MSTU(5)*(N+2)
16394 K(N+1,9-ISID)=MSTU(5)*(N+3)
16395 K(N+2,ISID)=MSTU(5)*(N+1)
16396 K(N+3,9-ISID)=MSTU(5)*(N+1)
16397 ENDIF
16398 IF(KFA.EQ.KSUSY1+21) THEN
16399 K(N+2,1)=3
16400 K(N+3,1)=3
16401 ISID=4
16402 IF(KFL2(JT).LT.0) ISID=5
16403 K(ID,ISID)=K(ID,ISID)+(N+2)
16404 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
16405 K(N+2,ISID)=MSTU(5)*ID
16406 K(N+3,9-ISID)=MSTU(5)*ID
16407 ENDIF
16408 NSAV=N
16409 N=N+3
16410 N=NSAV
16411CMRENNA--
16412
16413 IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
16414 & IABS(KCQ2(JT)).EQ.1) THEN
16415 K(N+2,1)=3
16416 K(N+3,1)=3
16417 ISID=4
16418 IF(KFL2(JT).LT.0) ISID=5
16419 K(N+2,ISID)=MSTU(5)*(N+3)
16420 K(N+3,9-ISID)=MSTU(5)*(N+2)
16421 ENDIF
16422
16423C...Set colour flow in three-body decays with baryon number violation.
16424C...Neutralino and chargino decays first.
16425 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
16426 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
16427 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
16428 K(N+4,4)=ITJUNC(JT)*MSTU(5)
16429C...Insert junction to keep track of colours.
16430 IF(KCQ1(JT).NE.0) K(N+1,1)=3
16431 IF(KCQ2(JT).NE.0) K(N+2,1)=3
16432 IF(KCQ3(JT).NE.0) K(N+3,1)=3
16433C...Set special junction codes:
16434 K(N+4,1)=42
16435 K(N+4,2)=88
16436
16437C...Order decay products by invariant mass. (will be used in PYSTRF).
16438 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)-
16439 & P(N+1,3)*P(N+2,3)
16440 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)-
16441 & P(N+1,3)*P(N+3,3)
16442 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)-
16443 & P(N+2,3)*P(N+3,3)
16444 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
16445 K(N+4,4)=N+3+K(N+4,4)
16446 K(N+4,5)=N+1+MSTU(5)*(N+2)
16447 ELSEIF(PM13.LT.PM23) THEN
16448 K(N+4,4)=N+2+K(N+4,4)
16449 K(N+4,5)=N+1+MSTU(5)*(N+3)
16450 ELSE
16451 K(N+4,4)=N+1+K(N+4,4)
16452 K(N+4,5)=N+2+MSTU(5)*(N+3)
16453 ENDIF
16454 DO 260 J=1,5
16455 P(N+4,J)=0D0
16456 V(N+4,J)=0D0
16457 260 CONTINUE
16458C...Connect daughters to junction.
16459 DO 270 II=N+1,N+3
16460 K(II,4)=0
16461 K(II,5)=0
16462 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
16463 270 CONTINUE
16464C...Particle counter should be stepped up one extra for junction.
16465 N=N+1
16466
16467C...Gluino decays.
16468 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
16469 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
16470 K(N+4,4)=ITJUNC(JT)*MSTU(5)
16471C...Insert junction to keep track of colours.
16472 IF(KCQ1(JT).NE.0) K(N+1,1)=3
16473 IF(KCQ2(JT).NE.0) K(N+2,1)=3
16474 IF(KCQ3(JT).NE.0) K(N+3,1)=3
16475 K(N+4,1)=42
16476 K(N+4,2)=88
16477 DO 280 J=1,5
16478 P(N+4,J)=0D0
16479 V(N+4,J)=0D0
16480 280 CONTINUE
16481 CTMSUM=0D0
16482 DO 290 II=N+1,N+3
16483 K(II,4)=0
16484 K(II,5)=0
16485C...Start by connecting all daughters to junction.
16486 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
16487C...Only consider colour topologies with off shell resonances.
16488 RMQ1=PMAS(PYCOMP(K(II,2)),1)
16489 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
16490 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
16491 IF (RMGLU-RMQ1.LT.RMRES) THEN
16492C...Calculate propagators for each colour topology.
16493 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
16494 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
16495 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
16496 ELSE
16497 CTM2(II-N)=0D0
16498 ENDIF
16499 CTMSUM=CTMSUM+CTM2(II-N)
16500 290 CONTINUE
16501 CTMSUM=PYR(0)*CTMSUM
16502C...Select colour topology J, with most off shell least likely.
16503 J=0
16504 300 J=J+1
16505 CTMSUM=CTMSUM-CTM2(J)
16506 IF (CTMSUM.GT.0D0) GOTO 300
16507C...The lucky winner gets its colour (anti-colour) directly from gluino.
16508 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
16509 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
16510C...The other gluino colour is connected to junction
16511 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
16512 & MSTU(5)
16513 K(N+4,4)=K(N+4,4)+ID
16514C...Lastly, connect junction to remaining daughters.
16515 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
16516C...Particle counter should be stepped up one extra for junction.
16517 N=N+1
16518 ENDIF
16519
16520C...Update particle counter.
16521 N=N+3
16522
16523C...2) Everything else two-body decay.
16524 ELSE
16525 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
16526 MCT(N-1,1)=0
16527 MCT(N-1,2)=0
16528 MCT(N,1)=0
16529 MCT(N,2)=0
16530C...First set colour flow as if mother colour singlet.
16531 IF(KCQ1(JT).NE.0) THEN
16532 K(N-1,1)=3
16533 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
16534 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
16535 ENDIF
16536 IF(KCQ2(JT).NE.0) THEN
16537 K(N,1)=3
16538 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
16539 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
16540 ENDIF
16541C...Then redirect colour flow if mother (anti)triplet.
16542 IF(KCQM(JT).EQ.0) THEN
16543 ELSEIF(KCQM(JT).NE.2) THEN
16544 ISID=4
16545 IF(KCQM(JT).EQ.-1) ISID=5
16546 IDAU=N-1
16547 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
16548 K(ID,ISID)=K(ID,ISID)+IDAU
16549 K(IDAU,ISID)=MSTU(5)*ID
16550C...Then redirect colour flow if mother octet.
16551 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
16552 IDAU=N-1
16553 IF(KCQ1(JT).EQ.0) IDAU=N
16554 K(ID,4)=K(ID,4)+IDAU
16555 K(ID,5)=K(ID,5)+IDAU
16556 K(IDAU,4)=MSTU(5)*ID
16557 K(IDAU,5)=MSTU(5)*ID
16558 ELSE
16559 ISID=4
16560 IF(KCQ1(JT).EQ.-1) ISID=5
16561 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
16562 K(ID,ISID)=K(ID,ISID)+(N-1)
16563 K(ID,9-ISID)=K(ID,9-ISID)+N
16564 K(N-1,ISID)=MSTU(5)*ID
16565 K(N,9-ISID)=MSTU(5)*ID
16566 ENDIF
16567
16568C...Insert junction
16569 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
16570 N=N+1
16571C...~q* mother: type 3 junction. ~q mother: type 4.
16572 ITJUNC(JT)=(7+KCQM(JT))/2
16573C...Specify junction KF and set colour flow from junction
16574 K(N,1)=42
16575 K(N,2)=88
16576 K(N,3)=ID
16577C...Junction type encoded together with mother:
16578 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
16579 K(N,5)=N-1+MSTU(5)*(N-2)
16580C...Zero P and V for junction (V filled later)
16581 DO 310 J=1,5
16582 P(N,J)=0D0
16583 V(N,J)=0D0
16584 310 CONTINUE
16585C...Set colour flow from mother to junction
16586 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
16587C...Set colour flow from daughters to junction
16588 DO 320 II=N-2,N-1
16589 K(II,4) = 0
16590 K(II,5) = 0
16591C...(Anti-)colour mother is junction.
16592 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
16593 320 CONTINUE
16594 ENDIF
16595 ENDIF
16596
16597C...End loop over resonances for daughter flavour and mass selection.
16598 MSTU(10)=MSTU10
16599 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
16600 & NINH=NINH+1
16601 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
16602 & KFL1(JT).EQ.0) THEN
16603 WRITE(CODE,'(I9)') K(ID,2)
16604 WRITE(MASS,'(F9.3)') P(ID,5)
16605 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
16606 & CODE//' with mass'//MASS)
16607 MINT(51)=1
16608 GOTO 720
16609 ENDIF
16610 340 CONTINUE
16611
16612C...Check for allowed combinations. Skip if no decays.
16613 IF(JTMAX.EQ.1) THEN
16614 IF(KDCY(1).EQ.0) GOTO 710
16615 ELSEIF(JTMAX.EQ.2) THEN
16616 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
16617 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
16618 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
16619 ELSEIF(JTMAX.EQ.3) THEN
16620 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
16621 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
16622 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
16623 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
16624 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
16625 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
16626 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
16627 ENDIF
16628
16629C...Special case: matrix element option for Z0 decay to quarks.
16630 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
16631 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
16632
16633C...Check consistency of MSTJ options set.
16634 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
16635 CALL PYERRM(6,
16636 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
16637 MSTJ(110)=1
16638 ENDIF
16639 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
16640 CALL PYERRM(6,
16641 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
16642
16643 MSTJ(111)=0
16644 ENDIF
16645
16646C...Select alpha_strong behaviour.
16647 MST111=MSTU(111)
16648 PAR112=PARU(112)
16649 MSTU(111)=MSTJ(108)
16650 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
16651 & MSTU(111)=1
16652 PARU(112)=PARJ(121)
16653 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
16654
16655C...Find axial fraction in total cross section for scalar gluon model.
16656 PARJ(171)=0D0
16657 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
16658 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
16659 POLL=1D0-PARJ(131)*PARJ(132)
16660 SFF=1D0/(16D0*XW*XW1)
16661 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
16662 & (PARJ(123)*PARJ(124))**2)
16663 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
16664 VE=4D0*XW-1D0
16665 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
16666 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
16667 & (PARJ(132)-PARJ(131)))
16668 KFLC=IABS(KFL1(1))
16669 PMQ=PYMASS(KFLC)
16670 QF=KCHG(KFLC,1)/3D0
16671 VQ=1D0
16672 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
16673 & 1D0-(2D0*PMQ/P(ID,5))**2))
16674 VF=SIGN(1D0,QF)-4D0*QF*XW
16675 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
16676 & VF**2*HF1W)+VQ**3*HF1W
16677 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
16678 ENDIF
16679
16680C...Choice of jet configuration.
16681 CALL PYXJET(P(ID,5),NJET,CUT)
16682 KFLC=IABS(KFL1(1))
16683 KFLN=21
16684 IF(NJET.EQ.4) THEN
16685 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
16686 ELSEIF(NJET.EQ.3) THEN
16687 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
16688 ELSE
16689 MSTJ(120)=1
16690 ENDIF
16691
16692C...Fill jet configuration; return if incorrect kinematics.
16693 NC=N-2
16694 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
16695 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
16696 ELSEIF(NJET.EQ.2) THEN
16697 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
16698 ELSEIF(NJET.EQ.3) THEN
16699 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
16700 ELSEIF(KFLN.EQ.21) THEN
16701 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
16702 & X12,X14)
16703 ELSE
16704 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
16705 & X12,X14)
16706 ENDIF
16707 IF(MSTU(24).NE.0) THEN
16708 MINT(51)=1
16709 MSTU(111)=MST111
16710 PARU(112)=PAR112
16711 GOTO 720
16712 ENDIF
16713
16714C...Angular orientation according to matrix element.
16715 IF(MSTJ(106).EQ.1) THEN
16716 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
16717 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
16718 CTHE(1)=COS(THEZ)
16719 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
16720 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
16721 ENDIF
16722
16723C...Boost partons to Z0 rest frame.
16724 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
16725 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
16726
16727C...Mark decayed resonance and add documentation lines,
16728 K(ID,1)=K(ID,1)+10
16729 IDOC=MINT(83)+MINT(4)
16730 DO 360 I=NC+1,N
16731 I1=MINT(83)+MINT(4)+1
16732 K(I,3)=I1
16733 IF(MSTP(128).GE.1) K(I,3)=ID
16734 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
16735 MINT(4)=MINT(4)+1
16736 K(I1,1)=21
16737 K(I1,2)=K(I,2)
16738 K(I1,3)=IREF(IP,4)
16739 DO 350 J=1,5
16740 P(I1,J)=P(I,J)
16741 350 CONTINUE
16742 ENDIF
16743 360 CONTINUE
16744
16745C...Generate parton shower.
16746 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
16747 CALL PYSHOW(N-1,N,P(ID,5))
16748 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
16749 NPART=2
16750 IPART(1)=N-1
16751 IPART(2)=N
16752 PTPART(1)=0.5D0*P(ID,5)
16753 PTPART(2)=PTPART(1)
16754 NCT=NCT+1
16755 IF(K(N-1,2).GT.0) THEN
16756 MCT(N-1,1)=NCT
16757 MCT(N,2)=NCT
16758 ELSE
16759 MCT(N-1,2)=NCT
16760 MCT(N,1)=NCT
16761 ENDIF
16762 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
16763 ENDIF
16764
16765C... End special case for Z0: skip ahead.
16766 MSTU(111)=MST111
16767 PARU(112)=PAR112
16768 GOTO 700
16769 ENDIF
16770
16771C...Order incoming partons and outgoing resonances.
16772 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
16773 &NINH.EQ.0) THEN
16774 ILIN(1)=MINT(84)+1
16775 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
16776 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
16777 & ILIN(1)=2*MINT(84)+3-ILIN(1)
16778 ILIN(2)=2*MINT(84)+3-ILIN(1)
16779 IMIN=1
16780 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16781 & .EQ.36) IMIN=3
16782 IMAX=2
16783 IORD=1
16784 IF(K(IREF(IP,1),2).EQ.23) IORD=2
16785 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
16786 IAKIPD=IABS(K(IREF(IP,IORD),2))
16787 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
16788 IF(KDCY(IORD).EQ.0) IORD=3-IORD
16789
16790C...Order decay products of resonances.
16791 DO 370 JT=IORD,3-IORD,3-2*IORD
16792 IF(KDCY(JT).EQ.0) THEN
16793 ILIN(IMAX+1)=NSD(JT)
16794 IMAX=IMAX+1
16795 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
16796 ILIN(IMAX+1)=N+2*JT-1
16797 ILIN(IMAX+2)=N+2*JT
16798 IMAX=IMAX+2
16799 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
16800 K(N+2*JT,2)=K(NSD(JT)+2,2)
16801 ELSE
16802 ILIN(IMAX+1)=N+2*JT
16803
16804 ILIN(IMAX+2)=N+2*JT-1
16805 IMAX=IMAX+2
16806 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
16807 K(N+2*JT,2)=K(NSD(JT)+2,2)
16808 ENDIF
16809 370 CONTINUE
16810
16811C...Find charge, isospin, left- and righthanded couplings.
16812 DO 390 I=IMIN,IMAX
16813 DO 380 J=1,4
16814 COUP(I,J)=0D0
16815 380 CONTINUE
16816 KFA=IABS(K(ILIN(I),2))
16817 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
16818 COUP(I,1)=KCHG(KFA,1)/3D0
16819 COUP(I,2)=(-1)**MOD(KFA,2)
16820 COUP(I,4)=-2D0*COUP(I,1)*XWV
16821 COUP(I,3)=COUP(I,2)+COUP(I,4)
16822 390 CONTINUE
16823
16824C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
16825 IF(ISUB.EQ.22) THEN
16826 DO 420 I=3,5,2
16827 I1=IORD
16828 IF(I.EQ.5) I1=3-IORD
16829 DO 410 J1=1,2
16830 DO 400 J2=1,2
16831 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
16832 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
16833 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
16834 & COUP(I,J2+2)**2
16835 400 CONTINUE
16836 410 CONTINUE
16837 420 CONTINUE
16838 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
16839 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
16840 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
16841 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
16842
16843 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
16844 ENDIF
16845 ENDIF
16846
16847C...Select angular orientation type - Z'/W' only.
16848 MZPWP=0
16849 IF(ISUB.EQ.141) THEN
16850 IF(PYR(0).LT.PARU(130)) MZPWP=1
16851 IF(IP.EQ.2) THEN
16852 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
16853 IAKIR=IABS(K(IREF(2,2),2))
16854 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
16855 IF(IAKIR.LE.20) MZPWP=2
16856 ENDIF
16857 IF(IP.GE.3) MZPWP=2
16858 ELSEIF(ISUB.EQ.142) THEN
16859 IF(PYR(0).LT.PARU(136)) MZPWP=1
16860 IF(IP.EQ.2) THEN
16861 IAKIR=IABS(K(IREF(2,2),2))
16862 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
16863 IF(IAKIR.LE.20) MZPWP=2
16864 ENDIF
16865 IF(IP.GE.3) MZPWP=2
16866 ENDIF
16867
16868C...Select random angles (begin of weighting procedure).
16869 430 DO 440 JT=1,JTMAX
16870 IF(KDCY(JT).EQ.0) GOTO 440
16871 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
16872 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
16873 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
16874 PHI(JT)=VINT(24)
16875 ELSE
16876 CTHE(JT)=2D0*PYR(0)-1D0
16877 PHI(JT)=PARU(2)*PYR(0)
16878 ENDIF
16879 440 CONTINUE
16880
16881 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
16882C...Construct massless four-vectors.
16883 DO 460 I=N+1,N+4
16884 K(I,1)=1
16885 DO 450 J=1,5
16886 P(I,J)=0D0
16887 V(I,J)=0D0
16888 450 CONTINUE
16889 460 CONTINUE
16890 DO 470 JT=1,JTMAX
16891 IF(KDCY(JT).EQ.0) GOTO 470
16892 ID=IREF(IP,JT)
16893 P(N+2*JT-1,3)=0.5D0*P(ID,5)
16894 P(N+2*JT-1,4)=0.5D0*P(ID,5)
16895 P(N+2*JT,3)=-0.5D0*P(ID,5)
16896 P(N+2*JT,4)=0.5D0*P(ID,5)
16897 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
16898 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
16899 470 CONTINUE
16900
16901C...Store incoming and outgoing momenta, with random rotation to
16902C...avoid accidental zeroes in HA expressions.
16903 IF(ISUB.NE.0) THEN
16904 DO 490 I=IMIN,IMAX
16905 K(N+4+I,1)=1
16906 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
16907 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
16908 P(N+4+I,5)=P(ILIN(I),5)
16909 DO 480 J=1,3
16910 P(N+4+I,J)=P(ILIN(I),J)
16911 480 CONTINUE
16912 490 CONTINUE
16913 500 THERR=ACOS(2D0*PYR(0)-1D0)
16914 PHIRR=PARU(2)*PYR(0)
16915 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
16916 DO 520 I=IMIN,IMAX
16917 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
16918 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
16919 DO 510 J=1,4
16920 PK(I,J)=P(N+4+I,J)
16921 510 CONTINUE
16922 520 CONTINUE
16923 ENDIF
16924
16925C...Calculate internal products.
16926 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
16927 & ISUB.EQ.142) THEN
16928 DO 540 I1=IMIN,IMAX-1
16929 DO 530 I2=I1+1,IMAX
16930 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
16931 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
16932 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
16933 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
16934 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
16935 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
16936 HC(I1,I2)=CONJG(HA(I1,I2))
16937 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
16938 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
16939 HA(I2,I1)=-HA(I1,I2)
16940 HC(I2,I1)=-HC(I1,I2)
16941 530 CONTINUE
16942 540 CONTINUE
16943 ENDIF
16944
16945C...Calculate four-products.
16946 IF(ISUB.NE.0) THEN
16947 DO 560 I=1,2
16948 DO 550 J=1,4
16949 PK(I,J)=-PK(I,J)
16950 550 CONTINUE
16951 560 CONTINUE
16952 DO 580 I1=IMIN,IMAX-1
16953 DO 570 I2=I1+1,IMAX
16954 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
16955 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
16956 PKK(I2,I1)=PKK(I1,I2)
16957 570 CONTINUE
16958 580 CONTINUE
16959 ENDIF
16960 ENDIF
16961
16962 KFAGM=IABS(IREF(IP,7))
16963 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
16964C...Isotropic decay selected by user.
16965 WT=1D0
16966 WTMAX=1D0
16967
16968 ELSEIF(JTMAX.EQ.3) THEN
16969C...Isotropic decay when three mother particles.
16970 WT=1D0
16971 WTMAX=1D0
16972
16973 ELSEIF(IT4.GE.1) THEN
16974C... Isotropic decay t -> b + W etc for 4th generation q and l.
16975 WT=1D0
16976 WTMAX=1D0
16977
16978 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
16979 & IREF(IP,7).EQ.36) THEN
16980C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
16981C...CP-odd case added by Kari Ertresvag Myklevoll.
16982C...Now also with mixed Higgs CP-states
16983 ETA=PARP(25)
16984 IF(IP.EQ.1) WTMAX=SH**2
16985 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
16986 KFA=IABS(K(IREF(IP,1),2))
16987
16988 IF((KFA.EQ.23.OR.KFA.EQ.24).AND.MSTP(25).GE.3) THEN
16989C...For mixed CP states need epsilon product.
16990 P10=PK(3,4)
16991 P20=PK(4,4)
16992 P30=PK(5,4)
16993 P40=PK(6,4)
16994 P11=PK(3,1)
16995 P21=PK(4,1)
16996 P31=PK(5,1)
16997 P41=PK(6,1)
16998 P12=PK(3,2)
16999 P22=PK(4,2)
17000 P32=PK(5,2)
17001 P42=PK(6,2)
17002 P13=PK(3,3)
17003 P23=PK(4,3)
17004 P33=PK(5,3)
17005 P43=PK(6,3)
17006 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17007 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17008 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17009 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17010 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17011 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17012 & P22*P30*P41+P13*P22*P31*P40
17013C...For mixed CP states need gauge boson masses.
17014 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17015 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17016 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17017 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17018 XMV=PMAS(KFA,1)
17019 ENDIF
17020
17021C...Z decay
17022 IF(KFA.EQ.23) THEN
17023 KFLF1A=IABS(KFL1(1))
17024 EF1=KCHG(KFLF1A,1)/3D0
17025 AF1=SIGN(1D0,EF1+0.1D0)
17026 VF1=AF1-4D0*EF1*XWV
17027 KFLF2A=IABS(KFL1(2))
17028 EF2=KCHG(KFLF2A,1)/3D0
17029 AF2=SIGN(1D0,EF2+0.1D0)
17030 VF2=AF2-4D0*EF2*XWV
17031 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17032 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17033 & THEN
17034C...CP-even decay
17035 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17036 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17037 ELSEIF(MSTP(25).LE.2) THEN
17038C...CP-odd decay
17039 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17040 & -2*PKK(3,4)*PKK(5,6)
17041 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17042 & (PKK(3,4)*PKK(5,6))
17043 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17044 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17045 ELSE
17046C...Mixed CP states.
17047 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17048 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17049 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17050 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17051 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17052 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17053 & +PKK(3,4)*PKK(5,6)
17054 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17055 & +VA12AS*PKK(3,4)*PKK(5,6)
17056 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17057 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17058 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17059 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17060 ENDIF
17061
17062C...W decay
17063 ELSEIF(KFA.EQ.24) THEN
17064 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17065 & THEN
17066C...CP-even decay
17067 WT=16D0*PKK(3,5)*PKK(4,6)
17068 ELSEIF(MSTP(25).LE.2) THEN
17069C...CP-odd decay
17070 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17071 & -2*PKK(3,4)*PKK(5,6)
17072 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17073 & (PKK(3,4)*PKK(5,6))
17074 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17075 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17076 ELSE
17077C...Mixed CP states.
17078 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17079 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17080 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17081 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17082 & +PKK(3,4)*PKK(5,6)
17083 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17084 & +PKK(3,4)*PKK(5,6)
17085 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17086 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17087 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17088 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17089 ENDIF
17090
17091C...No angular correlations in other Higgs decays.
17092 ELSE
17093 WT=WTMAX
17094 ENDIF
17095
17096 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17097 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17098 & THEN
17099C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17100 I1=IREF(IP,8)
17101 IF(MOD(KFAGM,2).EQ.0) THEN
17102 I2=N+1
17103 I3=N+2
17104 ELSE
17105 I2=N+2
17106 I3=N+1
17107 ENDIF
17108 I4=IREF(IP,2)
17109 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17110 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17111 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17112 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17113
17114 ELSEIF(ISUB.EQ.1) THEN
17115C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17116 EI=KCHG(IABS(MINT(15)),1)/3D0
17117 AI=SIGN(1D0,EI+0.1D0)
17118 VI=AI-4D0*EI*XWV
17119 EF=KCHG(IABS(KFL1(1)),1)/3D0
17120 AF=SIGN(1D0,EF+0.1D0)
17121
17122 VF=AF-4D0*EF*XWV
17123 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17124 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17125 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17126 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17127 & (VI**2+AI**2)*VINT(114)*VF**2)
17128 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17129 & 4D0*VI*AI*VINT(114)*VF*AF)
17130 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17131 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17132 WTMAX=2D0*(WT1+ABS(WT3))
17133
17134 ELSEIF(ISUB.EQ.2) THEN
17135C...Angular weight for W+/- -> 2 quarks/leptons.
17136 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17137 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17138 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17139 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17140 WTMAX=4D0
17141
17142 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17143C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17144C...-> gluon/gamma + 2 quarks/leptons.
17145 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17146 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17147 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17148 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17149 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17150 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17151 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17152 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17153 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17154 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17155 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17156 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17157 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17158 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17159 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17160 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17161
17162 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17163C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17164C...-> gluon/gamma + 2 quarks/leptons.
17165 WT=PKK(1,3)**2+PKK(2,4)**2
17166 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17167
17168 ELSEIF(ISUB.EQ.22) THEN
17169C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17170 S34=P(IREF(IP,IORD),5)**2
17171 S56=P(IREF(IP,3-IORD),5)**2
17172 TI=PKK(1,3)+PKK(1,4)+S34
17173 UI=PKK(1,5)+PKK(1,6)+S56
17174 TIR=REAL(TI)
17175 UIR=REAL(UI)
17176 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17177 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17178 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17179 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17180 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17181 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17182 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17183 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17184
17185 WT=
17186 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17187 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17188 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17189 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17190 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17191 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17192 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17193 & 1D0/UI**2))
17194
17195 ELSEIF(ISUB.EQ.23) THEN
17196C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17197 D34=P(IREF(IP,IORD),5)**2
17198 D56=P(IREF(IP,3-IORD),5)**2
17199 DT=PKK(1,3)+PKK(1,4)+D34
17200 DU=PKK(1,5)+PKK(1,6)+D56
17201 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17202 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17203 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17204 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17205
17206 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17207 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17208 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17209 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17210 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17211 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17212
17213 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17214C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17215C...(or H0, or A0).
17216 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17217 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17218 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17219 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17220 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17221
17222 ELSEIF(ISUB.EQ.25) THEN
17223C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17224 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17225 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17226 D34=P(IREF(IP,IORD),5)**2
17227 D56=P(IREF(IP,3-IORD),5)**2
17228 DT=PKK(1,3)+PKK(1,4)+D34
17229 DU=PKK(1,5)+PKK(1,6)+D56
17230 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17231 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17232 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17233 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17234 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17235 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17236 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17237 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17238 IF(MSTP(50).LE.0) THEN
17239 WT=FGK135**2+(CCWW*FGK253)**2
17240 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17241 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17242 & DJGK(DT,DU)))
17243 ELSE
17244 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17245 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17246 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17247 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17248 ENDIF
17249
17250 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17251C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17252C...(or H0, or A0).
17253 WT=PKK(1,3)*PKK(2,4)
17254 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17255
17256 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17257C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17258C...-> f + 2 quarks/leptons.
17259 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17260 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17261 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17262 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17263 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17264 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17265 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17266 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17267 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17268 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17269 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17270 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17271 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17272 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17273 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17274 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17275 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17276 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17277
17278 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17279C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17280 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17281 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17282 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17283
17284 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17285 & ISUB.EQ.77) THEN
17286C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17287 WT=16D0*PKK(3,5)*PKK(4,6)
17288 WTMAX=SH**2
17289
17290 ELSEIF(ISUB.EQ.110) THEN
17291C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17292 WT=1D0
17293 WTMAX=1D0
17294
17295 ELSEIF(ISUB.EQ.141) THEN
17296 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17297C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17298C...Couplings of incoming flavour.
17299 KFAI=IABS(MINT(15))
17300 EI=KCHG(KFAI,1)/3D0
17301 AI=SIGN(1D0,EI+0.1D0)
17302 VI=AI-4D0*EI*XWV
17303 KFAIC=1
17304 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17305 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17306 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17307 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17308 VPI=PARU(119+2*KFAIC)
17309 API=PARU(120+2*KFAIC)
17310 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17311 VPI=PARJ(178+2*KFAIC)
17312 API=PARJ(179+2*KFAIC)
17313 ELSE
17314 VPI=PARJ(186+2*KFAIC)
17315 API=PARJ(187+2*KFAIC)
17316 ENDIF
17317C...Couplings of final flavour.
17318 KFAF=IABS(KFL1(1))
17319 EF=KCHG(KFAF,1)/3D0
17320 AF=SIGN(1D0,EF+0.1D0)
17321 VF=AF-4D0*EF*XWV
17322 KFAFC=1
17323 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17324 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17325 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17326 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17327 VPF=PARU(119+2*KFAFC)
17328 APF=PARU(120+2*KFAFC)
17329 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17330 VPF=PARJ(178+2*KFAFC)
17331 APF=PARJ(179+2*KFAFC)
17332 ELSE
17333 VPF=PARJ(186+2*KFAFC)
17334 APF=PARJ(187+2*KFAFC)
17335 ENDIF
17336C...Asymmetry and weight.
17337 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17338 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17339 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17340 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17341 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17342 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17343 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17344 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17345 WTMAX=2D0+ABS(ASYM)
17346 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17347C...Angular weight for f + fbar -> Z' -> W+ + W-.
17348 RM1=P(NSD(1)+1,5)**2/SH
17349 RM2=P(NSD(1)+2,5)**2/SH
17350 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17351 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17352 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17353 & (RM2-RM1)**2)
17354 WT=CFLAT+CCOS2*CTHE(1)**2
17355 WTMAX=CFLAT+MAX(0D0,CCOS2)
17356 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17357 & IABS(KFL1(1)).EQ.37)) THEN
17358C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17359 WT=1D0-CTHE(1)**2
17360 WTMAX=1D0
17361 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17362C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17363 RM1=P(NSD(1)+1,5)**2/SH
17364 RM2=P(NSD(1)+2,5)**2/SH
17365 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17366 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17367 WTMAX=1D0+FLAM2/(8D0*RM1)
17368 ELSEIF(MZPWP.EQ.0) THEN
17369C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17370C...(W:s like if intermediate Z).
17371 D34=P(IREF(IP,IORD),5)**2
17372 D56=P(IREF(IP,3-IORD),5)**2
17373 DT=PKK(1,3)+PKK(1,4)+D34
17374 DU=PKK(1,5)+PKK(1,6)+D56
17375 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17376 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17377 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17378 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17379 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17380 ELSEIF(MZPWP.EQ.1) THEN
17381C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17382C...(W:s approximately longitudinal, like if intermediate H).
17383 WT=16D0*PKK(3,5)*PKK(4,6)
17384 WTMAX=SH**2
17385 ELSE
17386C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17387C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17388 WT=1D0
17389 WTMAX=1D0
17390 ENDIF
17391
17392 ELSEIF(ISUB.EQ.142) THEN
17393 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17394C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17395 KFAI=IABS(MINT(15))
17396 KFAIC=1
17397 IF(KFAI.GT.10) KFAIC=2
17398 VI=PARU(129+2*KFAIC)
17399 AI=PARU(130+2*KFAIC)
17400 KFAF=IABS(KFL1(1))
17401 KFAFC=1
17402 IF(KFAF.GT.10) KFAFC=2
17403 VF=PARU(129+2*KFAFC)
17404 AF=PARU(130+2*KFAFC)
17405 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
17406 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17407 WTMAX=2D0+ABS(ASYM)
17408 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
17409C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
17410 RM1=P(NSD(1)+1,5)**2/SH
17411 RM2=P(NSD(1)+2,5)**2/SH
17412 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17413 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17414 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17415 & (RM2-RM1)**2)
17416 WT=CFLAT+CCOS2*CTHE(1)**2
17417 WTMAX=CFLAT+MAX(0D0,CCOS2)
17418 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17419C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
17420 RM1=P(NSD(1)+1,5)**2/SH
17421 RM2=P(NSD(1)+2,5)**2/SH
17422 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17423 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17424 WTMAX=1D0+FLAM2/(8D0*RM1)
17425 ELSEIF(MZPWP.EQ.0) THEN
17426C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
17427C...(W/Z like if intermediate W).
17428 D34=P(IREF(IP,IORD),5)**2
17429 D56=P(IREF(IP,3-IORD),5)**2
17430 DT=PKK(1,3)+PKK(1,4)+D34
17431 DU=PKK(1,5)+PKK(1,6)+D56
17432 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17433 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
17434 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17435 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
17436 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17437 ELSEIF(MZPWP.EQ.1) THEN
17438C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
17439C...(W/Z approximately longitudinal, like if intermediate H).
17440 WT=16D0*PKK(3,5)*PKK(4,6)
17441 WTMAX=SH**2
17442 ELSE
17443C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
17444C...t + bbar -> t + W + bbar.
17445 WT=1D0
17446 WTMAX=1D0
17447 ENDIF
17448
17449 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
17450 & THEN
17451C...Isotropic decay of leptoquarks (assumed spin 0).
17452 WT=1D0
17453 WTMAX=1D0
17454
17455 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
17456C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
17457 SIDE=1D0
17458 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
17459 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
17460 WT=1D0+SIDE*CTHE(1)
17461 WTMAX=2D0
17462 ELSEIF(IP.EQ.1) THEN
17463
17464 RM1=P(NSD(1)+1,5)**2/SH
17465 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
17466 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
17467 ELSE
17468C...W/Z decay assumed isotropic, since not known.
17469 WT=1D0
17470 WTMAX=1D0
17471 ENDIF
17472
17473 ELSEIF(ISUB.EQ.149) THEN
17474C...Isotropic decay of techni-eta.
17475 WT=1D0
17476 WTMAX=1D0
17477
17478 ELSEIF(ISUB.EQ.191) THEN
17479 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
17480C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
17481C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
17482 WT=1D0-CTHE(1)**2
17483 WTMAX=1D0
17484 ELSEIF(IP.EQ.1) THEN
17485C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
17486 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
17487 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
17488 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17489 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17490 KFAI=IABS(MINT(15))
17491 EI=KCHG(KFAI,1)/3D0
17492 AI=SIGN(1D0,EI+0.1D0)
17493 VI=AI-4D0*EI*XWV
17494 VALI=0.5D0*(VI+AI)
17495 VARI=0.5D0*(VI-AI)
17496 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
17497 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
17498 KFAF=IABS(KFL1(1))
17499 EF=KCHG(KFAF,1)/3D0
17500 AF=SIGN(1D0,EF+0.1D0)
17501 VF=AF-4D0*EF*XWV
17502 VALF=0.5D0*(VF+AF)
17503 VARF=0.5D0*(VF-AF)
17504 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
17505 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
17506 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
17507 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
17508 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
17509 WTMAX=4D0*MAX(ASAME,AFLIP)
17510 ELSE
17511C...Isotropic decay of W/pi_tc produced in rho_tc decay.
17512 WT=1D0
17513 WTMAX=1D0
17514 ENDIF
17515
17516 ELSEIF(ISUB.EQ.192) THEN
17517 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
17518C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
17519C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
17520 WT=1D0-CTHE(1)**2
17521 WTMAX=1D0
17522 ELSEIF(IP.EQ.1) THEN
17523C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
17524 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
17525 WT=(1D0+CTHESG)**2
17526 WTMAX=4D0
17527 ELSE
17528C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
17529 WT=1D0
17530 WTMAX=1D0
17531 ENDIF
17532
17533 ELSEIF(ISUB.EQ.193) THEN
17534 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
17535C...Angular weight for f + fbar -> omega_tc0 ->
17536C...gamma pi_tc0 or Z0 pi_tc0.
17537 WT=1D0+CTHE(1)**2
17538 WTMAX=2D0
17539 ELSEIF(IP.EQ.1) THEN
17540C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
17541 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
17542 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
17543 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
17544 KFAI=IABS(MINT(15))
17545 EI=KCHG(KFAI,1)/3D0
17546 AI=SIGN(1D0,EI+0.1D0)
17547 VI=AI-4D0*EI*XWV
17548 VALI=0.5D0*(VI+AI)
17549 VARI=0.5D0*(VI-AI)
17550 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
17551 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
17552 KFAF=IABS(KFL1(1))
17553 EF=KCHG(KFAF,1)/3D0
17554 AF=SIGN(1D0,EF+0.1D0)
17555 VF=AF-4D0*EF*XWV
17556 VALF=0.5D0*(VF+AF)
17557 VARF=0.5D0*(VF-AF)
17558 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
17559 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
17560 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
17561 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
17562 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
17563 WTMAX=4D0*MAX(BSAME,BFLIP)
17564 ELSE
17565C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
17566 WT=1D0
17567 WTMAX=1D0
17568 ENDIF
17569
17570 ELSEIF(ISUB.EQ.353) THEN
17571C...Angular weight for Z_R0 -> 2 quarks/leptons.
17572 EI=KCHG(IABS(MINT(15)),1)/3D0
17573 AI=SIGN(1D0,EI+0.1D0)
17574 VI=AI-4D0*EI*XWV
17575 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
17576 AF=SIGN(1D0,EF+0.1D0)
17577 VF=AF-4D0*EF*XWV
17578 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
17579 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
17580 WT2=RMF*(VI**2+AI**2)*VF**2
17581 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
17582 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17583 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17584 WTMAX=2D0*(WT1+ABS(WT3))
17585
17586 ELSEIF(ISUB.EQ.354) THEN
17587C...Angular weight for W_R+/- -> 2 quarks/leptons.
17588 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
17589 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
17590 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17591 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17592 WTMAX=4D0
17593
17594 ELSEIF(ISUB.EQ.391) THEN
17595C...Angular weight for f + fbar -> G* -> f + fbar
17596 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
17597 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
17598 WTMAX=2D0
17599C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
17600C...implemented by M.-C. Lemaire
17601 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
17602 & IABS(KFL1(1)).EQ.22)) THEN
17603 WT=1D0-CTHE(1)**4
17604 WTMAX=1D0
17605C...Other G* decays not yet implemented angular distributions.
17606 ELSE
17607 WT=1D0
17608 WTMAX=1D0
17609 ENDIF
17610
17611 ELSEIF(ISUB.EQ.392) THEN
17612C...Angular weight for g + g -> G* -> f + fbar
17613 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
17614 WT=1D0-CTHE(1)**4
17615 WTMAX=1D0
17616C...Angular weight for g + g -> G* -> gamma +gamma or g + g
17617C...implemented by M.-C. Lemaire
17618 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
17619 & IABS(KFL1(1)).EQ.22)) THEN
17620 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
17621 WTMAX=8D0
17622C...Other G* decays not yet implemented angular distributions.
17623 ELSE
17624 WT=1D0
17625 WTMAX=1D0
17626 ENDIF
17627
17628C...Obtain correct angular distribution by rejection techniques.
17629 ELSE
17630 WT=1D0
17631 WTMAX=1D0
17632 ENDIF
17633 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
17634
17635C...Construct massive four-vectors using angles chosen.
17636 590 DO 690 JT=1,JTMAX
17637 IF(KDCY(JT).EQ.0) GOTO 690
17638 ID=IREF(IP,JT)
17639 DO 600 J=1,5
17640 DPMO(J)=P(ID,J)
17641 600 CONTINUE
17642 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
17643CMRENNA++
17644 IF(KFL3(JT).EQ.0) THEN
17645 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
17646 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
17647 N0=NSD(JT)+2
17648 ELSE
17649 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
17650 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
17651 N0=NSD(JT)+3
17652 ENDIF
17653
17654 DO 610 J=1,4
17655 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17656 610 CONTINUE
17657C...Fill in position of decay vertex.
17658 DO 630 I=NSD(JT)+1,N0
17659 DO 620 J=1,4
17660 V(I,J)=VDCY(J)
17661 620 CONTINUE
17662 V(I,5)=0D0
17663
17664 630 CONTINUE
17665CMRENNA--
17666
17667C...Mark decayed resonances; trace history.
17668 K(ID,1)=K(ID,1)+10
17669 KFA=IABS(K(ID,2))
17670 KCA=PYCOMP(KFA)
17671 IF(KCQM(JT).NE.0) THEN
17672C...Do not kill colour flow through coloured resonance!
17673 ELSE
17674 K(ID,4)=NSD(JT)+1
17675 K(ID,5)=NSD(JT)+2
17676C...If 3-body or 2-body with junction:
17677 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
17678C...If 3-body with junction:
17679 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
17680 ENDIF
17681
17682C...Add documentation lines.
17683 ISUBRG=MAX(1,MIN(500,MINT(1)))
17684 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
17685 IDOC=MINT(83)+MINT(4)
17686CMRENNA+++
17687 IHI=NSD(JT)+2
17688 IF(KFL3(JT).NE.0) IHI=IHI+1
17689 DO 650 I=NSD(JT)+1,IHI
17690CMRENNA---
17691 I1=MINT(83)+MINT(4)+1
17692 K(I,3)=I1
17693 IF(MSTP(128).GE.1) K(I,3)=ID
17694 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17695 MINT(4)=MINT(4)+1
17696 K(I1,1)=21
17697 K(I1,2)=K(I,2)
17698 K(I1,3)=IREF(IP,JT+3)
17699 DO 640 J=1,5
17700 P(I1,J)=P(I,J)
17701 640 CONTINUE
17702 ENDIF
17703 650 CONTINUE
17704 ELSE
17705 K(NSD(JT)+1,3)=ID
17706 K(NSD(JT)+2,3)=ID
17707C...If 3-body or 2-body with junction:
17708 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
17709C...If 3-body with junction:
17710 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
17711 ENDIF
17712
17713C...Do showering of two or three objects.
17714 NSHBEF=N
17715 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
17716 IF(KFL3(JT).EQ.0) THEN
17717 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
17718 ELSE
17719 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
17720 ENDIF
17721
17722c...For pT-ordered shower need set up first, especially colour tags.
17723C...(Need to set up colour tags even if MSTP(71) = 0)
17724 ELSEIF(MINT(35).GE.2) THEN
17725 NPART=2
17726 IF(KFL3(JT).NE.0) NPART=3
17727 IPART(1)=NSD(JT)+1
17728 IPART(2)=NSD(JT)+2
17729 IPART(3)=NSD(JT)+3
17730 PTPART(1)=0.5D0*P(ID,5)
17731 PTPART(2)=PTPART(1)
17732 PTPART(3)=PTPART(1)
17733 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
17734 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
17735 IF(MOTHER.LE.NSD(JT)) THEN
17736 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
17737 ELSE
17738 NCT=NCT+1
17739 MCT(NSD(JT)+1,1)=NCT
17740 MCT(MOTHER,2)=NCT
17741 ENDIF
17742 ENDIF
17743 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
17744 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
17745 IF(MOTHER.LE.NSD(JT)) THEN
17746 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
17747 ELSE
17748 NCT=NCT+1
17749 MCT(NSD(JT)+1,2)=NCT
17750 MCT(MOTHER,1)=NCT
17751 ENDIF
17752 ENDIF
17753 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
17754 & KCQ2(JT).EQ.2)) THEN
17755 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
17756 IF(MOTHER.LE.NSD(JT)) THEN
17757 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
17758 ELSE
17759 NCT=NCT+1
17760 MCT(NSD(JT)+2,1)=NCT
17761 MCT(MOTHER,2)=NCT
17762 ENDIF
17763 ENDIF
17764 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
17765 & KCQ2(JT).EQ.2)) THEN
17766 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
17767 IF(MOTHER.LE.NSD(JT)) THEN
17768 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
17769 ELSE
17770 NCT=NCT+1
17771 MCT(NSD(JT)+2,2)=NCT
17772 MCT(MOTHER,1)=NCT
17773 ENDIF
17774 ENDIF
17775 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
17776 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
17777 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
17778 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
17779 ENDIF
17780 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
17781 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
17782 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
17783 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
17784 ENDIF
17785 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17786 ENDIF
17787 NSHAFT=N
17788 IF(JT.EQ.1) NAFT1=N
17789
17790C...Check if decay products moved by shower.
17791 NSD1=NSD(JT)+1
17792 NSD2=NSD(JT)+2
17793 NSD3=NSD(JT)+3
17794 IF(NSHAFT.GT.NSHBEF) THEN
17795 IF(K(NSD1,1).GT.10) THEN
17796 DO 660 I=NSHBEF+1,NSHAFT
17797 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
17798 660 CONTINUE
17799 ENDIF
17800 IF(K(NSD2,1).GT.10) THEN
17801 DO 670 I=NSHBEF+1,NSHAFT
17802 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
17803 & I.NE.NSD1) NSD2=I
17804 670 CONTINUE
17805 ENDIF
17806 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
17807 DO 680 I=NSHBEF+1,NSHAFT
17808 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
17809 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
17810 680 CONTINUE
17811 ENDIF
17812 ENDIF
17813
17814C...Store decay products for further treatment.
17815 NP=NP+1
17816 IREF(NP,1)=NSD1
17817 IREF(NP,2)=NSD2
17818 IREF(NP,3)=0
17819 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
17820 IREF(NP,4)=IDOC+1
17821 IREF(NP,5)=IDOC+2
17822 IREF(NP,6)=0
17823 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
17824 IREF(NP,7)=K(IREF(IP,JT),2)
17825 IREF(NP,8)=IREF(IP,JT)
17826 690 CONTINUE
17827
17828
17829C...Fill information for 2 -> 1 -> 2.
17830 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
17831 MINT(7)=MINT(83)+6+2*ISET(ISUB)
17832 MINT(8)=MINT(83)+7+2*ISET(ISUB)
17833 MINT(25)=KFL1(1)
17834 MINT(26)=KFL2(1)
17835 VINT(23)=CTHE(1)
17836 RM3=P(N-1,5)**2/SH
17837 RM4=P(N,5)**2/SH
17838 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17839 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
17840 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
17841 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
17842 VINT(47)=SQRT(VINT(48))
17843 ENDIF
17844
17845C...Possibility of colour rearrangement in W+W- events.
17846 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
17847 IAKF1=IABS(KFL1(1))
17848 IAKF2=IABS(KFL1(2))
17849 IAKF3=IABS(KFL2(1))
17850 IAKF4=IABS(KFL2(2))
17851 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
17852 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
17853 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
17854 IF(MINT(51).NE.0) RETURN
17855 ENDIF
17856
17857C...Loop back if needed.
17858 710 IF(IP.LT.NP) GOTO 170
17859
17860C...Boost back to standard frame.
17861 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
17862 &BEZIN)
17863
17864 RETURN
17865 END
17866
17867C*********************************************************************
17868
17869C...PYMULT
17870C...Initializes treatment of multiple interactions, selects kinematics
17871C...of hardest interaction if low-pT physics included in run, and
17872C...generates all non-hardest interactions.
17873
17874 SUBROUTINE PYMULT(MMUL)
17875
17876C...Double precision and integer declarations.
17877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17878 IMPLICIT INTEGER(I-N)
17879 INTEGER PYK,PYCHGE,PYCOMP
17880C...Commonblocks.
17881 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17882 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17883 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17884 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17885 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17886 COMMON/PYINT1/MINT(400),VINT(400)
17887 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17888 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
17889 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
17890 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
17891 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
17892 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
17893C...Local arrays and saved variables.
17894 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
17895 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
17896 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
17897 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
17898
17899C...Initialization of multiple interaction treatment.
17900 IF(MMUL.EQ.1) THEN
17901 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
17902 ISUB=96
17903 MINT(1)=96
17904 VINT(63)=0D0
17905 VINT(64)=0D0
17906 VINT(143)=1D0
17907 VINT(144)=1D0
17908
17909C...Loop over phase space points: xT2 choice in 20 bins.
17910 100 SIGSUM=0D0
17911 DO 120 IXT2=1,20
17912 NMUL(IXT2)=MSTP(83)
17913 SIGM(IXT2)=0D0
17914 DO 110 ITRY=1,MSTP(83)
17915 RSCA=0.05D0*((21-IXT2)-PYR(0))
17916 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
17917 XT2=MAX(0.01D0*VINT(149),XT2)
17918 VINT(25)=XT2
17919
17920C...Choose tau and y*. Calculate cos(theta-hat).
17921 IF(PYR(0).LE.COEF(ISUB,1)) THEN
17922 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
17923 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
17924 ELSE
17925 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
17926 ENDIF
17927 VINT(21)=TAU
17928 CALL PYKLIM(2)
17929 RYST=PYR(0)
17930 MYST=1
17931 IF(RYST.GT.COEF(ISUB,8)) MYST=2
17932 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
17933 CALL PYKMAP(2,MYST,PYR(0))
17934 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
17935
17936C...Calculate differential cross-section.
17937 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
17938 CALL PYSIGH(NCHN,SIGS)
17939 SIGM(IXT2)=SIGM(IXT2)+SIGS
17940 110 CONTINUE
17941 SIGSUM=SIGSUM+SIGM(IXT2)
17942 120 CONTINUE
17943 SIGSUM=SIGSUM/(20D0*MSTP(83))
17944
17945C...Reject result if sigma(parton-parton) is smaller than hadronic one.
17946 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
17947 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
17948 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
17949 PARP(82)=0.9D0*PARP(82)
17950 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
17951 & VINT(2)
17952 GOTO 100
17953 ENDIF
17954 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
17955 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
17956
17957C...Start iteration to find k factor.
17958 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
17959 P83A=(1D0-PARP(83))**2
17960 P83B=2D0*PARP(83)*(1D0-PARP(83))
17961 P83C=PARP(83)**2
17962 CQ2I=1D0/PARP(84)**2
17963 CQ2R=2D0/(1D0+PARP(84)**2)
17964 SO=0.5D0
17965 XI=0D0
17966 YI=0D0
17967 XF=0D0
17968 YF=0D0
17969 XK=0.5D0
17970 IIT=0
17971 130 IF(IIT.EQ.0) THEN
17972 XK=2D0*XK
17973 ELSEIF(IIT.EQ.1) THEN
17974 XK=0.5D0*XK
17975 ELSE
17976 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
17977 ENDIF
17978
17979C...Evaluate overlap integrals. Find where to divide the b range.
17980 IF(MSTP(82).EQ.2) THEN
17981 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
17982 SOP=SP/PARU(1)
17983 ELSE
17984 IF(MSTP(82).EQ.3) THEN
17985 DELTAB=0.02D0
17986 ELSEIF(MSTP(82).EQ.4) THEN
17987 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
17988 ELSE
17989 POWIP=MAX(0.4D0,PARP(83))
17990 RPWIP=2D0/POWIP-1D0
17991 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
17992 SO=0D0
17993 ENDIF
17994 SP=0D0
17995 SOP=0D0
17996 BSP=0D0
17997 SOHIGH=0D0
17998 IBDIV=0
17999 B=-0.5D0*DELTAB
18000 140 B=B+DELTAB
18001 IF(MSTP(82).EQ.3) THEN
18002 OV=EXP(-B**2)/PARU(2)
18003 ELSEIF(MSTP(82).EQ.4) THEN
18004 OV=(P83A*EXP(-MIN(50D0,B**2))+
18005 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18006 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18007 ELSE
18008 OV=EXP(-B**POWIP)/PARU(2)
18009 SO=SO+PARU(2)*B*DELTAB*OV
18010 ENDIF
18011 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18012 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18013 SP=SP+PARU(2)*B*DELTAB*PACC
18014 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18015 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18016 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18017 IBDIV=1
18018 BDIV=B+0.5D0*DELTAB
18019 ENDIF
18020 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18021 ENDIF
18022 YK=PARU(1)*XK*SO/SP
18023
18024C...Continue iteration until convergence.
18025 IF(YK.LT.YKE) THEN
18026 XI=XK
18027 YI=YK
18028 IF(IIT.EQ.1) IIT=2
18029 ELSE
18030 XF=XK
18031 YF=YK
18032 IF(IIT.EQ.0) IIT=1
18033 ENDIF
18034 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18035
18036C...Store some results for subsequent use.
18037 BAVG=BSP/SP
18038 VINT(145)=SIGSUM
18039 VINT(146)=SOP/SO
18040 VINT(147)=SOP/SP
18041 VNT145=VINT(145)
18042 VNT146=VINT(146)
18043 VNT147=VINT(147)
18044C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18045 PIK=(VNT146/VNT147)*YKE
18046
18047C...Find relative weight for low and high impact parameter.
18048 PLOWB=PARU(1)*BDIV**2
18049 IF(MSTP(82).EQ.3) THEN
18050 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18051 ELSEIF(MSTP(82).EQ.4) THEN
18052 S4A=P83A*EXP(-BDIV**2)
18053 S4B=P83B*EXP(-BDIV**2*CQ2R)
18054 S4C=P83C*EXP(-BDIV**2*CQ2I)
18055 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18056 ELSEIF(PARP(83).GE.1.999D0) THEN
18057 PHIGHB=PIK*SOHIGH
18058 B2RPDV=BDIV**POWIP
18059 ELSE
18060 PHIGHB=PIK*SOHIGH
18061 B2RPDV=BDIV**POWIP
18062 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18063 ENDIF
18064 PALLB=PLOWB+PHIGHB
18065
18066C...Initialize iteration in xT2 for hardest interaction.
18067 ELSEIF(MMUL.EQ.2) THEN
18068 VINT(145)=VNT145
18069 VINT(146)=VNT146
18070 VINT(147)=VNT147
18071 IF(MSTP(82).LE.0) THEN
18072 ELSEIF(MSTP(82).EQ.1) THEN
18073 XT2=1D0
18074 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18075 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18076 & VINT(317)/(VINT(318)*VINT(320))
18077 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18078 ELSEIF(MSTP(82).EQ.2) THEN
18079 XT2=1D0
18080 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18081 & VINT(149)*(1D0+VINT(149))
18082 ELSE
18083 XC2=4D0*CKIN(3)**2/VINT(2)
18084 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18085 ENDIF
18086
18087C...Select impact parameter for hardest interaction.
18088 IF(MSTP(82).LE.2) RETURN
18089 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18090C...Treatment in low b region.
18091 MINT(39)=1
18092 B=BDIV*SQRT(PYR(0))
18093 IF(MSTP(82).EQ.3) THEN
18094 OV=EXP(-B**2)/PARU(2)
18095 ELSEIF(MSTP(82).EQ.4) THEN
18096 OV=(P83A*EXP(-MIN(50D0,B**2))+
18097 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18098 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18099 ELSE
18100 OV=EXP(-B**POWIP)/PARU(2)
18101 ENDIF
18102 VINT(148)=OV/VNT147
18103 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18104 XT2=1D0
18105 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18106 & VINT(149)*(1D0+VINT(149))
18107 ELSE
18108C...Treatment in high b region.
18109 MINT(39)=2
18110 IF(MSTP(82).EQ.3) THEN
18111 B=SQRT(BDIV**2-LOG(PYR(0)))
18112 OV=EXP(-B**2)/PARU(2)
18113 ELSEIF(MSTP(82).EQ.4) THEN
18114 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18115 IF(S4RNDM.LT.S4A) THEN
18116 B=SQRT(BDIV**2-LOG(PYR(0)))
18117 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18118 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18119 ELSE
18120 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18121 ENDIF
18122 OV=(P83A*EXP(-MIN(50D0,B**2))+
18123 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18124 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18125 ELSEIF(PARP(83).GE.1.999D0) THEN
18126 144 B2RPW=B2RPDV-LOG(PYR(0))
18127 ACCIP=(B2RPW/B2RPDV)**RPWIP
18128 IF(ACCIP.LT.PYR(0)) GOTO 144
18129 OV=EXP(-B2RPW)/PARU(2)
18130 B=B2RPW**(1D0/POWIP)
18131 ELSE
18132 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18133 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18134 IF(ACCIP.LT.PYR(0)) GOTO 146
18135 OV=EXP(-B2RPW)/PARU(2)
18136 B=B2RPW**(1D0/POWIP)
18137 ENDIF
18138 VINT(148)=OV/VNT147
18139 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18140 ENDIF
18141 IF(PACC.LT.PYR(0)) GOTO 142
18142 VINT(139)=B/BAVG
18143
18144 ELSEIF(MMUL.EQ.3) THEN
18145C...Low-pT or multiple interactions (first semihard interaction):
18146C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18147C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18148 ISUB=MINT(1)
18149 VINT(145)=VNT145
18150 VINT(146)=VNT146
18151 VINT(147)=VNT147
18152 IF(MSTP(82).LE.0) THEN
18153 XT2=0D0
18154 ELSEIF(MSTP(82).EQ.1) THEN
18155 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18156C...Use with "Sudakov" for low b values when impact parameter dependence.
18157 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18158 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18159 & VINT(149)))).GT.PYR(0)) XT2=1D0
18160 IF(XT2.GE.1D0) THEN
18161 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18162 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18163 & VINT(149)
18164 ELSE
18165 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18166 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18167 & VINT(149)
18168 ENDIF
18169 XT2=MAX(0.01D0*VINT(149),XT2)
18170C...Use without "Sudakov" for high b values when impact parameter dep.
18171 ELSE
18172 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18173 & PYR(0)*(1D0-XC2))-VINT(149)
18174 XT2=MAX(0.01D0*VINT(149),XT2)
18175 ENDIF
18176 VINT(25)=XT2
18177
18178C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18179 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18180 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18181 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18182 ISUB=95
18183 MINT(1)=ISUB
18184 VINT(21)=0.01D0*VINT(149)
18185 VINT(22)=0D0
18186 VINT(23)=0D0
18187 VINT(25)=0.01D0*VINT(149)
18188
18189 ELSE
18190C...Multiple interactions (first semihard interaction).
18191C...Choose tau and y*. Calculate cos(theta-hat).
18192 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18193 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18194 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18195 ELSE
18196 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18197 ENDIF
18198 VINT(21)=TAU
18199 CALL PYKLIM(2)
18200 RYST=PYR(0)
18201 MYST=1
18202 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18203 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18204 CALL PYKMAP(2,MYST,PYR(0))
18205 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18206 ENDIF
18207 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18208
18209C...Store results of cross-section calculation.
18210 ELSEIF(MMUL.EQ.4) THEN
18211 ISUB=MINT(1)
18212 VINT(145)=VNT145
18213 VINT(146)=VNT146
18214 VINT(147)=VNT147
18215 XTS=VINT(25)
18216 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18217 IF(ISET(ISUB).EQ.2)
18218 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18219 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18220 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18221 & (XTS+VINT(149))))
18222 IRBIN=INT(1D0+20D0*RBIN)
18223 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18224 NMUL(IRBIN)=NMUL(IRBIN)+1
18225 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18226 ENDIF
18227
18228C...Choose impact parameter if not already done.
18229 ELSEIF(MMUL.EQ.5) THEN
18230 ISUB=MINT(1)
18231 VINT(145)=VNT145
18232 VINT(146)=VNT146
18233 VINT(147)=VNT147
18234 150 IF(MINT(39).GT.0) THEN
18235 ELSEIF(MSTP(82).EQ.3) THEN
18236 EXPB2=PYR(0)
18237 B2=-LOG(PYR(0))
18238 VINT(148)=EXPB2/(PARU(2)*VNT147)
18239 VINT(139)=SQRT(B2)/BAVG
18240 ELSEIF(MSTP(82).EQ.4) THEN
18241 RTYPE=PYR(0)
18242 IF(RTYPE.LT.P83A) THEN
18243 B2=-LOG(PYR(0))
18244 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18245 B2=-LOG(PYR(0))/CQ2R
18246 ELSE
18247 B2=-LOG(PYR(0))/CQ2I
18248 ENDIF
18249 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18250 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18251 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18252 VINT(139)=SQRT(B2)/BAVG
18253 ELSEIF(PARP(83).GE.1.999D0) THEN
18254 POWIP=MAX(2D0,PARP(83))
18255 RPWIP=2D0/POWIP-1D0
18256 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18257 160 IF(PYR(0).LT.PROB1) THEN
18258 B2RPW=PYR(0)**(0.5D0*POWIP)
18259 ACCIP=EXP(-B2RPW)
18260 ELSE
18261 B2RPW=1D0-LOG(PYR(0))
18262 ACCIP=B2RPW**RPWIP
18263 ENDIF
18264 IF(ACCIP.LT.PYR(0)) GOTO 160
18265 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18266 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18267 ELSE
18268 POWIP=MAX(0.4D0,PARP(83))
18269 RPWIP=2D0/POWIP-1D0
18270 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18271 170 IF(PYR(0).LT.PROB1) THEN
18272 B2RPW=2D0*RPWIP*PYR(0)
18273 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18274 ELSE
18275 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18276 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18277 ENDIF
18278 IF(ACCIP.LT .PYR(0)) GOTO 170
18279 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18280 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18281 ENDIF
18282
18283C...Multiple interactions (variable impact parameter) : reject with
18284C...probability exp(-overlap*cross-section above pT/normalization).
18285C...Does not apply to low-b region, where "Sudakov" already included.
18286 VINT(150)=1D0
18287 IF(MINT(39).NE.1) THEN
18288 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18289 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18290 DO 180 IBIN=IRBIN+1,20
18291 RNCOR=RNCOR+NMUL(IBIN)
18292 SIGCOR=SIGCOR+SIGM(IBIN)
18293 180 CONTINUE
18294 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18295 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18296 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18297 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18298 ENDIF
18299 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18300 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18301 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18302 IF(VINT(150).LT.PYR(0)) GOTO 150
18303 VINT(150)=1D0
18304 ENDIF
18305
18306C...Generate additional multiple semihard interactions.
18307 ELSEIF(MMUL.EQ.6) THEN
18308 ISUBSV=MINT(1)
18309 VINT(145)=VNT145
18310 VINT(146)=VNT146
18311 VINT(147)=VNT147
18312 DO 190 J=11,80
18313 VINTSV(J)=VINT(J)
18314 190 CONTINUE
18315 ISUB=96
18316 MINT(1)=96
18317 VINT(151)=0D0
18318 VINT(152)=0D0
18319
18320C...Reconstruct strings in hard scattering.
18321 NMAX=MINT(84)+4
18322 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18323 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18324 NSTR=0
18325 DO 210 I=MINT(84)+1,NMAX
18326 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18327 IF(KCS.EQ.0) GOTO 210
18328 DO 200 J=1,4
18329 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18330 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18331 IF(J.LE.2) THEN
18332 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18333 ELSE
18334 IST=MOD(K(I,J+1),MSTU(5))
18335 ENDIF
18336 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18337 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18338 NSTR=NSTR+1
18339 IF(J.EQ.1.OR.J.EQ.4) THEN
18340 KSTR(NSTR,1)=I
18341 KSTR(NSTR,2)=IST
18342 ELSE
18343 KSTR(NSTR,1)=IST
18344 KSTR(NSTR,2)=I
18345 ENDIF
18346 200 CONTINUE
18347 210 CONTINUE
18348
18349C...Set up starting values for iteration in xT2.
18350 XT2=4D0*VINT(62)/VINT(2)
18351 IF(MSTP(82).LE.1) THEN
18352 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18353 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18354 & VINT(317)/(VINT(318)*VINT(320))
18355 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18356 ELSE
18357 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18358 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18359 ENDIF
18360 VINT(63)=0D0
18361 VINT(64)=0D0
18362 VINT(143)=1D0-VINT(141)
18363 VINT(144)=1D0-VINT(142)
18364
18365C...Iterate downwards in xT2.
18366 220 IF(MSTP(82).LE.1) THEN
18367 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18368 IF(XT2.LT.VINT(149)) GOTO 270
18369 ELSE
18370 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18371 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18372 & LOG(PYR(0)))-VINT(149)
18373 IF(XT2.LE.0D0) GOTO 270
18374 XT2=MAX(0.01D0*VINT(149),XT2)
18375 ENDIF
18376 VINT(25)=XT2
18377
18378C...Choose tau and y*. Calculate cos(theta-hat).
18379 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18380 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18381 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18382 ELSE
18383 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18384 ENDIF
18385 VINT(21)=TAU
18386 CALL PYKLIM(2)
18387 RYST=PYR(0)
18388 MYST=1
18389 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18390 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18391 CALL PYKMAP(2,MYST,PYR(0))
18392 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18393
18394C...Check that x not used up. Accept or reject kinematical variables.
18395 X1M=SQRT(TAU)*EXP(VINT(22))
18396 X2M=SQRT(TAU)*EXP(-VINT(22))
18397 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
18398 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18399 CALL PYSIGH(NCHN,SIGS)
18400 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
18401 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
18402
18403C...Reset K, P and V vectors. Select some variables.
18404 DO 240 I=N+1,N+2
18405 DO 230 J=1,5
18406 K(I,J)=0
18407 P(I,J)=0D0
18408 V(I,J)=0D0
18409 230 CONTINUE
18410 240 CONTINUE
18411 RFLAV=PYR(0)
18412 PT=0.5D0*VINT(1)*SQRT(XT2)
18413 PHI=PARU(2)*PYR(0)
18414 CTH=VINT(23)
18415
18416C...Add first parton to event record.
18417 K(N+1,1)=3
18418 K(N+1,2)=21
18419 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
18420 & 1+INT((2D0+PARJ(2))*PYR(0))
18421 P(N+1,1)=PT*COS(PHI)
18422 P(N+1,2)=PT*SIN(PHI)
18423 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
18424 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
18425 P(N+1,5)=0D0
18426
18427C...Add second parton to event record.
18428 K(N+2,1)=3
18429 K(N+2,2)=21
18430 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
18431 P(N+2,1)=-P(N+1,1)
18432 P(N+2,2)=-P(N+1,2)
18433 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
18434 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
18435 P(N+2,5)=0D0
18436
18437 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
18438C....Choose relevant string pieces to place gluons on.
18439 DO 260 I=N+1,N+2
18440 DMIN=1D8
18441 DO 250 ISTR=1,NSTR
18442 I1=KSTR(ISTR,1)
18443 I2=KSTR(ISTR,2)
18444 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
18445 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
18446 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
18447 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
18448 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
18449 DMIN=DIST
18450 IST1=I1
18451 IST2=I2
18452 ISTM=ISTR
18453 ENDIF
18454 250 CONTINUE
18455
18456C....Colour flow adjustments, new string pieces.
18457 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
18458 & MOD(K(IST1,4),MSTU(5))
18459 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
18460 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
18461 K(I,5)=MSTU(5)*IST1
18462 K(I,4)=MSTU(5)*IST2
18463 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
18464 & MOD(K(IST2,5),MSTU(5))
18465 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
18466 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
18467 KSTR(ISTM,2)=I
18468 KSTR(NSTR+1,1)=I
18469 KSTR(NSTR+1,2)=IST2
18470 NSTR=NSTR+1
18471 260 CONTINUE
18472
18473C...String drawing and colour flow for gluon loop.
18474 ELSEIF(K(N+1,2).EQ.21) THEN
18475 K(N+1,4)=MSTU(5)*(N+2)
18476 K(N+1,5)=MSTU(5)*(N+2)
18477 K(N+2,4)=MSTU(5)*(N+1)
18478 K(N+2,5)=MSTU(5)*(N+1)
18479 KSTR(NSTR+1,1)=N+1
18480 KSTR(NSTR+1,2)=N+2
18481 KSTR(NSTR+2,1)=N+2
18482 KSTR(NSTR+2,2)=N+1
18483 NSTR=NSTR+2
18484
18485C...String drawing and colour flow for qqbar pair.
18486 ELSE
18487 K(N+1,4)=MSTU(5)*(N+2)
18488 K(N+2,5)=MSTU(5)*(N+1)
18489 KSTR(NSTR+1,1)=N+1
18490 KSTR(NSTR+1,2)=N+2
18491 NSTR=NSTR+1
18492 ENDIF
18493
18494C...Global statistics.
18495 MINT(351)=MINT(351)+1
18496 VINT(351)=VINT(351)+PT
18497 IF (MINT(351).EQ.1) VINT(356)=PT
18498
18499C...Update remaining energy; iterate.
18500 N=N+2
18501 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
18502 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
18503 MINT(51)=1
18504 RETURN
18505 ENDIF
18506 MINT(31)=MINT(31)+1
18507 VINT(151)=VINT(151)+VINT(41)
18508 VINT(152)=VINT(152)+VINT(42)
18509 VINT(143)=VINT(143)-VINT(41)
18510 VINT(144)=VINT(144)-VINT(42)
18511 IF(MINT(31).LT.240) GOTO 220
18512 270 CONTINUE
18513 MINT(1)=ISUBSV
18514 DO 280 J=11,80
18515 VINT(J)=VINTSV(J)
18516 280 CONTINUE
18517 ENDIF
18518
18519C...Format statements for printout.
18520 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
18521 &'actions for MSTP(82) =',I2,' ******')
18522 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
18523 &D9.2,' mb: rejected')
18524 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
18525 &D9.2,' mb: accepted')
18526
18527 RETURN
18528 END
18529
18530C*********************************************************************
18531
18532C...PYREMN
18533C...Adds on target remnants (one or two from each side) and
18534C...includes primordial kT for hadron beams.
18535
18536 SUBROUTINE PYREMN(IPU1,IPU2)
18537
18538C...Double precision and integer declarations.
18539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18540 IMPLICIT INTEGER(I-N)
18541 INTEGER PYK,PYCHGE,PYCOMP
18542C...Commonblocks.
18543 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18544 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18545 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18546 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18547 COMMON/PYINT1/MINT(400),VINT(400)
18548 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
18549C...Local arrays.
18550 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
18551 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
18552
18553C...Find event type and remaining energy.
18554 ISUB=MINT(1)
18555 NS=N
18556 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
18557 VINT(143)=1D0-VINT(141)
18558 VINT(144)=1D0-VINT(142)
18559 ENDIF
18560
18561C...Define initial partons.
18562 NTRY=0
18563 100 NTRY=NTRY+1
18564 DO 130 JT=1,2
18565 I=MINT(83)+JT+2
18566 IF(JT.EQ.1) IPU=IPU1
18567 IF(JT.EQ.2) IPU=IPU2
18568 K(I,1)=21
18569 K(I,2)=K(IPU,2)
18570 K(I,3)=I-2
18571 PMS(JT)=0D0
18572 VINT(156+JT)=0D0
18573 VINT(158+JT)=0D0
18574 IF(MINT(47).EQ.1) THEN
18575 DO 110 J=1,5
18576 P(I,J)=P(I-2,J)
18577 110 CONTINUE
18578 ELSEIF(ISUB.EQ.95) THEN
18579 K(I,2)=21
18580 ELSE
18581 P(I,5)=P(IPU,5)
18582
18583C...No primordial kT, or chosen according to truncated Gaussian or
18584C...exponential, or (for photon) predetermined or power law.
18585 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
18586 IF(MSTP(91).LE.0) THEN
18587 PT=0D0
18588 ELSEIF(MSTP(91).EQ.1) THEN
18589 PT=PARP(91)*SQRT(-LOG(PYR(0)))
18590 ELSE
18591 RPT1=PYR(0)
18592 RPT2=PYR(0)
18593 PT=-PARP(92)*LOG(RPT1*RPT2)
18594 ENDIF
18595 IF(PT.GT.PARP(93)) GOTO 120
18596 ELSEIF(MINT(106+JT).EQ.3) THEN
18597 PTA=SQRT(VINT(282+JT))
18598 PTB=0D0
18599 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
18600 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
18601 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
18602 RPT1=PYR(0)
18603 RPT2=PYR(0)
18604 PTB=-PARP(99)*LOG(RPT1*RPT2)
18605 ENDIF
18606 IF(PTB.GT.PARP(100)) GOTO 120
18607 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
18608 PT=PT*0.8D0**MINT(57)
18609 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
18610 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
18611 IF(MSTP(93).LE.0) THEN
18612 PT=0D0
18613 ELSEIF(MSTP(93).EQ.1) THEN
18614 PT=PARP(99)*SQRT(-LOG(PYR(0)))
18615 ELSEIF(MSTP(93).EQ.2) THEN
18616 RPT1=PYR(0)
18617 RPT2=PYR(0)
18618 PT=-PARP(99)*LOG(RPT1*RPT2)
18619 ELSEIF(MSTP(93).EQ.3) THEN
18620 HA=PARP(99)**2
18621 HB=PARP(100)**2
18622 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
18623 ELSE
18624 HA=PARP(99)**2
18625 HB=PARP(100)**2
18626 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
18627 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
18628 ENDIF
18629 IF(PT.GT.PARP(100)) GOTO 120
18630 ELSE
18631 PT=0D0
18632 ENDIF
18633 VINT(156+JT)=PT
18634 PHI=PARU(2)*PYR(0)
18635 P(I,1)=PT*COS(PHI)
18636 P(I,2)=PT*SIN(PHI)
18637 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
18638 ENDIF
18639 130 CONTINUE
18640 IF(MINT(47).EQ.1) RETURN
18641
18642C...Kinematics construction for initial partons.
18643 I1=MINT(83)+3
18644 I2=MINT(83)+4
18645 IF(ISUB.EQ.95) THEN
18646 SHS=0D0
18647 SHR=0D0
18648 ELSE
18649 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
18650 & (P(I1,2)+P(I2,2))**2
18651 SHR=SQRT(MAX(0D0,SHS))
18652 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
18653 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
18654 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
18655 P(I2,4)=SHR-P(I1,4)
18656 P(I2,3)=-P(I1,3)
18657
18658C...Transform partons to overall CM-frame.
18659 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
18660 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
18661 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
18662 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
18663 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
18664 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
18665 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
18666 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
18667 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
18668 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
18669 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
18670 ENDIF
18671
18672C...Optionally fix up x and Q2 definitions for leptoproduction.
18673 IDISXQ=0
18674 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
18675 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
18676 IF(IDISXQ.EQ.1) THEN
18677
18678C...Find where incoming and outgoing leptons/partons are sitting.
18679 LESD=1
18680 IF(MINT(42).EQ.1) LESD=2
18681 LPIN=MINT(83)+3-LESD
18682 LEIN=MINT(84)+LESD
18683 LQIN=MINT(84)+3-LESD
18684 LEOUT=MINT(84)+2+LESD
18685 LQOUT=MINT(84)+5-LESD
18686 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
18687 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
18688 LSCMS=0
18689 DO 140 I=MINT(84)+5,N
18690 IF(K(I,2).EQ.94) THEN
18691 LSCMS=I
18692 LEOUT=I+LESD
18693 LQOUT=I+3-LESD
18694 ENDIF
18695 140 CONTINUE
18696 LQBG=IPU1
18697 IF(LESD.EQ.1) LQBG=IPU2
18698
18699C...Calculate actual and wanted momentum transfer.
18700 XNOM=VINT(43-LESD)
18701 Q2NOM=-VINT(45)
18702 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
18703 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
18704 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
18705 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
18706 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
18707 P(N+1,1)=FAC*P(LEOUT,1)
18708 P(N+1,2)=FAC*P(LEOUT,2)
18709 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
18710 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
18711 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
18712 & P(N+1,3)**2)
18713 DO 150 J=1,4
18714 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
18715 QNEW(J)=P(LEIN,J)-P(N+1,J)
18716 150 CONTINUE
18717
18718C...Boost outgoing electron and daughters.
18719 IF(LSCMS.EQ.0) THEN
18720 DO 160 J=1,4
18721 P(LEOUT,J)=P(N+1,J)
18722 160 CONTINUE
18723 ELSE
18724 DO 170 J=1,3
18725 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
18726 170 CONTINUE
18727 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
18728 DO 180 J=1,3
18729 DBE(J)=PINV*P(N+2,J)
18730 180 CONTINUE
18731 DO 200 I=LSCMS+1,N
18732 IORIG=I
18733 190 IORIG=K(IORIG,3)
18734 IF(IORIG.GT.LEOUT) GOTO 190
18735 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
18736 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
18737 200 CONTINUE
18738 ENDIF
18739
18740C...Copy shower initiator and all outgoing partons.
18741 NCOP=N+1
18742 K(NCOP,3)=LQBG
18743 DO 210 J=1,5
18744 P(NCOP,J)=P(LQBG,J)
18745 210 CONTINUE
18746 DO 240 I=MINT(84)+1,N
18747 ICOP=0
18748 IF(K(I,1).GT.10) GOTO 240
18749 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
18750 ICOP=I
18751 ELSE
18752 IORIG=I
18753 220 IORIG=K(IORIG,3)
18754 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
18755 ICOP=IORIG
18756 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
18757 GOTO 220
18758 ENDIF
18759 ENDIF
18760 IF(ICOP.NE.0) THEN
18761 NCOP=NCOP+1
18762 K(NCOP,3)=I
18763 DO 230 J=1,5
18764 P(NCOP,J)=P(I,J)
18765 230 CONTINUE
18766 ENDIF
18767 240 CONTINUE
18768
18769C...Calculate relative rescaling factors.
18770 SLC=3-2*LESD
18771 PLCSUM=0D0
18772 DO 250 I=N+2,NCOP
18773 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
18774 250 CONTINUE
18775 DO 260 I=N+2,NCOP
18776 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
18777 260 CONTINUE
18778
18779C...Transfer extra three-momentum of current.
18780 DO 280 I=N+2,NCOP
18781 DO 270 J=1,3
18782 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
18783 270 CONTINUE
18784 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
18785 280 CONTINUE
18786
18787C...Iterate change of initiator momentum to get energy right.
18788 ITER=0
18789 290 ITER=ITER+1
18790 PEEX=-P(N+1,4)-QNEW(4)
18791 PEMV=-P(N+1,3)/P(N+1,4)
18792 DO 300 I=N+2,NCOP
18793 PEEX=PEEX+P(I,4)
18794 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
18795 300 CONTINUE
18796 IF(ABS(PEMV).LT.1D-10) THEN
18797 MINT(51)=1
18798 MINT(57)=MINT(57)+1
18799 RETURN
18800 ENDIF
18801 PZCH=-PEEX/PEMV
18802 P(N+1,3)=P(N+1,3)+PZCH
18803 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)
18804 DO 310 I=N+2,NCOP
18805 P(I,3)=P(I,3)+V(I,1)*PZCH
18806 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
18807 310 CONTINUE
18808 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
18809
18810C...Modify momenta in event record.
18811 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
18812 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
18813 IF(ABS(HBE).GE.1D0) THEN
18814 MINT(51)=1
18815 MINT(57)=MINT(57)+1
18816 RETURN
18817 ENDIF
18818 I=MINT(83)+5-LESD
18819 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
18820 DO 330 I=N+1,NCOP
18821 ICOP=K(I,3)
18822 DO 320 J=1,4
18823 P(ICOP,J)=P(I,J)
18824 320 CONTINUE
18825 330 CONTINUE
18826 ENDIF
18827
18828C...Check minimum invariant mass of remnant system(s).
18829 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
18830 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
18831 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
18832 PMIN(0)=SQRT(PMS(0))
18833 DO 340 JT=1,2
18834 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
18835 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
18836 PMIN(JT)=0D0
18837 IF(MINT(44+JT).EQ.1) GOTO 340
18838 MINT(105)=MINT(102+JT)
18839 MINT(109)=MINT(106+JT)
18840 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
18841 IF(MINT(51).NE.0) THEN
18842 MINT(57)=MINT(57)+1
18843 RETURN
18844 ENDIF
18845 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
18846 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
18847 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
18848 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
18849 & P(MINT(83)+JT+2,2)**2)
18850 340 CONTINUE
18851 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
18852 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
18853 &PSYS(2,4))) THEN
18854 MINT(51)=1
18855 MINT(57)=MINT(57)+1
18856 RETURN
18857 ENDIF
18858
18859C...Loop over two remnants; skip if none there.
18860 I=NS
18861 DO 410 JT=1,2
18862 ISN(JT)=0
18863 IF(MINT(44+JT).EQ.1) GOTO 410
18864 IF(JT.EQ.1) IPU=IPU1
18865 IF(JT.EQ.2) IPU=IPU2
18866
18867C...Store first remnant parton.
18868 I=I+1
18869 IS(JT)=I
18870 ISN(JT)=1
18871 DO 350 J=1,5
18872 K(I,J)=0
18873 P(I,J)=0D0
18874 V(I,J)=0D0
18875 350 CONTINUE
18876 K(I,1)=1
18877 K(I,2)=KFLSP(JT)
18878 K(I,3)=MINT(83)+JT
18879 P(I,5)=PYMASS(K(I,2))
18880
18881C...First parton colour connections and kinematics.
18882 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
18883 IF(KCOL.EQ.2) THEN
18884 K(I,1)=3
18885 K(I,4)=MSTU(5)*IPU+IPU
18886 K(I,5)=MSTU(5)*IPU+IPU
18887 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
18888 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
18889 ELSEIF(KCOL.NE.0) THEN
18890 K(I,1)=3
18891 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
18892 K(I,KFLS+3)=IPU
18893 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
18894 ENDIF
18895 IF(KFLCH(JT).EQ.0) THEN
18896 P(I,1)=-P(MINT(83)+JT+2,1)
18897 P(I,2)=-P(MINT(83)+JT+2,2)
18898 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
18899 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
18900 P(I,3)=PSYS(JT,3)
18901 P(I,4)=PSYS(JT,4)
18902
18903C...When extra remnant parton or hadron: store extra remnant.
18904 ELSE
18905 I=I+1
18906 ISN(JT)=2
18907 DO 360 J=1,5
18908 K(I,J)=0
18909 P(I,J)=0D0
18910 V(I,J)=0D0
18911 360 CONTINUE
18912 K(I,1)=1
18913 K(I,2)=KFLCH(JT)
18914 K(I,3)=MINT(83)+JT
18915 P(I,5)=PYMASS(K(I,2))
18916
18917C...Find parton colour connections of extra remnant.
18918 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
18919 IF(KCOL.EQ.2) THEN
18920 K(I,1)=3
18921 K(I,4)=MSTU(5)*IPU+IPU
18922 K(I,5)=MSTU(5)*IPU+IPU
18923 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
18924 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
18925 ELSEIF(KCOL.NE.0) THEN
18926 K(I,1)=3
18927 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
18928 K(I,KFLS+3)=IPU
18929 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
18930 ENDIF
18931
18932C...Relative transverse momentum when two remnants.
18933 LOOP=0
18934 370 LOOP=LOOP+1
18935 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
18936 IF(IABS(MINT(10+JT)).LT.20) THEN
18937 P(I-1,1)=0D0
18938 P(I-1,2)=0D0
18939 ELSE
18940 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
18941 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
18942 ENDIF
18943 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
18944 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
18945 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
18946 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
18947
18948C...Meson or baryon; photon as meson. For splitup below.
18949 IMB=1
18950 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
18951
18952C***Relative distribution for electron into two electrons. Temporary!
18953 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
18954 & THEN
18955 CHI(JT)=PYR(0)
18956
18957C...Relative distribution of electron energy into electron plus parton.
18958 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
18959 XHRD=VINT(140+JT)
18960 XE=VINT(154+JT)
18961 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
18962
18963C...Relative distribution of energy for particle into two jets.
18964 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
18965 CHIK=PARP(92+2*IMB)
18966 IF(MSTP(92).LE.1) THEN
18967 IF(IMB.EQ.1) CHI(JT)=PYR(0)
18968 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
18969 ELSEIF(MSTP(92).EQ.2) THEN
18970 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
18971 ELSEIF(MSTP(92).EQ.3) THEN
18972 CUT=2D0*0.3D0/VINT(1)
18973 380 CHI(JT)=PYR(0)**2
18974 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
18975 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
18976 ELSEIF(MSTP(92).EQ.4) THEN
18977 CUT=2D0*0.3D0/VINT(1)
18978 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
18979 390 CHIR=CUT*CUTR**PYR(0)
18980 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
18981 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
18982 ELSE
18983 CUT=2D0*0.3D0/VINT(1)
18984 CUTA=CUT**(1D0-PARP(98))
18985 CUTB=(1D0+CUT)**(1D0-PARP(98))
18986 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
18987 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
18988 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
18989 ENDIF
18990
18991C...Relative distribution of energy for particle into jet plus particle.
18992 ELSE
18993 IF(MSTP(94).LE.1) THEN
18994 IF(IMB.EQ.1) CHI(JT)=PYR(0)
18995 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
18996 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
18997 ELSEIF(MSTP(94).EQ.2) THEN
18998 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
18999 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19000 ELSEIF(MSTP(94).EQ.3) THEN
19001 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19002 CHI(JT)=ZZ
19003 ELSE
19004 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19005 CHI(JT)=ZZ
19006 ENDIF
19007 ENDIF
19008
19009C...Construct total transverse mass; reject if too large.
19010 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19011 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19012 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19013 IF(LOOP.LT.100) THEN
19014 GOTO 370
19015 ELSE
19016 MINT(51)=1
19017 MINT(57)=MINT(57)+1
19018 RETURN
19019 ENDIF
19020 ENDIF
19021 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19022 VINT(158+JT)=CHI(JT)
19023
19024C...Subdivide longitudinal momentum according to value selected above.
19025 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19026 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19027 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19028 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19029 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19030 ENDIF
19031 410 CONTINUE
19032 N=I
19033
19034C...Check if longitudinal boosts needed - if so pick two systems.
19035 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19036 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19037 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19038 IF(ISN(1).EQ.0) THEN
19039 IR=0
19040 IL=2
19041 ELSEIF(ISN(2).EQ.0) THEN
19042 IR=1
19043 IL=0
19044 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19045 IR=1
19046 IL=2
19047 ELSEIF(VINT(143).GT.0.2D0) THEN
19048 IR=1
19049 IL=0
19050 ELSEIF(VINT(144).GT.0.2D0) THEN
19051 IR=0
19052 IL=2
19053 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19054 IR=1
19055 IL=0
19056 ELSE
19057 IR=0
19058 IL=2
19059 ENDIF
19060 IG=3-IR-IL
19061
19062C...E+-pL wanted for system to be modified.
19063 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19064 PPB=VINT(1)
19065 PNB=VINT(1)
19066 ELSE
19067 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19068 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19069 ENDIF
19070
19071C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19072 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19073 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19074 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19075 DO 420 J=1,4
19076 PSYS(0,J)=0D0
19077 420 CONTINUE
19078 DO 450 I=MINT(84)+1,NS
19079 IF(K(I,1).GT.10) GOTO 450
19080 INCL=0
19081 IORIG=I
19082 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19083 IORIG=K(IORIG,3)
19084 IF(IORIG.GT.LPIN) GOTO 430
19085 IF(INCL.EQ.0) GOTO 450
19086 DO 440 J=1,4
19087 PSYS(0,J)=PSYS(0,J)+P(I,J)
19088 440 CONTINUE
19089 450 CONTINUE
19090 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19091 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19092 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19093 ENDIF
19094
19095C...Construct longitudinal boosts.
19096 DPMTB=PPB*PNB
19097 DPMTR=PMS(IR)
19098 DPMTL=PMS(IL)
19099 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19100 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19101 MINT(51)=1
19102 MINT(57)=MINT(57)+1
19103 RETURN
19104 ENDIF
19105 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19106 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19107 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19108 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19109 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19110 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19111 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19112
19113C...Perform longitudinal boosts.
19114 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19115 P(IS(1),3)=0D0
19116 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19117 ELSEIF(IR.EQ.1) THEN
19118 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19119 ELSEIF(IDISXQ.EQ.1) THEN
19120 DO 470 I=I1,NS
19121 INCL=0
19122 IORIG=I
19123 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19124 IORIG=K(IORIG,3)
19125 IF(IORIG.GT.LPIN) GOTO 460
19126 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19127 470 CONTINUE
19128 ELSE
19129 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19130 ENDIF
19131 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19132 P(IS(2),3)=0D0
19133 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19134 ELSEIF(IL.EQ.2) THEN
19135 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19136 ELSEIF(IDISXQ.EQ.1) THEN
19137 DO 490 I=I1,NS
19138 INCL=0
19139 IORIG=I
19140 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19141 IORIG=K(IORIG,3)
19142 IF(IORIG.GT.LPIN) GOTO 480
19143 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19144 490 CONTINUE
19145 ELSE
19146 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19147 ENDIF
19148
19149C...Final check that energy-momentum conservation worked.
19150 PESUM=0D0
19151 PZSUM=0D0
19152 DO 500 I=MINT(84)+1,N
19153 IF(K(I,1).GT.10) GOTO 500
19154 PESUM=PESUM+P(I,4)
19155 PZSUM=PZSUM+P(I,3)
19156 500 CONTINUE
19157 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19158 IF(PDEV.GT.1D-4*VINT(1)) THEN
19159 MINT(51)=1
19160 MINT(57)=MINT(57)+1
19161 RETURN
19162 ENDIF
19163
19164C...Calculate rotation and boost from overall CM frame to
19165C...hadronic CM frame in leptoproduction.
19166 MINT(91)=0
19167 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19168 MINT(91)=1
19169 LESD=1
19170 IF(MINT(42).EQ.1) LESD=2
19171 LPIN=MINT(83)+3-LESD
19172
19173C...Sum upp momenta of everything not lepton or photon to define boost.
19174 DO 510 J=1,4
19175 PSUM(J)=0D0
19176 510 CONTINUE
19177 DO 530 I=1,N
19178 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19179 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19180 IF(K(I,2).EQ.22) GOTO 530
19181 DO 520 J=1,4
19182 PSUM(J)=PSUM(J)+P(I,J)
19183 520 CONTINUE
19184 530 CONTINUE
19185 VINT(223)=-PSUM(1)/PSUM(4)
19186 VINT(224)=-PSUM(2)/PSUM(4)
19187 VINT(225)=-PSUM(3)/PSUM(4)
19188
19189C...Boost incoming hadron to hadronic CM frame to determine rotations.
19190 K(N+1,1)=1
19191 DO 540 J=1,5
19192 P(N+1,J)=P(LPIN,J)
19193 V(N+1,J)=V(LPIN,J)
19194 540 CONTINUE
19195 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19196 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19197 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19198 IF(LESD.EQ.2) THEN
19199 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19200 ELSE
19201 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19202 ENDIF
19203 ENDIF
19204
19205 RETURN
19206 END
19207
19208C*********************************************************************
19209
19210C...PYMIGN
19211C...Initializes treatment of new multiple interactions scenario,
19212C...selects kinematics of hardest interaction if low-pT physics
19213C...included in run, and generates all non-hardest interactions.
19214
19215 SUBROUTINE PYMIGN(MMUL)
19216
19217C...Double precision and integer declarations.
19218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19219 IMPLICIT INTEGER(I-N)
19220 INTEGER PYK,PYCHGE,PYCOMP
19221 EXTERNAL PYALPS
19222 DOUBLE PRECISION PYALPS
19223C...Commonblocks.
19224 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19225 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19226 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19227 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19228 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19229 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19230 COMMON/PYINT1/MINT(400),VINT(400)
19231 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19232 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19233 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19234 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19235 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19236 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19237 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19238 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19239 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19240C...Local arrays and saved variables.
19241 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19242 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19243 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19244 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19245 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19246
19247C...Initialization of multiple interaction treatment.
19248 IF(MMUL.EQ.1) THEN
19249 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19250 ISUB=96
19251 MINT(1)=96
19252 VINT(63)=0D0
19253 VINT(64)=0D0
19254 VINT(143)=1D0
19255 VINT(144)=1D0
19256
19257C...Loop over phase space points: xT2 choice in 20 bins.
19258 100 SIGSUM=0D0
19259 DO 120 IXT2=1,20
19260 NMUL(IXT2)=MSTP(83)
19261 SIGM(IXT2)=0D0
19262 DO 110 ITRY=1,MSTP(83)
19263 RSCA=0.05D0*((21-IXT2)-PYR(0))
19264 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19265 XT2=MAX(0.01D0*VINT(149),XT2)
19266 VINT(25)=XT2
19267
19268C...Choose tau and y*. Calculate cos(theta-hat).
19269 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19270 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19271 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19272 ELSE
19273 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19274 ENDIF
19275 VINT(21)=TAU
19276 CALL PYKLIM(2)
19277 RYST=PYR(0)
19278 MYST=1
19279 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19280 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19281 CALL PYKMAP(2,MYST,PYR(0))
19282 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19283
19284C...Calculate differential cross-section.
19285 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19286 CALL PYSIGH(NCHN,SIGS)
19287 SIGM(IXT2)=SIGM(IXT2)+SIGS
19288 110 CONTINUE
19289 SIGSUM=SIGSUM+SIGM(IXT2)
19290 120 CONTINUE
19291 SIGSUM=SIGSUM/(20D0*MSTP(83))
19292
19293C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19294 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19295 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19296 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19297 PARP(82)=0.9D0*PARP(82)
19298 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19299 & VINT(2)
19300 GOTO 100
19301 ENDIF
19302 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19303 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19304
19305C...Start iteration to find k factor.
19306 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19307 P83A=(1D0-PARP(83))**2
19308 P83B=2D0*PARP(83)*(1D0-PARP(83))
19309 P83C=PARP(83)**2
19310 CQ2I=1D0/PARP(84)**2
19311 CQ2R=2D0/(1D0+PARP(84)**2)
19312 SO=0.5D0
19313 XI=0D0
19314 YI=0D0
19315 XF=0D0
19316 YF=0D0
19317 XK=0.5D0
19318 IIT=0
19319 130 IF(IIT.EQ.0) THEN
19320 XK=2D0*XK
19321 ELSEIF(IIT.EQ.1) THEN
19322 XK=0.5D0*XK
19323 ELSE
19324 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19325 ENDIF
19326
19327C...Evaluate overlap integrals. Find where to divide the b range.
19328 IF(MSTP(82).EQ.2) THEN
19329 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19330 SOP=SP/PARU(1)
19331 ELSE
19332 IF(MSTP(82).EQ.3) THEN
19333 DELTAB=0.02D0
19334 ELSEIF(MSTP(82).EQ.4) THEN
19335 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19336 ELSE
19337 POWIP=MAX(0.4D0,PARP(83))
19338 RPWIP=2D0/POWIP-1D0
19339 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19340 SO=0D0
19341 ENDIF
19342 SP=0D0
19343 SOP=0D0
19344 BSP=0D0
19345 SOHIGH=0D0
19346 IBDIV=0
19347 B=-0.5D0*DELTAB
19348 140 B=B+DELTAB
19349 IF(MSTP(82).EQ.3) THEN
19350 OV=EXP(-B**2)/PARU(2)
19351 ELSEIF(MSTP(82).EQ.4) THEN
19352 OV=(P83A*EXP(-MIN(50D0,B**2))+
19353 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19354 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19355 ELSE
19356 OV=EXP(-B**POWIP)/PARU(2)
19357 SO=SO+PARU(2)*B*DELTAB*OV
19358 ENDIF
19359 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19360 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19361 SP=SP+PARU(2)*B*DELTAB*PACC
19362 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19363 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19364 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19365 IBDIV=1
19366 BDIV=B+0.5D0*DELTAB
19367 ENDIF
19368 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19369 ENDIF
19370 YK=PARU(1)*XK*SO/SP
19371
19372C...Continue iteration until convergence.
19373 IF(YK.LT.YKE) THEN
19374 XI=XK
19375 YI=YK
19376 IF(IIT.EQ.1) IIT=2
19377 ELSE
19378 XF=XK
19379 YF=YK
19380 IF(IIT.EQ.0) IIT=1
19381 ENDIF
19382 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19383
19384C...Store some results for subsequent use.
19385 BAVG=BSP/SP
19386 VINT(145)=SIGSUM
19387 VINT(146)=SOP/SO
19388 VINT(147)=SOP/SP
19389 VNT145=VINT(145)
19390 VNT146=VINT(146)
19391 VNT147=VINT(147)
19392C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19393 PIK=(VNT146/VNT147)*YKE
19394
19395C...Find relative weight for low and high impact parameter..
19396 PLOWB=PARU(1)*BDIV**2
19397 IF(MSTP(82).EQ.3) THEN
19398 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19399 ELSEIF(MSTP(82).EQ.4) THEN
19400 S4A=P83A*EXP(-BDIV**2)
19401 S4B=P83B*EXP(-BDIV**2*CQ2R)
19402 S4C=P83C*EXP(-BDIV**2*CQ2I)
19403 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19404 ELSEIF(PARP(83).GE.1.999D0) THEN
19405 PHIGHB=PIK*SOHIGH
19406 B2RPDV=BDIV**POWIP
19407 ELSE
19408 PHIGHB=PIK*SOHIGH
19409 B2RPDV=BDIV**POWIP
19410 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19411 ENDIF
19412 PALLB=PLOWB+PHIGHB
19413
19414C...Initialize iteration in xT2 for hardest interaction.
19415 ELSEIF(MMUL.EQ.2) THEN
19416 VINT(145)=VNT145
19417 VINT(146)=VNT146
19418 VINT(147)=VNT147
19419 IF(MSTP(82).LE.0) THEN
19420 ELSEIF(MSTP(82).EQ.1) THEN
19421 XT2=1D0
19422 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19423 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19424 & VINT(317)/(VINT(318)*VINT(320))
19425 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19426 ELSEIF(MSTP(82).EQ.2) THEN
19427 XT2=1D0
19428 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19429 & VINT(149)*(1D0+VINT(149))
19430 ELSE
19431 XC2=4D0*CKIN(3)**2/VINT(2)
19432 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19433 ENDIF
19434
19435C...Select impact parameter for hardest interaction.
19436 IF(MSTP(82).LE.2) RETURN
19437 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19438C...Treatment in low b region.
19439 MINT(39)=1
19440 B=BDIV*SQRT(PYR(0))
19441 IF(MSTP(82).EQ.3) THEN
19442 OV=EXP(-B**2)/PARU(2)
19443 ELSEIF(MSTP(82).EQ.4) THEN
19444 OV=(P83A*EXP(-MIN(50D0,B**2))+
19445 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19446 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19447 ELSE
19448 OV=EXP(-B**POWIP)/PARU(2)
19449 ENDIF
19450 VINT(148)=OV/VNT147
19451 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19452 XT2=1D0
19453 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19454 & VINT(149)*(1D0+VINT(149))
19455 ELSE
19456C...Treatment in high b region.
19457 MINT(39)=2
19458 IF(MSTP(82).EQ.3) THEN
19459 B=SQRT(BDIV**2-LOG(PYR(0)))
19460 OV=EXP(-B**2)/PARU(2)
19461 ELSEIF(MSTP(82).EQ.4) THEN
19462 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19463 IF(S4RNDM.LT.S4A) THEN
19464 B=SQRT(BDIV**2-LOG(PYR(0)))
19465 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19466 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19467 ELSE
19468 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19469 ENDIF
19470 OV=(P83A*EXP(-MIN(50D0,B**2))+
19471 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19472 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19473 ELSEIF(PARP(83).GE.1.999D0) THEN
19474 144 B2RPW=B2RPDV-LOG(PYR(0))
19475 ACCIP=(B2RPW/B2RPDV)**RPWIP
19476 IF(ACCIP.LT.PYR(0)) GOTO 144
19477 OV=EXP(-B2RPW)/PARU(2)
19478 B=B2RPW**(1D0/POWIP)
19479 ELSE
19480 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19481 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19482 IF(ACCIP.LT.PYR(0)) GOTO 146
19483 OV=EXP(-B2RPW)/PARU(2)
19484 B=B2RPW**(1D0/POWIP)
19485 ENDIF
19486 VINT(148)=OV/VNT147
19487 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19488 ENDIF
19489 IF(PACC.LT.PYR(0)) GOTO 142
19490 VINT(139)=B/BAVG
19491
19492 ELSEIF(MMUL.EQ.3) THEN
19493C...Low-pT or multiple interactions (first semihard interaction):
19494C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19495C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19496 ISUB=MINT(1)
19497 VINT(145)=VNT145
19498 VINT(146)=VNT146
19499 VINT(147)=VNT147
19500 IF(MSTP(82).LE.0) THEN
19501 XT2=0D0
19502 ELSEIF(MSTP(82).EQ.1) THEN
19503 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19504C...Use with "Sudakov" for low b values when impact parameter dependence.
19505 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19506 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19507 & VINT(149)))).GT.PYR(0)) XT2=1D0
19508 IF(XT2.GE.1D0) THEN
19509 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19510 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19511 & VINT(149)
19512 ELSE
19513 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19514 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19515 & VINT(149)
19516 ENDIF
19517 XT2=MAX(0.01D0*VINT(149),XT2)
19518C...Use without "Sudakov" for high b values when impact parameter dep.
19519 ELSE
19520 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19521 & PYR(0)*(1D0-XC2))-VINT(149)
19522 XT2=MAX(0.01D0*VINT(149),XT2)
19523 ENDIF
19524 VINT(25)=XT2
19525
19526C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19527 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19528 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19529 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19530 ISUB=95
19531 MINT(1)=ISUB
19532 VINT(21)=1D-12*VINT(149)
19533 VINT(22)=0D0
19534 VINT(23)=0D0
19535 VINT(25)=1D-12*VINT(149)
19536
19537 ELSE
19538C...Multiple interactions (first semihard interaction).
19539C...Choose tau and y*. Calculate cos(theta-hat).
19540 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19541 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19542 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19543 ELSE
19544 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19545 ENDIF
19546 VINT(21)=TAU
19547 CALL PYKLIM(2)
19548 RYST=PYR(0)
19549 MYST=1
19550 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19551 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19552 CALL PYKMAP(2,MYST,PYR(0))
19553 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19554 ENDIF
19555 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19556
19557C...Store results of cross-section calculation.
19558 ELSEIF(MMUL.EQ.4) THEN
19559 ISUB=MINT(1)
19560 VINT(145)=VNT145
19561 VINT(146)=VNT146
19562 VINT(147)=VNT147
19563 XTS=VINT(25)
19564 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19565 IF(ISET(ISUB).EQ.2)
19566 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19567 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19568 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19569 & (XTS+VINT(149))))
19570 IRBIN=INT(1D0+20D0*RBIN)
19571 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19572 NMUL(IRBIN)=NMUL(IRBIN)+1
19573 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19574 ENDIF
19575
19576C...Choose impact parameter if not already done.
19577 ELSEIF(MMUL.EQ.5) THEN
19578 ISUB=MINT(1)
19579 VINT(145)=VNT145
19580 VINT(146)=VNT146
19581 VINT(147)=VNT147
19582 150 IF(MINT(39).GT.0) THEN
19583 ELSEIF(MSTP(82).EQ.3) THEN
19584 EXPB2=PYR(0)
19585 B2=-LOG(PYR(0))
19586 VINT(148)=EXPB2/(PARU(2)*VNT147)
19587 VINT(139)=SQRT(B2)/BAVG
19588 ELSEIF(MSTP(82).EQ.4) THEN
19589 RTYPE=PYR(0)
19590 IF(RTYPE.LT.P83A) THEN
19591 B2=-LOG(PYR(0))
19592 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19593 B2=-LOG(PYR(0))/CQ2R
19594 ELSE
19595 B2=-LOG(PYR(0))/CQ2I
19596 ENDIF
19597 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19598 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19599 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19600 VINT(139)=SQRT(B2)/BAVG
19601 ELSEIF(PARP(83).GE.1.999D0) THEN
19602 POWIP=MAX(2D0,PARP(83))
19603 RPWIP=2D0/POWIP-1D0
19604 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19605 160 IF(PYR(0).LT.PROB1) THEN
19606 B2RPW=PYR(0)**(0.5D0*POWIP)
19607 ACCIP=EXP(-B2RPW)
19608 ELSE
19609 B2RPW=1D0-LOG(PYR(0))
19610 ACCIP=B2RPW**RPWIP
19611 ENDIF
19612 IF(ACCIP.LT.PYR(0)) GOTO 160
19613 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19614 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19615 ELSE
19616 POWIP=MAX(0.4D0,PARP(83))
19617 RPWIP=2D0/POWIP-1D0
19618 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19619 170 IF(PYR(0).LT.PROB1) THEN
19620 B2RPW=2D0*RPWIP*PYR(0)
19621 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19622 ELSE
19623 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19624 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19625 ENDIF
19626 IF(ACCIP.LT .PYR(0)) GOTO 170
19627 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19628 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19629 ENDIF
19630
19631C...Multiple interactions (variable impact parameter) : reject with
19632C...probability exp(-overlap*cross-section above pT/normalization).
19633C...Does not apply to low-b region, where "Sudakov" already included.
19634 VINT(150)=1D0
19635 IF(MINT(39).NE.1) THEN
19636 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19637 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19638 DO 180 IBIN=IRBIN+1,20
19639 RNCOR=RNCOR+NMUL(IBIN)
19640 SIGCOR=SIGCOR+SIGM(IBIN)
19641 180 CONTINUE
19642 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19643 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19644 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19645 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19646 ENDIF
19647 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19648 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19649 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19650 IF(VINT(150).LT.PYR(0)) GOTO 150
19651 VINT(150)=1D0
19652 ENDIF
19653
19654C...Generate additional multiple semihard interactions.
19655 ELSEIF(MMUL.EQ.6) THEN
19656
19657C...Save data for hardest initeraction, to be restored.
19658 ISUBSV=MINT(1)
19659 VINT(145)=VNT145
19660 VINT(146)=VNT146
19661 VINT(147)=VNT147
19662 M13SV=MINT(13)
19663 M14SV=MINT(14)
19664 M15SV=MINT(15)
19665 M16SV=MINT(16)
19666 M21SV=MINT(21)
19667 M22SV=MINT(22)
19668 DO 190 J=11,80
19669 VINTSV(J)=VINT(J)
19670 190 CONTINUE
19671 V141SV=VINT(141)
19672 V142SV=VINT(142)
19673
19674C...Store data on hardest interaction.
19675 XMI(1,1)=VINT(141)
19676 XMI(2,1)=VINT(142)
19677 PT2MI(1)=VINT(54)
19678 IMISEP(0)=MINT(84)
19679 IMISEP(1)=N
19680
19681C...Change process to generate; sum of x values so far.
19682 ISUB=96
19683 MINT(1)=96
19684 VINT(143)=1D0-VINT(141)
19685 VINT(144)=1D0-VINT(142)
19686 VINT(151)=0D0
19687 VINT(152)=0D0
19688
19689C...Initialize factors for PDF reshaping.
19690 DO 230 JS=1,2
19691 KFBEAM=MINT(10+JS)
19692 KFABM=IABS(KFBEAM)
19693 KFSBM=ISIGN(1,KFBEAM)
19694
19695C...Zero flavour content of incoming beam particle.
19696 KFIVAL(JS,1)=0
19697 KFIVAL(JS,2)=0
19698 KFIVAL(JS,3)=0
19699C...Flavour content of baryon.
19700 IF(KFABM.GT.1000) THEN
19701 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
19702 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
19703 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
19704C...Flavour content of pi+-, K+-.
19705 ELSEIF(KFABM.EQ.211) THEN
19706 KFIVAL(JS,1)=KFSBM*2
19707 KFIVAL(JS,2)=-KFSBM
19708 ELSEIF(KFABM.EQ.321) THEN
19709 KFIVAL(JS,1)=-KFSBM*3
19710 KFIVAL(JS,2)=KFSBM*2
19711C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
19712 ENDIF
19713
19714C...Zero initial valence and companion content.
19715 DO 200 IFL=-6,6
19716 NVC(JS,IFL)=0
19717 200 CONTINUE
19718
19719C...Initiate listing of all incoming partons from two sides.
19720 NMI(JS)=0
19721 DO 210 I=MINT(84)+1,N
19722 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
19723 IMI(JS,1,1)=I
19724 IMI(JS,1,2)=0
19725 ENDIF
19726 210 CONTINUE
19727
19728C...Decide whether quarks in hard scattering were valence or sea.
19729 IFL=K(IMI(JS,1,1),2)
19730 IF (IABS(IFL).GT.6) GOTO 230
19731
19732C...Get PDFs at X and Q2 of the parton shower initiator for the
19733C...hard scattering.
19734 X=VINT(140+JS)
19735 IF(MSTP(61).GE.1) THEN
19736 Q2=PARP(62)**2
19737 ELSE
19738 Q2=VINT(54)
19739 ENDIF
19740C...Note: XPSVC = x*pdf.
19741 MINT(30)=JS
19742 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
19743 SEA=XPSVC(IFL,-1)
19744 VAL=XPSVC(IFL,0)
19745
19746C...Decide (Extra factor x cancels in the division).
19747 RVCS=PYR(0)*(SEA+VAL)
19748 IVNOW=1
19749 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
19750C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
19751 IVNOW=0
19752 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
19753 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
19754 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
19755 IF(KFIVAL(JS,1).EQ.0) THEN
19756 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
19757 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
19758 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
19759 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
19760 ENDIF
19761 IF(IVNOW.EQ.0) GOTO 220
19762C...Mark valence.
19763 IMI(JS,1,2)=0
19764C...Sets valence content of gamma, pi0, K0S, K0L if not done.
19765 IF(KFIVAL(JS,1).EQ.0) THEN
19766 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
19767 KFIVAL(JS,1)=IFL
19768 KFIVAL(JS,2)=-IFL
19769 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
19770 KFIVAL(JS,1)=IFL
19771 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
19772 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
19773 ENDIF
19774 ENDIF
19775
19776C...If sea, add opposite sign companion parton. Store X and I.
19777 ELSE
19778 NVC(JS,-IFL)=NVC(JS,-IFL)+1
19779 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
19780C...Set pointer to companion
19781 IMI(JS,1,2)=-NVC(JS,-IFL)
19782 ENDIF
19783 230 CONTINUE
19784
19785C...Update counter number of multiple interactions.
19786 NMI(1)=1
19787 NMI(2)=1
19788
19789C...Set up starting values for iteration in xT2.
19790 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
19791 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
19792 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
19793 & ISUBSV.NE.96)) THEN
19794 XT2=(1D0-VINT(141))*(1D0-VINT(142))
19795 ELSE
19796 XT2=VINT(25)
19797 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
19798 IF(ISET(ISUBSV).EQ.2)
19799 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19800 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
19801 ENDIF
19802 IF(MSTP(82).LE.1) THEN
19803 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19804 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19805 & VINT(317)/(VINT(318)*VINT(320))
19806 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19807 ELSE
19808 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19809 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19810 ENDIF
19811 VINT(63)=0D0
19812 VINT(64)=0D0
19813
19814C...Iterate downwards in xT2.
19815 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
19816 XT2=0D0
19817 GOTO 440
19818 ELSEIF(MSTP(82).LE.1) THEN
19819 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19820 IF(XT2.LT.VINT(149)) GOTO 440
19821 ELSE
19822 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
19823 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19824 & LOG(PYR(0)))-VINT(149)
19825 IF(XT2.LE.0D0) GOTO 440
19826 XT2=MAX(0.01D0*VINT(149),XT2)
19827 ENDIF
19828 VINT(25)=XT2
19829
19830C...Choose tau and y*. Calculate cos(theta-hat).
19831 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19832 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19833 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19834 ELSE
19835 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19836 ENDIF
19837 VINT(21)=TAU
19838C...New: require shat > 1.
19839 IF(TAU*VINT(2).LT.1D0) GOTO 240
19840 CALL PYKLIM(2)
19841 RYST=PYR(0)
19842 MYST=1
19843 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19844 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19845 CALL PYKMAP(2,MYST,PYR(0))
19846 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19847
19848C...Check that x not used up. Accept or reject kinematical variables.
19849 X1M=SQRT(TAU)*EXP(VINT(22))
19850 X2M=SQRT(TAU)*EXP(-VINT(22))
19851 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
19852 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19853 CALL PYSIGH(NCHN,SIGS)
19854 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19855 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
19856 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
19857
19858C...Reset K, P and V vectors.
19859 DO 260 I=N+1,N+4
19860 DO 250 J=1,5
19861 K(I,J)=0
19862 P(I,J)=0D0
19863 V(I,J)=0D0
19864 250 CONTINUE
19865 260 CONTINUE
19866 PT=0.5D0*VINT(1)*SQRT(XT2)
19867
19868C...Choose flavour of reacting partons (and subprocess).
19869 RSIGS=SIGS*PYR(0)
19870 DO 270 ICHN=1,NCHN
19871 KFL1=ISIG(ICHN,1)
19872 KFL2=ISIG(ICHN,2)
19873 ICONMI=ISIG(ICHN,3)
19874 RSIGS=RSIGS-SIGH(ICHN)
19875 IF(RSIGS.LE.0D0) GOTO 280
19876 270 CONTINUE
19877
19878C...Reassign to appropriate process codes.
19879 280 ISUBMI=ICONMI/10
19880 ICONMI=MOD(ICONMI,10)
19881
19882C...Choose new quark flavour for annihilation graphs
19883 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
19884 SH=TAU*VINT(2)
19885 CALL PYWIDT(21,SH,WDTP,WDTE)
19886 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
19887 DO 300 I=1,MDCY(21,3)
19888 KFLF=KFDP(I+MDCY(21,2)-1,1)
19889 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
19890 IF(RKFL.LE.0D0) GOTO 310
19891 300 CONTINUE
19892 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
19893 IF(KFLF.GE.4) GOTO 290
19894 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
19895 KFLF=4
19896 ICONMI=ICONMI-2
19897 ELSEIF(ISUBMI.EQ.53) THEN
19898 KFLF=5
19899 ICONMI=ICONMI-4
19900 ENDIF
19901 ENDIF
19902
19903C...Final state flavours and colour flow: default values
19904 JS=1
19905 KFL3=KFL1
19906 KFL4=KFL2
19907 KCC=20
19908 KCS=ISIGN(1,KFL1)
19909
19910 IF(ISUBMI.EQ.11) THEN
19911C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
19912 KCC=ICONMI
19913 IF(KFL1*KFL2.LT.0) KCC=KCC+2
19914
19915 ELSEIF(ISUBMI.EQ.12) THEN
19916C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
19917 KFL3=ISIGN(KFLF,KFL1)
19918 KFL4=-KFL3
19919 KCC=4
19920
19921 ELSEIF(ISUBMI.EQ.13) THEN
19922C...f + fbar -> g + g; th arbitrary
19923 KFL3=21
19924 KFL4=21
19925 KCC=ICONMI+4
19926
19927 ELSEIF(ISUBMI.EQ.28) THEN
19928C...f + g -> f + g; th = (p(f)-p(f))**2
19929 IF(KFL1.EQ.21) JS=2
19930 KCC=ICONMI+6
19931 IF(KFL1.EQ.21) KCC=KCC+2
19932 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
19933 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
19934
19935 ELSEIF(ISUBMI.EQ.53) THEN
19936C...g + g -> f + fbar; th arbitrary
19937 KCS=(-1)**INT(1.5D0+PYR(0))
19938 KFL3=ISIGN(KFLF,KCS)
19939 KFL4=-KFL3
19940 KCC=ICONMI+10
19941
19942 ELSEIF(ISUBMI.EQ.68) THEN
19943C...g + g -> g + g; th arbitrary
19944 KCC=ICONMI+12
19945 KCS=(-1)**INT(1.5D0+PYR(0))
19946 ENDIF
19947
19948C...Store flavours of scattering.
19949 MINT(13)=KFL1
19950 MINT(14)=KFL2
19951 MINT(15)=KFL1
19952 MINT(16)=KFL2
19953 MINT(21)=KFL3
19954 MINT(22)=KFL4
19955
19956C...Set flavours and mothers of scattering partons.
19957 K(N+1,1)=14
19958 K(N+2,1)=14
19959 K(N+3,1)=3
19960 K(N+4,1)=3
19961 K(N+1,2)=KFL1
19962 K(N+2,2)=KFL2
19963 K(N+3,2)=KFL3
19964 K(N+4,2)=KFL4
19965 K(N+1,3)=MINT(83)+1
19966 K(N+2,3)=MINT(83)+2
19967 K(N+3,3)=N+1
19968 K(N+4,3)=N+2
19969
19970C...Store colour connection indices.
19971 DO 320 J=1,2
19972 JC=J
19973 IF(KCS.EQ.-1) JC=3-J
19974 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
19975 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
19976 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
19977 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
19978 320 CONTINUE
19979
19980C...Store incoming and outgoing partons in their CM-frame.
19981 SHR=SQRT(TAU)*VINT(1)
19982 P(N+1,3)=0.5D0*SHR
19983 P(N+1,4)=0.5D0*SHR
19984 P(N+2,3)=-0.5D0*SHR
19985 P(N+2,4)=0.5D0*SHR
19986 P(N+3,5)=PYMASS(K(N+3,2))
19987 P(N+4,5)=PYMASS(K(N+4,2))
19988 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
19989 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
19990 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
19991 P(N+4,4)=SHR-P(N+3,4)
19992 P(N+4,3)=-P(N+3,3)
19993
19994C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
19995 PHI=PARU(2)*PYR(0)
19996 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
19997
19998C...Set up default values before showers.
19999 MINT(31)=MINT(31)+1
20000 IPU1=N+1
20001 IPU2=N+2
20002 IPU3=N+3
20003 IPU4=N+4
20004 VINT(141)=VINT(41)
20005 VINT(142)=VINT(42)
20006 N=N+4
20007
20008C...Showering of initial state partons (optional).
20009C...Note: no showering of final state partons here; it comes later.
20010 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20011 MINT(51)=0
20012 ALAMSV=PARJ(81)
20013 PARJ(81)=PARP(72)
20014 NSAV=N
20015 DO 340 I=1,4
20016 DO 330 J=1,5
20017 KSAV(I,J)=K(N-4+I,J)
20018 PSAV(I,J)=P(N-4+I,J)
20019 330 CONTINUE
20020 340 CONTINUE
20021 CALL PYSSPA(IPU1,IPU2)
20022 PARJ(81)=ALAMSV
20023C...If shower failed then restore to situation before shower.
20024 IF(MINT(51).GE.1) THEN
20025 N=NSAV
20026 DO 360 I=1,4
20027 DO 350 J=1,5
20028 K(N-4+I,J)=KSAV(I,J)
20029 P(N-4+I,J)=PSAV(I,J)
20030 350 CONTINUE
20031 360 CONTINUE
20032 IPU1=N-3
20033 IPU2=N-2
20034 VINT(141)=VINT(41)
20035 VINT(142)=VINT(42)
20036 ENDIF
20037 ENDIF
20038
20039C...Keep track of loose colour ends and information on scattering.
20040 370 IMI(1,MINT(31),1)=IPU1
20041 IMI(2,MINT(31),1)=IPU2
20042 IMI(1,MINT(31),2)=0
20043 IMI(2,MINT(31),2)=0
20044 XMI(1,MINT(31))=VINT(141)
20045 XMI(2,MINT(31))=VINT(142)
20046 PT2MI(MINT(31))=VINT(54)
20047 IMISEP(MINT(31))=N
20048
20049C...Decide whether quarks in last scattering were valence, companion or
20050C...sea.
20051 DO 430 JS=1,2
20052 KFBEAM=MINT(10+JS)
20053 KFSBM=ISIGN(1,MINT(10+JS))
20054 IFL=K(IMI(JS,MINT(31),1),2)
20055 IMI(JS,MINT(31),2)=0
20056 IF (IABS(IFL).GT.6) GOTO 430
20057
20058C...Get PDFs at X and Q2 of the parton shower initiator for the
20059C...last scattering. At this point VINT(143:144) do not yet
20060C...include the scattered x values VINT(141:142).
20061 X=VINT(140+JS)/VINT(142+JS)
20062 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20063 Q2=PARP(62)**2
20064 ELSE
20065 Q2=VINT(54)
20066 ENDIF
20067C...Note: XPSVC = x*pdf.
20068 MINT(30)=JS
20069 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20070 SEA=XPSVC(IFL,-1)
20071 VAL=XPSVC(IFL,0)
20072 CMP=0D0
20073 DO 380 IVC=1,NVC(JS,IFL)
20074 CMP=CMP+XPSVC(IFL,IVC)
20075 380 CONTINUE
20076
20077C...Decide (Extra factor x cancels in the dvision).
20078 RVCS=PYR(0)*(SEA+VAL+CMP)
20079 IVNOW=1
20080 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20081C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20082 IVNOW=0
20083 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20084 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20085 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20086 IF(KFIVAL(JS,1).EQ.0) THEN
20087 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20088 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20089 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20090 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20091 ELSE
20092 DO 400 I1=1,NMI(JS)
20093 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20094 & IVNOW=IVNOW-1
20095 400 CONTINUE
20096 ENDIF
20097 IF(IVNOW.EQ.0) GOTO 390
20098C...Mark valence.
20099 IMI(JS,MINT(31),2)=0
20100C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20101 IF(KFIVAL(JS,1).EQ.0) THEN
20102 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20103 KFIVAL(JS,1)=IFL
20104 KFIVAL(JS,2)=-IFL
20105 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20106 KFIVAL(JS,1)=IFL
20107 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20108 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20109 ENDIF
20110 ENDIF
20111
20112 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20113C...If sea, add opposite sign companion parton. Store X and I.
20114 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20115 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20116C...Set pointer to companion
20117 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20118 ELSE
20119C...If companion, decide which one.
20120 CMPSUM=VAL+SEA
20121 ISEL=0
20122 410 ISEL=ISEL+1
20123 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20124 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20125C...Find original sea (anti-)quark:
20126 IASSOC=0
20127 DO 420 I1=1,NMI(JS)
20128 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20129 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20130 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20131 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20132 ENDIF
20133 420 CONTINUE
20134C...Change X to what associated companion had, so that the correct
20135C...amount of momentum can be subtracted from the companion sum below.
20136 X=XASSOC(JS,IFL,ISEL)
20137C...Mark companion read.
20138 XASSOC(JS,IFL,ISEL)=0D0
20139 ENDIF
20140 430 CONTINUE
20141
20142C...Global statistics.
20143 MINT(351)=MINT(351)+1
20144 VINT(351)=VINT(351)+PT
20145 IF (MINT(351).EQ.1) VINT(356)=PT
20146
20147C...Update remaining energy and other counters.
20148 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20149 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20150 MINT(51)=1
20151 RETURN
20152 ENDIF
20153 NMI(1)=NMI(1)+1
20154 NMI(2)=NMI(2)+1
20155 VINT(151)=VINT(151)+VINT(41)
20156 VINT(152)=VINT(152)+VINT(42)
20157 VINT(143)=VINT(143)-VINT(141)
20158 VINT(144)=VINT(144)-VINT(142)
20159
20160C...Iterate, with more interactions allowed.
20161 IF(MINT(31).LT.240) GOTO 240
20162 440 CONTINUE
20163
20164C...Restore saved quantities for hardest interaction.
20165 MINT(1)=ISUBSV
20166 MINT(13)=M13SV
20167 MINT(14)=M14SV
20168 MINT(15)=M15SV
20169 MINT(16)=M16SV
20170 MINT(21)=M21SV
20171 MINT(22)=M22SV
20172 DO 450 J=11,80
20173 VINT(J)=VINTSV(J)
20174 450 CONTINUE
20175 VINT(141)=V141SV
20176 VINT(142)=V142SV
20177
20178 ENDIF
20179
20180C...Format statements for printout.
20181 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20182 &'actions for MSTP(82) =',I2,' ******')
20183 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20184 &D9.2,' mb: rejected')
20185 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20186 &D9.2,' mb: accepted')
20187
20188 RETURN
20189 END
20190
20191C*********************************************************************
20192
20193C...PYMIHK
20194C...Finds left-behind remnant flavour content and hooks up
20195C...the colour flow between the hard scattering and remnants
20196
20197 SUBROUTINE PYMIHK
20198
20199C...Double precision and integer declarations.
20200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20201 IMPLICIT INTEGER(I-N)
20202 INTEGER PYK,PYCHGE,PYCOMP
20203C...The event record
20204 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20205C...Parameters
20206 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20207 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20208 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20209 COMMON/PYINT1/MINT(400),VINT(400)
20210C...The common block of dangling ends
20211 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20212 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20213 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20214 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20215C...Local variables
20216 PARAMETER (NERSIZ=4000)
20217 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20218 & ,MACCPT
20219 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20220 SAVE /PYCBLS/,/PYCTAG/
20221 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20222 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20223 DATA NERRPR/0/
20224 SAVE NERRPR
20225 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)
20226
20227C...Set up error checkers
20228 IBOOST=0
20229
20230C...Initialize colour arrays: MCO (Original) and MCT (New)
20231 DO 110 I=MINT(84)+1,NERSIZ
20232 DO 100 JC=1,2
20233 MCT(I,JC)=0
20234 MCO(I,JC)=0
20235 100 CONTINUE
20236C...Also zero colour tracing information, if existed.
20237 IF (I.LE.N) THEN
20238 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20239 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20240 ENDIF
20241 110 CONTINUE
20242
20243C...Initialize colour tag collapse arrays:
20244C...JCCO (Original) and JCCN (New).
20245 DO 130 MG=MINT(84)+1,NERSIZ
20246 DO 120 JC=1,2
20247 JCCO(MG,JC)=0
20248 JCCN(MG,JC)=0
20249 120 CONTINUE
20250 130 CONTINUE
20251
20252C...Zero gluon insertion array
20253 DO 150 IM=1,1000
20254 DO 140 J=1,3
20255 INSR(IM,J)=0
20256 140 CONTINUE
20257 150 CONTINUE
20258
20259C...Compute hard scattering system rapidities
20260 IF (MSTP(89).EQ.1) THEN
20261 DO 160 IM=1,240
20262 IF (IM.LE.MINT(31)) THEN
20263 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20264 ELSE
20265C...Set (unsigned) rapidity = 100 for beam remnant systems.
20266 YMI(IM)=100D0
20267 ENDIF
20268 160 CONTINUE
20269 ENDIF
20270
20271C...Treat each side separately
20272 DO 290 JS=1,2
20273
20274C...Initialize side.
20275 NG(JS)=0
20276 JV=0
20277 KFS=ISIGN(1,MINT(10+JS))
20278
20279C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20280 IF(KFIVAL(JS,1).EQ.0) THEN
20281 IF(MINT(10+JS).EQ.111) THEN
20282 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20283 KFIVAL(JS,2)=-KFIVAL(JS,1)
20284 ELSEIF(MINT(10+JS).EQ.22) THEN
20285 PYRKF=PYR(0)
20286 KFIVAL(JS,1)=1
20287 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20288 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20289 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20290 KFIVAL(JS,2)=-KFIVAL(JS,1)
20291 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20292 IF(PYR(0).GT.0.5D0) THEN
20293 KFIVAL(JS,1)=1
20294 KFIVAL(JS,2)=-3
20295 ELSE
20296 KFIVAL(JS,1)=3
20297 KFIVAL(JS,2)=-1
20298 ENDIF
20299 ENDIF
20300 ENDIF
20301
20302C...Initialize beam remnant sea and valence content flavour by flavour.
20303 NVSUM(JS)=0
20304 NBRTOT(JS)=0
20305 DO 210 JFA=1,6
20306C...Count up original number of JFA valence quarks and antiquarks.
20307 NVALQ=0
20308 NVALQB=0
20309 NSEA=0
20310 DO 170 J=1,3
20311 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20312 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20313 170 CONTINUE
20314 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20315C...Subtract kicked out valence and determine sea from flavour cons.
20316 DO 180 IM=1,NMI(JS)
20317 IFL = K(IMI(JS,IM,1),2)
20318 IFA = IABS(IFL)
20319 IFS = ISIGN(1,IFL)
20320 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20321C...Subtract K.O. valence quark from remainder.
20322 NVALQ=NVALQ-1
20323 JV=NVSUM(JS)-NVALQ-NVALQB
20324 IV(JS,JV)=IMI(JS,IM,1)
20325 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20326C...Subtract K.O. valence antiquark from remainder.
20327 NVALQB=NVALQB-1
20328 JV=NVSUM(JS)-NVALQ-NVALQB
20329 IV(JS,JV)=IMI(JS,IM,1)
20330 ELSEIF (IFA.EQ.JFA) THEN
20331C...Outside sea without companion: add opposite sea flavour inside.
20332 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20333 ENDIF
20334 180 CONTINUE
20335C...Check if space left in PYJETS for additional BR flavours
20336 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20337 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20338 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20339 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20340 MINT(51)=1
20341 RETURN
20342 ENDIF
20343C...Add required val+sea content to beam remnant.
20344 IF (NFLSUM.GT.0) THEN
20345 DO 200 IA=1,NFLSUM
20346C...Insert beam remnant quark as p.t. symbolic parton in ER.
20347 N=N+1
20348 DO 190 IX=1,5
20349 K(N,IX)=0
20350 P(N,IX)=0D0
20351 V(N,IX)=0D0
20352 190 CONTINUE
20353 K(N,1)=3
20354 K(N,2)=ISIGN(JFA,NSEA)
20355 IF (IA.LE.NVALQ) K(N,2)=JFA
20356 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20357 K(N,3)=MINT(83)+JS
20358C...Also update NMI, IMI, and IV arrays.
20359 NMI(JS)=NMI(JS)+1
20360 IMI(JS,NMI(JS),1)=N
20361 IMI(JS,NMI(JS),2)=-1
20362 IF (IA.LE.NVALQ+NVALQB) THEN
20363 IMI(JS,NMI(JS),2)=0
20364 JV=JV+1
20365 IV(JS,JV)=IMI(JS,NMI(JS),1)
20366 ENDIF
20367 200 CONTINUE
20368 ENDIF
20369 210 CONTINUE
20370
20371 IM=0
20372 220 IM=IM+1
20373 IF (IM.LE.NMI(JS)) THEN
20374 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20375 NG(JS)=NG(JS)+1
20376C...Add fictitious parent gluons for companion pairs.
20377 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20378C...Randomly assign companions to sea quarks which have none.
20379 IF (IMI(JS,IM,2).LT.0) THEN
20380 IMC=PYR(0)*NMI(JS)
20381 230 IMC=MOD(IMC,NMI(JS))+1
20382 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20383 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20384 IMI(JS, IM,2) = IMI(JS,IMC,1)
20385 IMI(JS,IMC,2) = IMI(JS, IM,1)
20386 ENDIF
20387C...Add fictitious parent gluon
20388 N=N+1
20389 DO 240 IX=1,5
20390 K(N,IX)=0
20391 P(N,IX)=0D0
20392 V(N,IX)=0D0
20393 240 CONTINUE
20394 K(N,1)=14
20395 K(N,2)=21
20396 K(N,3)=MINT(83)+JS
20397C...Set gluon (anti-)colour daughter pointers
20398 K(N,4)=IMI(JS, IM,1)
20399 K(N,5)=IMI(JS, IM,2)
20400C...Set quark (anti-)colour parent pointers
20401 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
20402 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
20403C...Add gluon to IMI
20404 NMI(JS)=NMI(JS)+1
20405 IMI(JS,NMI(JS),1)=N
20406 IMI(JS,NMI(JS),2)=0
20407 ENDIF
20408 GOTO 220
20409 ENDIF
20410
20411C...If incoming (anti-)baryon, insert inside (anti-)junction.
20412C...Set up initial v-v-j-v configuration. Otherwise set up
20413C...mesonic v-vbar configuration
20414 IF (IABS(MINT(10+JS)).GT.1000) THEN
20415C...Determine junction type (1: B=1 2: B=-1)
20416 ITJUNC(JS) = (3-KFS)/2
20417C...Insert junction.
20418 N=N+1
20419 DO 250 IX=1,5
20420 K(N,IX)=0
20421 P(N,IX)=0D0
20422 V(N,IX)=0D0
20423 250 CONTINUE
20424C...Set special junction codes:
20425 K(N,1)=42
20426 K(N,2)=88
20427C...Set parent to side.
20428 K(N,3)=MINT(83)+JS
20429 K(N,4)=ITJUNC(JS)*MSTU(5)
20430 K(N,5)=0
20431C...Connect valence quarks to junction.
20432 MOUT(JS)=0
20433 MANTI=ITJUNC(JS)-1
20434C...Set (anti)colour mother = junction.
20435 DO 260 JV=1,3
20436 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
20437 & +MSTU(5)*N
20438C...Keep track of partons adjacent to junction:
20439 JST(JS,JV)=IV(JS,JV)
20440 260 CONTINUE
20441 ELSE
20442C...Mesons: set up initial q-qbar topology
20443 ITJUNC(JS)=0
20444 IF (K(IV(JS,1),2).GT.0) THEN
20445 IQ=IV(JS,1)
20446 IQBAR=IV(JS,2)
20447 ELSE
20448 IQ=IV(JS,2)
20449 IQBAR=IV(JS,1)
20450 ENDIF
20451 IV(JS,3)=0
20452 JST(JS,1)=IQ
20453 JST(JS,2)=IQBAR
20454 JST(JS,3)=0
20455 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
20456 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
20457C...Special for mesons. Insert gluon if BR empty.
20458 IF (NBRTOT(JS).EQ.0) THEN
20459 N=N+1
20460 DO 270 IX=1,5
20461 K(N,IX)=0
20462 P(N,IX)=0D0
20463 V(N,IX)=0D0
20464 270 CONTINUE
20465 K(N,1)=3
20466 K(N,2)=21
20467 K(N,3)=MINT(83)+JS
20468 K(N,4)=0
20469 K(N,5)=0
20470 NBRTOT(JS)=1
20471 NG(JS)=NG(JS)+1
20472C...Add gluon to IMI
20473 NMI(JS)=NMI(JS)+1
20474 IMI(JS,NMI(JS),1)=N
20475 IMI(JS,NMI(JS),2)=0
20476 ENDIF
20477 MOUT(JS)=0
20478 ENDIF
20479
20480C...Count up number of valence quarks outside BR.
20481 DO 280 JV=1,3
20482 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
20483 & MOUT(JS)=MOUT(JS)+1
20484 280 CONTINUE
20485
20486 290 CONTINUE
20487
20488C...Now both sides have been prepared in an initial vvjv (baryonic) or
20489C...v(g)vbar (mesonic) configuration.
20490
20491C...Create colour line tags starting from initiators.
20492 NCT=0
20493 DO 320 IM=1,MINT(31)
20494C...Consider each side in turn.
20495 DO 310 JS=1,2
20496 I1=IMI(JS,IM,1)
20497 I2=IMI(3-JS,IM,1)
20498 DO 300 JCS=4,5
20499 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
20500 & GOTO 300
20501 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
20502
20503 KCS=JCS
20504 CALL PYCTTR(I1,KCS,I2)
20505 IF(MINT(51).NE.0) RETURN
20506
20507 300 CONTINUE
20508 310 CONTINUE
20509 320 CONTINUE
20510
20511 DO 340 JS=1,2
20512C...Create colour tags for beam remnant partons.
20513 DO 330 IM=MINT(31)+1,NMI(JS)
20514 IP=IMI(JS,IM,1)
20515 IF (K(IP,2).NE.21) THEN
20516 JC=(3-ISIGN(1,K(IP,2)))/2
20517 IF (MCT(IP,JC).EQ.0) THEN
20518 NCT=NCT+1
20519 MCT(IP,JC)=NCT
20520 ENDIF
20521 ELSE
20522C...Gluons
20523 ICD=K(IP,4)
20524 IAD=K(IP,5)
20525 IF (ICD.NE.0) THEN
20526C...Fictituous gluons just inherit from their quark daughters.
20527 ICC=MCT(ICD,1)
20528 IAC=MCT(IAD,2)
20529 ELSE
20530C...Real beam remnant gluons get their own colours
20531 ICC=NCT+1
20532 IAC=NCT+2
20533 NCT=NCT+2
20534 ENDIF
20535 MCT(IP,1)=ICC
20536 MCT(IP,2)=IAC
20537 ENDIF
20538 330 CONTINUE
20539 340 CONTINUE
20540
20541C...Create colour tags for colour lines which are detached from the
20542C...initial state.
20543
20544 DO 360 MQGST=1,2
20545 DO 350 I=MINT(84)+1,N
20546
20547C...Look for coloured string endpoint, or (later) leftover gluon.
20548 IF (K(I,1).NE.3) GOTO 350
20549 KC=PYCOMP(K(I,2))
20550 IF(KC.EQ.0) GOTO 350
20551 KQ=KCHG(KC,2)
20552 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
20553
20554C...Pick up loose string end with no previous tag.
20555 KCS=4
20556 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
20557 IF(MCT(I,KCS-3).NE.0) GOTO 350
20558
20559 CALL PYCTTR(I,KCS,I)
20560 IF(MINT(51).NE.0) RETURN
20561
20562 350 CONTINUE
20563 360 CONTINUE
20564
20565C...Store original colour tags
20566 DO 370 I=MINT(84)+1,N
20567 MCO(I,1)=MCT(I,1)
20568 MCO(I,2)=MCT(I,2)
20569 370 CONTINUE
20570
20571C...Iteratively add gluons to already existing string pieces, enforcing
20572C...various possible orderings, and rejecting insertions that would give
20573C...rise to singlet gluons.
20574C...<kappa tau> normalization.
20575 RM0=1.5D0
20576 MRETRY=0
20577 PARP80=PARP(80)
20578
20579C...Set up simplified kinematics.
20580C...Boost hard interaction systems.
20581 IBOOST=IBOOST+1
20582 DO 380 IM=1,MINT(31)
20583 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
20584 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
20585 380 CONTINUE
20586C...Assign preliminary beam remnant momenta.
20587 DO 390 I=MINT(53)+1,N
20588 JS=K(I,3)
20589 P(I,1)=0D0
20590 P(I,2)=0D0
20591 IF (K(I,2).NE.88) THEN
20592 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
20593 P(I,3)=P(I,4)
20594 IF (JS.EQ.2) P(I,3)=-P(I,3)
20595 ELSE
20596C...Junctions are wildcards for the present.
20597 P(I,4)=0D0
20598 P(I,3)=0D0
20599 ENDIF
20600 390 CONTINUE
20601
20602C...Reset colour processing information.
20603 400 DO 410 I=MINT(84)+1,N
20604 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20605 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20606 410 CONTINUE
20607
20608 NCC=0
20609 DO 430 JS=1,2
20610C...If meson, without gluon in BR, collapse q-qbar colour tags:
20611 IF (ITJUNC(JS).EQ.0) THEN
20612 JC1=MCT(JST(JS,1),1)
20613 JC2=MCT(JST(JS,2),2)
20614 NCC=NCC+1
20615 JCCO(NCC,1)=MAX(JC1,JC2)
20616 JCCO(NCC,2)=MIN(JC1,JC2)
20617C...Collapse colour tags in event record
20618 DO 420 I=MINT(84)+1,N
20619 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
20620 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
20621 420 CONTINUE
20622 ENDIF
20623 430 CONTINUE
20624
20625 440 JS=1
20626 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
20627 IF (NG(JS).GT.0) THEN
20628 NOPT=0
20629 RLOPT=1D9
20630C...Start at random gluon (optimizes speed for random attachments)
20631 NMGL=0
20632 IMGL=PYR(0)*NMI(JS)+1
20633 450 IMGL=MOD(IMGL,NMI(JS))+1
20634 NMGL=NMGL+1
20635C...Only loop through NMI once (with upper limit to save time)
20636 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
20637 IGL = IMI(JS,IMGL,1)
20638C...If not gluon or if already connected, try next.
20639 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
20640 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
20641C...Now loop through all possible insertions of this gluon.
20642 NMP1=0
20643 IMP1=PYR(0)*NMI(JS)+1
20644 460 IMP1=MOD(IMP1,NMI(JS))+1
20645 NMP1=NMP1+1
20646 IF (IMP1.EQ.IMGL) GOTO 460
20647C...Only loop through NMI once (with upper limit to save time).
20648 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
20649 IP1 = IMI(JS,IMP1,1)
20650C...Try both colour mother and colour anti-mother.
20651C...Randomly select which one to try first.
20652 NANTI=0
20653 MANTI=PYR(0)*2
20654 470 MANTI=MOD(MANTI+1,2)
20655 NANTI=NANTI+1
20656 IF (NANTI.LE.2) THEN
20657 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
20658C...Reject if no appropriate mother (or if mother is fictitious
20659C...parent gluon.)
20660 IF (IP2.LE.0) GOTO 470
20661 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
20662C...Also reject if this link has already been tried.
20663 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
20664 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
20665C...Set flag to indicate that this link has now been tried for this
20666C...gluon. IP2 may be junction, which has several mothers.
20667 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
20668 IF (K(IP2,2).NE.88) THEN
20669 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
20670 ENDIF
20671
20672C...JCG1: Original colour tag of gluon on IP1 side
20673C...JCG2: Original colour tag of gluon on IP2 side
20674C...JCP1: Original colour tag of IP1 on gluon side
20675C...JCP2: Original colour tag of IP2 on gluon side.
20676 JCG1=MCO(IGL,2-MANTI)
20677 JCG2=MCO(IGL,1+MANTI)
20678 JCP1=MCO(IP1,1+MANTI)
20679 JCP2=MCO(IP2,2-MANTI)
20680
20681 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
20682C...Reject gluon attachments that give rise to singlet gluons.
20683 IF (MACCPT.EQ.0) GOTO 470
20684
20685C...Update colours
20686 JCG1=MCT(IGL,2-MANTI)
20687 JCG2=MCT(IGL,1+MANTI)
20688 JCP1=MCT(IP1,1+MANTI)
20689 JCP2=MCT(IP2,2-MANTI)
20690
20691C...Select whether to accept this insertion
20692 IF (MSTP(89).EQ.0) THEN
20693C...Random insertions: no measure.
20694 RL=1D0
20695C...For random ordering, we want to suppress beam remnant breakups
20696C...already at this point.
20697 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
20698 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
20699 NMP1=0
20700 NMGL=0
20701 GOTO 470
20702 ENDIF
20703 ELSEIF (MSTP(89).EQ.1) THEN
20704C...Rapidity ordering:
20705C...YGL = Rapidity of gluon.
20706 YGL=YMI(IMGL)
20707C...If fictitious gluon
20708 IF (YGL.EQ.100D0) THEN
20709 YGL=(3-2*JS)*100D0
20710 IDA1=MOD(K(IGL,4),MSTU(5))
20711 IDA2=MOD(K(IGL,5),MSTU(5))
20712 DO 480 IMT=1,NMI(JS)
20713C...Select (arbitrarily) the most central daughter.
20714 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
20715 & THEN
20716 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
20717 ENDIF
20718 480 CONTINUE
20719 ENDIF
20720C...YP1 = Rapidity IP1
20721 YP1=YMI(IMP1)
20722C...If fictitious gluon
20723 IF (YP1.EQ.100D0) THEN
20724 YP1=(3-2*JS)*YP1
20725 IDA1=MOD(K(IP1,4),MSTU(5))
20726 IDA2=MOD(K(IP1,5),MSTU(5))
20727 DO 490 IMT=1,NMI(JS)
20728C...Select (arbitrarily) the most central daughter.
20729 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
20730 & THEN
20731 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
20732 ENDIF
20733 490 CONTINUE
20734 ENDIF
20735C...YP2 = Rapidity of mother system
20736 IF (K(IP2,2).NE.88) THEN
20737 DO 500 IMT=1,NMI(JS)
20738 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
20739 500 CONTINUE
20740C...If fictitious gluon
20741 IF (YP2.EQ.100D0) THEN
20742 YP2=(3-2*JS)*YP2
20743 IDA1=MOD(K(IP2,4),MSTU(5))
20744 IDA2=MOD(K(IP2,5),MSTU(5))
20745 DO 510 IMT=1,NMI(JS)
20746C...Select (arbitrarily) the most central daughter.
20747 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
20748 & ) THEN
20749 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
20750 ENDIF
20751 510 CONTINUE
20752 ENDIF
20753C...Assign (arbitrarily) 100D0 to junction also
20754 ELSE
20755 YP2=(3-2*JS)*100D0
20756 ENDIF
20757 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
20758 ELSEIF (MSTP(89).EQ.2) THEN
20759C...Lambda ordering:
20760C...Compute lambda measure for this insertion.
20761 RL=1D0
20762 DO 520 IST=1,6
20763 ISTR(IST)=0
20764 520 CONTINUE
20765C...If IP2 is junction, not caught below.
20766 IF (JCP2.EQ.0) THEN
20767 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
20768C...Anti-junction is colour endpoint et vv., always on JCG2.
20769 ISTR(5-ITJU)=IP2
20770 ENDIF
20771 DO 530 I=MINT(84)+1,N
20772 IF (K(I,1).LT.10) THEN
20773C...The new string pieces
20774 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
20775 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
20776 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
20777 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
20778 ENDIF
20779 530 CONTINUE
20780C...Also identify junctions as string endpoints.
20781 DO 540 I=MINT(84)+1,N
20782 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
20783 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
20784C...Find partons adjacent to junctions.
20785 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
20786 & .EQ.0) ISTR(2) = ICMO
20787 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
20788 & .EQ.0) ISTR(1) = IAMO
20789 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
20790 & .EQ.0) ISTR(4) = ICMO
20791 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
20792 & .EQ.0) ISTR(3) = IAMO
20793 540 CONTINUE
20794C...The old string piece
20795 ISTR(5)=ISTR(1+2*MANTI)
20796 ISTR(6)=ISTR(4-2*MANTI)
20797 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
20798 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
20799 RL=LOG(RL)
20800 ENDIF
20801C...Allow some breadth to speed things up.
20802 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
20803 NOPT=NOPT+1
20804 ELSEIF (RL.GT.RLOPT) THEN
20805 GOTO 470
20806 ELSE
20807 NOPT=1
20808 RLOPT=RL
20809 ENDIF
20810C...INSR(NOPT,1)=Gluon colour mother
20811C...INSR(NOPT,2)=Gluon
20812C...INSR(NOPT,3)=Gluon anticolour mother
20813 IF (NOPT.GT.1000) GOTO 470
20814 INSR(NOPT,1+2*MANTI)=IP2
20815 INSR(NOPT,2)=IGL
20816 INSR(NOPT,3-2*MANTI)=IP1
20817 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
20818 ENDIF
20819 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
20820 ENDIF
20821C...Reset link test information.
20822 DO 550 I=MINT(84)+1,N
20823 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20824 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20825 550 CONTINUE
20826 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
20827 ENDIF
20828C...Now we have a list of best gluon insertions, none of which cause
20829C...singlets to arise. If list is empty, try again a few times. Note:
20830C...this should never happen if we have a meson with a gluon inserted
20831C...in the beam remnant, since that breaks up the colour line.
20832 IF (NOPT.EQ.0) THEN
20833C...Abandon BR-g-BR suppression for retries. This is not serious, it
20834C...just means we happened to start with trying a bad sequence.
20835 PARP80=1D0
20836 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
20837 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
20838 MRETRY=MRETRY+1
20839 DO 590 JS=1,2
20840 IF (ITJUNC(JS).NE.0) THEN
20841 JST(JS,1)=IV(JS,1)
20842 JST(JS,2)=IV(JS,2)
20843 JST(JS,3)=IV(JS,3)
20844C...Reset valence quark parent pointers
20845 DO 560 I=MINT(53)+1,N
20846 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
20847 560 CONTINUE
20848 MANTI=ITJUNC(JS)-1
20849C...Set (anti)colour mother = junction.
20850 DO 570 JV=1,3
20851 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
20852 & +MSTU(5)*IJU
20853 570 CONTINUE
20854 ELSE
20855C...Same for mesons. JST unchanged, so needn't be restored.
20856 IQ=JST(JS,1)
20857 IQBAR=JST(JS,2)
20858 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
20859 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
20860 ENDIF
20861C...Also reset gluon parent pointers.
20862 NG(JS)=0
20863 DO 580 IM=1,NMI(JS)
20864 I=IMI(JS,IM,1)
20865 IF (K(I,2).EQ.21) THEN
20866 K(I,4)=MOD(K(I,4),MSTU(5))
20867 K(I,5)=MOD(K(I,5),MSTU(5))
20868 NG(JS)=NG(JS)+1
20869 ENDIF
20870 580 CONTINUE
20871 590 CONTINUE
20872C...Reset colour tags
20873 DO 600 I=MINT(84)+1,N
20874 MCT(I,1)=MCO(I,1)
20875 MCT(I,2)=MCO(I,2)
20876 600 CONTINUE
20877 GOTO 400
20878 ELSE
20879 IF(NERRPR.LT.5) THEN
20880 NERRPR=NERRPR+1
20881 CALL PYLIST(4)
20882 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
20883 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
20884 ENDIF
20885C...Kill event and start another.
20886 MINT(51)=1
20887 RETURN
20888 ENDIF
20889 ELSE
20890C...Select between insertions, suppressing insertions wholly in the BR.
20891 IIN=PYR(0)*NOPT+1
20892 610 IIN=MOD(IIN,NOPT)+1
20893 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
20894 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
20895 ENDIF
20896
20897C...Now we know which gluon to insert where. Colour tags in JCCO and
20898C...colour connection information should be updated, NG(JS) should be
20899C...counted down, and a new loop performed if there are still gluons
20900C...left on any side.
20901 ICM=INSR(IIN,1)
20902 IACM=INSR(IIN,3)
20903 IGL=INSR(IIN,2)
20904C...JCG : Original gluon colour tag
20905C...JCAG: Original gluon anticolour tag.
20906C...JCM : Original anticolour tag of gluon colour mother
20907C...JACM: Original colour tag of gluon anticolour mother
20908 JCG=MCO(IGL,1)
20909 JCM=MCO(ICM,2)
20910 JACG=MCO(IGL,2)
20911 JACM=MCO(IACM,1)
20912
20913 CALL PYMIHG(JACM,JACG,JCM,JCG)
20914 IF (MACCPT.EQ.0) THEN
20915 IF(NERRPR.LT.5) THEN
20916 NERRPR=NERRPR+1
20917 CALL PYLIST(4)
20918 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
20919 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
20920 ENDIF
20921C...Kill event and start another.
20922 MINT(51)=1
20923 RETURN
20924 ELSE
20925C...If everything went fine, store new JCCN in JCCO.
20926 NCC=NCC+1
20927 DO 620 ICC=1,NCC
20928 JCCO(ICC,1)=JCCN(ICC,1)
20929 JCCO(ICC,2)=JCCN(ICC,2)
20930 620 CONTINUE
20931 ENDIF
20932
20933C...One gluon attached is counted as equivalent to one end outside.
20934 MOUT(JS)=1
20935C...Set IGL colour mother = ICM.
20936 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
20937C...Set ICM anticolour mother = IGL colour.
20938 IF (K(ICM,2).NE.88) THEN
20939 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
20940 ELSE
20941C...If ICM is junction, just update JST array for now.
20942 DO 630 MSJ=1,3
20943 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
20944 630 CONTINUE
20945 ENDIF
20946C...Set IGL anticolour mother = IACM.
20947 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
20948C...Set IACM anticolour mother = IGL anticolour.
20949 IF (K(IACM,2).NE.88) THEN
20950 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
20951 ELSE
20952C...If IACM is junction, just update JST array for now.
20953 DO 640 MSJ=1,3
20954 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
20955 640 CONTINUE
20956 ENDIF
20957C...Count down # unconnected gluons.
20958 NG(JS)=NG(JS)-1
20959 ENDIF
20960 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
20961
20962 DO 840 JS=1,2
20963C...Collapse fictitious gluons.
20964 DO 670 IGL=MINT(53)+1,N
20965 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
20966 & K(IGL,1).EQ.14) THEN
20967 ICM=K(IGL,4)/MSTU(5)
20968 IAM=K(IGL,5)/MSTU(5)
20969 ICD=MOD(K(IGL,4),MSTU(5))
20970 IAD=MOD(K(IGL,5),MSTU(5))
20971C...Set gluon daughters pointing to gluon mothers
20972 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
20973 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
20974C...Set gluon mothers pointing to gluon daughters.
20975 IF (K(ICM,2).NE.88) THEN
20976 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
20977 ELSE
20978C...Special case: mother=junction. Just update JST array for now.
20979 DO 650 MSJ=1,3
20980 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
20981 650 CONTINUE
20982 ENDIF
20983 IF (K(IAM,2).NE.88) THEN
20984 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
20985 ELSE
20986 DO 660 MSJ=1,3
20987 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
20988 660 CONTINUE
20989 ENDIF
20990 ENDIF
20991 670 CONTINUE
20992
20993C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
20994 IM=NMI(JS)+1
20995 680 IM=IM-1
20996 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
20997 IF (IM.GT.MINT(31)) THEN
20998 NMI(JS)=NMI(JS)-1
20999 DO 690 IMR=IM,NMI(JS)
21000 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21001 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21002 690 CONTINUE
21003 GOTO 680
21004 ENDIF
21005
21006C...Finally, connect junction.
21007 IF (ITJUNC(JS).NE.0) THEN
21008 DO 700 I=MINT(53)+1,N
21009 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21010 700 CONTINUE
21011C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21012 NBRJQ =0
21013 NBRVQ =0
21014 DO 720 MSJ=1,3
21015 IDQ(MSJ)=0
21016C...Find jq with no glue inbetween inside beam remnant.
21017 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21018 & THEN
21019 NBRJQ=NBRJQ+1
21020C...Set IDQ = -I if q non-valence and = +I if q valence.
21021 IDQ(NBRJQ)=-JST(JS,MSJ)
21022 DO 710 JV=1,3
21023 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21024 IDQ(NBRJQ)=JST(JS,MSJ)
21025 NBRVQ=NBRVQ+1
21026 ENDIF
21027 710 CONTINUE
21028 ENDIF
21029 I12=MOD(MSJ+1,2)
21030 I45=5
21031 IF (MSJ.EQ.3) I45=4
21032 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21033 720 CONTINUE
21034
21035C...Check if diquark can be formed.
21036 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21037 & .GE.1)) THEN
21038C...If there is less than 2 valence quarks connected to junction
21039C...and MSTP(88)>1, use random non-valence quarks to fill up.
21040 IF (NBRVQ.LE.1) THEN
21041 NDIQ=NBRVQ
21042 730 JFLIP=NBRJQ*PYR(0)+1
21043 IF (IDQ(JFLIP).LT.0) THEN
21044 IDQ(JFLIP)=-IDQ(JFLIP)
21045 NDIQ=NDIQ+1
21046 ENDIF
21047 IF (NDIQ.LE.1) GOTO 730
21048 ENDIF
21049C...Place selected quarks first in IDQ, ordered in flavour.
21050 DO 740 JDQ=1,3
21051 IF (IDQ(JDQ).LE.0) THEN
21052 ITEMP1 = IDQ(JDQ)
21053 IDQ(JDQ)= IDQ(3)
21054 IDQ(3) = -ITEMP1
21055 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21056 ITEMP1 = IDQ(1)
21057 IDQ(1) = IDQ(2)
21058 IDQ(2) = ITEMP1
21059 ENDIF
21060 ENDIF
21061 740 CONTINUE
21062C...Choose diquark spin.
21063 IF (NBRVQ.EQ.2) THEN
21064C...If the selected quarks are both valence, we may use SU(6) rules
21065C...to figure out which spin the diquark has, by a subdivision of the
21066C...original beam hadron into the selected diquark system plus a kicked
21067C...out quark, IKO.
21068 JKO=6
21069 DO 760 JDQ=1,2
21070 DO 750 JV=1,3
21071 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21072 750 CONTINUE
21073 760 CONTINUE
21074 IKO=IV(JS,JKO)
21075 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21076 ELSE
21077C...If one or more of the selected quarks are not valence, we cannot use
21078C...SU(6) subdivisions of the original beam hadron. Instead, with the
21079C...flavours of the diquark already selected, we assume for now
21080C...50:50 spin-1:spin-0 (where spin-0 possible).
21081 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21082 IS=3
21083 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21084 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21085 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21086 ENDIF
21087
21088C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21089C...Note: third quark can per definition not also be valence,
21090C...therefore we can only do this if we are allowed to use sea quarks.
21091 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21092 NTRY=0
21093 780 NTRY=NTRY+1
21094 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21095 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21096 GOTO 780
21097 ELSEIF(NTRY.GT.100) THEN
21098C...If no baryon can be found, give up and form diquark.
21099 IDQ(3)=0
21100 GOTO 770
21101 ELSE
21102C...Replace junction by baryon.
21103 K(IJU,1)=1
21104 K(IJU,2)=KFBAR
21105 K(IJU,3)=MINT(83)+JS
21106 K(IJU,4)=0
21107 K(IJU,5)=0
21108 P(IJU,5)=PYMASS(KFBAR)
21109 DO 790 MSJ=1,3
21110C...Prepare removal of participating quarks from ER.
21111 K(JST(JS,MSJ),1)=-1
21112 790 CONTINUE
21113 ENDIF
21114 ELSE
21115C...If collapse to baryon not possible or not allowed, replace junction
21116C...by diquark. This way, collapsed gluons that were pointing at the
21117C...junction will now point (correctly) at diquark.
21118 MANTI=ITJUNC(JS)-1
21119 K(IJU,1)=3
21120 K(IJU,2)=KFDQ
21121 K(IJU,3)=MINT(83)+JS
21122 K(IJU,4)=0
21123 K(IJU,5)=0
21124 DO 800 MSJ=1,3
21125 IP=JST(JS,MSJ)
21126 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21127 K(IJU,4+MANTI)=0
21128 K(IJU,5-MANTI)=IP*MSTU(5)
21129 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21130 & MSTU(5)*IJU
21131 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21132 ELSE
21133C...Prepare removal of participating quarks from ER.
21134 K(IP,1)=-1
21135 ENDIF
21136 800 CONTINUE
21137 ENDIF
21138
21139C...Update so ER pointers to collapsed quarks
21140C...now go to collapsed object.
21141 DO 820 I=MINT(84)+1,N
21142 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21143 & .K(I,1).GT.0) THEN
21144 DO 810 ISID=4,5
21145 IMO=K(I,ISID)/MSTU(5)
21146 IDA=MOD(K(I,ISID),MSTU(5))
21147 IF (IMO.GT.0) THEN
21148 IF (K(IMO,1).EQ.-1) IMO=IJU
21149 ENDIF
21150 IF (IDA.GT.0) THEN
21151 IF (K(IDA,1).EQ.-1) IDA=IJU
21152 ENDIF
21153 K(I,ISID)=IDA+MSTU(5)*IMO
21154 810 CONTINUE
21155 ENDIF
21156 820 CONTINUE
21157 ENDIF
21158 ENDIF
21159
21160C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21161C...(this only happens for baryons, where we want to force the gluon
21162C...to sit next to the junction. Mesons handled above.)
21163 IF (NBRTOT(JS).EQ.0) THEN
21164 N=N+1
21165 DO 830 IX=1,5
21166 K(N,IX)=0
21167 P(N,IX)=0D0
21168 V(N,IX)=0D0
21169 830 CONTINUE
21170 IGL=N
21171 K(IGL,1)=3
21172 K(IGL,2)=21
21173 K(IGL,3)=MINT(83)+JS
21174 IF (ITJUNC(JS).NE.0) THEN
21175C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21176 JLEG=PYR(0)*NVSUM(JS)+1
21177 I1=JST(JS,JLEG)
21178 JST(JS,JLEG)=IGL
21179 JCT=MCT(I1,ITJUNC(JS))
21180 MCT(IGL,3-ITJUNC(JS))=JCT
21181 NCT=NCT+1
21182 MCT(IGL,ITJUNC(JS))=NCT
21183 MANTI=ITJUNC(JS)-1
21184 ELSE
21185C...Meson. Should not happen.
21186 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21187 IF(NERRPR.LT.5) THEN
21188 WRITE(MSTU(11),*) 'This should not have been possible!'
21189 CALL PYLIST(4)
21190 NERRPR=NERRPR+1
21191 ENDIF
21192 MINT(51)=1
21193 RETURN
21194 ENDIF
21195 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21196 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21197 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21198 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21199 IF (K(I2,2).NE.88) THEN
21200 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21201 ELSE
21202 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21203 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21204 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21205 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21206 ELSE
21207 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21208 ENDIF
21209 ENDIF
21210 ENDIF
21211 840 CONTINUE
21212
21213C...Remove collapsed quarks and junctions from ER and update IMI.
21214 CALL PYEDIT(11)
21215
21216C...Also update beam remnant part of IMI.
21217 NMI(1)=MINT(31)
21218 NMI(2)=MINT(31)
21219 DO 850 I=MINT(53)+1,N
21220 IF (K(I,1).LE.0) GOTO 850
21221C...Restore BR quark/diquark/baryon pointers in IMI.
21222 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21223 JS=K(I,3)-MINT(83)
21224 NMI(JS)=NMI(JS)+1
21225 IMI(JS,NMI(JS),1)=I
21226 IMI(JS,NMI(JS),2)=0
21227 ENDIF
21228 850 CONTINUE
21229
21230C...Restore companion information from collapsed gluons.
21231 DO 870 I=MINT(53)+1,N
21232 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21233 JS=K(I,3)-MINT(83)
21234 JCD=MOD(K(I,4),MSTU(5))
21235 JAD=MOD(K(I,5),MSTU(5))
21236 DO 860 IM=1,NMI(JS)
21237 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21238 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21239 860 CONTINUE
21240 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21241 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21242 ENDIF
21243 870 CONTINUE
21244
21245C...Renumber colour lines (since some have disappeared)
21246 JCT=0
21247 JCD=0
21248 880 JCT=JCT+1
21249 MFOUND=0
21250 I=MINT(84)
21251 890 I=I+1
21252 IF (I.EQ.N+1) THEN
21253 IF (MFOUND.EQ.0) JCD=JCD+1
21254 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21255 MCT(I,1)=JCT-JCD
21256 MFOUND=1
21257 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21258 MCT(I,2)=JCT-JCD
21259 MFOUND=1
21260 ENDIF
21261 IF (I.LE.N) GOTO 890
21262 IF (JCT.LT.NCT) GOTO 880
21263 NCT=JCT-JCD
21264
21265C...Reset hard interaction subsystems to their CM frames.
21266 IF (IBOOST.EQ.1) THEN
21267 DO 900 IM=1,MINT(31)
21268 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21269 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21270 900 CONTINUE
21271C...Zero beam remnant longitudinal momenta and energies
21272 DO 910 I=MINT(53)+1,N
21273 P(I,3)=0D0
21274 P(I,4)=0D0
21275 910 CONTINUE
21276 ELSE
21277 CALL PYERRM(9
21278 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21279C...Kill event and start another.
21280 MINT(51)=1
21281 RETURN
21282 ENDIF
21283
21284 9999 RETURN
21285 END
21286
21287C*********************************************************************
21288
21289C...PYCTTR
21290C...Adapted from PYPREP.
21291C...Assigns LHA1 colour tags to coloured partons based on
21292C...K(I,4) and K(I,5) colour connection record.
21293C...KCS negative signifies that a previous tracing should be continued.
21294C...(in case the tag to be continued is empty, the routine exits)
21295C...Starts at I and ends at I or IEND.
21296C...Special considerations for systems with junctions.
21297
21298 SUBROUTINE PYCTTR(I,KCS,IEND)
21299C...Double precision and integer declarations.
21300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21301 INTEGER PYK,PYCHGE,PYCOMP
21302C...Commonblocks.
21303 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21306 COMMON/PYINT1/MINT(400),VINT(400)
21307C...The common block of colour tags.
21308 COMMON/PYCTAG/NCT,MCT(4000,2)
21309 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21310 DATA NERRPR/0/
21311 SAVE NERRPR
21312
21313C...Skip if KCS not existing for this parton
21314 KQ=KCHG(PYCOMP(K(I,2)),2)
21315 IF (KQ.EQ.0) GOTO 120
21316 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21317 & GOTO 120
21318
21319 IF (KCS.GT.0) THEN
21320 NCT=NCT+1
21321C...Set colour tag of first parton.
21322 MCT(I,KCS-3)=NCT
21323 NCS=NCT
21324 ELSE
21325 KCS=-KCS
21326 NCS=MCT(I,KCS-3)
21327 IF (NCS.EQ.0) GOTO 120
21328 ENDIF
21329
21330 IA=I
21331 NSTP=0
21332 100 NSTP=NSTP+1
21333 IF(NSTP.GT.4*N) THEN
21334 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21335 RETURN
21336 ENDIF
21337
21338C...Finished if reached final-state triplet.
21339 IF(K(IA,1).EQ.3) THEN
21340 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21341 ENDIF
21342
21343C...Also finished if reached junction.
21344 IF(K(IA,1).EQ.42) THEN
21345 GOTO 120
21346 ENDIF
21347
21348C...GOTO next parton in colour space.
21349 110 IB=IA
21350C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21351 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21352 & .NE.0) THEN
21353 IA=MOD(K(IB,KCS),MSTU(5))
21354 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21355 MREV=0
21356 ELSE
21357C...If KCS mother traced or KCS mother nonexistent, switch colour.
21358 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21359 & MSTU(5)).EQ.0) THEN
21360 KCS=9-KCS
21361 NCT=NCT+1
21362 NCS=NCT
21363C...Assign new colour tag on other side of old parton.
21364 MCT(IB,KCS-3)=NCT
21365 ENDIF
21366C...Goto (new) KCS mother, set mother traced tag
21367 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21368 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21369 MREV=1
21370 ENDIF
21371 IF(IA.LE.0.OR.IA.GT.N) THEN
21372 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21373 IF(NERRPR.LT.5) THEN
21374 write(*,*) 'began at ',I
21375 write(*,*) 'ended going from', IB, ' to', IA
21376 CALL PYLIST(4)
21377 NERRPR=NERRPR+1
21378 ENDIF
21379 MINT(51)=1
21380 RETURN
21381 ENDIF
21382 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21383 & MSTU(5)).EQ.IB) THEN
21384 IF(MREV.EQ.1) KCS=9-KCS
21385 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21386C...Set KSC mother traced tag for IA
21387 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21388 ELSE
21389 IF(MREV.EQ.0) KCS=9-KCS
21390 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
21391C...Set KCS daughter traced tag for IA
21392 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
21393 ENDIF
21394C...Assign new colour tag
21395 MCT(IA,KCS-3)=NCS
21396 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
21397
21398 120 RETURN
21399 END
21400
21401*********************************************************************
21402
21403C...PYMIHG
21404C...Collapse JCP1 and connecting tags to JCG1.
21405C...Collapse JCP2 and connecting tags to JCG2.
21406
21407 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
21408C...Double precision and integer declarations.
21409 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21410 IMPLICIT INTEGER(I-N)
21411 INTEGER PYK,PYCHGE,PYCOMP
21412C...The event record
21413 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21414C...Parameters
21415 COMMON/PYINT1/MINT(400),VINT(400)
21416 SAVE /PYJETS/,/PYINT1/
21417C...Local variables
21418 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
21419 COMMON /PYCTAG/NCT,MCT(4000,2)
21420 SAVE /PYCBLS/,/PYCTAG/
21421
21422C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
21423C...in temporary tag collapse array JCCN. Only break up one connection.
21424 MACCPT=1
21425 MCLPS=0
21426 DO 100 ICC=1,NCC
21427 JCCN(ICC,1)=JCCO(ICC,1)
21428 JCCN(ICC,2)=JCCO(ICC,2)
21429C...If there was a mother, it was previously connected to JCP1.
21430C...Should be changed to JCP2.
21431 IF (MCLPS.EQ.0) THEN
21432 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
21433 & ,JCP2)) THEN
21434 JCCN(ICC,1)=MAX(JCG2,JCP2)
21435 JCCN(ICC,2)=MIN(JCG2,JCP2)
21436 MCLPS=1
21437 ENDIF
21438 ENDIF
21439 100 CONTINUE
21440C...Also collapse colours on JCP1 side of JCG1
21441 IF (JCP1.NE.0) THEN
21442 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
21443 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
21444 ELSE
21445 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
21446 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
21447 ENDIF
21448
21449C...Initialize event record colour tag array MCT array to MCO.
21450 DO 110 I=MINT(84)+1,N
21451 MCT(I,1)=MCO(I,1)
21452 MCT(I,2)=MCO(I,2)
21453 110 CONTINUE
21454
21455C...Collapse tags:
21456C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
21457C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
21458C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
21459C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
21460 DO 160 IS=1,4
21461C...Skip if junction.
21462 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
21463C...Define starting point in tag space.
21464C...JCA = previous tag
21465C...JCO = present tag
21466C...JCN = new tag
21467 IF (MOD(IS,2).EQ.1) THEN
21468 JCO=JCP1
21469 JCN=JCG1
21470 JCALL=JCG1
21471 ELSEIF (MOD(IS,2).EQ.0) THEN
21472 JCO=JCP2
21473 JCN=JCG2
21474 JCALL=JCG2
21475 ENDIF
21476 ITRACE=0
21477 120 ITRACE=ITRACE+1
21478 IF (ITRACE.GT.1000) THEN
21479C...NB: Proper error message should be defined here.
21480 CALL PYERRM(14
21481 & ,'(PYMIHG:) Inf loop when collapsing colours.')
21482 MINT(57)=MINT(57)+1
21483 MINT(51)=1
21484 RETURN
21485 ENDIF
21486C...Collapse all JCN tags to JCALL
21487 DO 130 I=MINT(84)+1,N
21488 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
21489 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
21490 130 CONTINUE
21491C...IS = 1,2: first step forward. IS = 3,4: first step backward.
21492 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
21493 JCA=JCN
21494 JCN=JCO
21495 ELSE
21496 JCA=JCO
21497 JCO=JCN
21498 ENDIF
21499C...If possible, step from JCO to new tag JCN not equal to JCA.
21500 DO 140 ICC=1,NCC+1
21501 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
21502 & JCCN(ICC,2)
21503 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
21504 & JCCN(ICC,1)
21505 140 CONTINUE
21506C...Iterate if new colour was arrived at, but don't go in circles.
21507 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
21508C...Change all JCN tags in MCO to JCALL in MCT.
21509 DO 150 I=MINT(84)+1,N
21510 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
21511 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
21512C...If gluon and colour tag = anticolour tag (and not = 0) try again.
21513 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
21514 & .NE.0) MACCPT=0
21515 150 CONTINUE
21516 160 CONTINUE
21517
21518 DO 200 JCL=NCT,1,-1
21519 JCA=0
21520 JCN=JCL
21521 170 JCO=JCN
21522 DO 180 ICC=1,NCC+1
21523 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
21524 & =JCCN(ICC,2)
21525 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
21526 & =JCCN(ICC,1)
21527 180 CONTINUE
21528C...Overpaint all JCN with JCL
21529 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
21530 DO 190 I=MINT(84)+1,N
21531 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
21532 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
21533C...If gluon and colour tag = anticolour tag (and not = 0) try again.
21534 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
21535 & .NE.0) MACCPT=0
21536 190 CONTINUE
21537 JCA=JCO
21538 GOTO 170
21539 ENDIF
21540 200 CONTINUE
21541
21542 RETURN
21543 END
21544
21545C*********************************************************************
21546
21547C...PYMIRM
21548C...Picks primordial kT and shares longitudinal momentum among
21549C...beam remnants.
21550
21551 SUBROUTINE PYMIRM
21552
21553C...Double precision and integer declarations.
21554 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21555 IMPLICIT INTEGER(I-N)
21556 INTEGER PYK,PYCHGE,PYCOMP
21557C...The event record
21558 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21559C...Parameters
21560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21562 COMMON/PYINT1/MINT(400),VINT(400)
21563C...The common block of colour tags.
21564 COMMON/PYCTAG/NCT,MCT(4000,2)
21565C...The common block of dangling ends
21566 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21567 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21568 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21569 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
21570C...Local variables
21571 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
21572C...W(I,J)| J=0 | 1 | 2 |
21573C... I=0 | Wrem**2 | W+ | W- |
21574C... 1 | W1**2 | W1+ | W1- |
21575C... 2 | W2**2 | W2+ | W2- |
21576C...4-product
21577 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)
21578C...Tentative parametrization of <kT> as a function of Q.
21579 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
21580C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
21581C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
21582 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
21583C...Lambda kinematic function.
21584 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
21585
21586C...Beginning and end of beam remnant partons
21587 NOUT=MINT(53)
21588 ISUB=MINT(1)
21589
21590C...Loopback point if kinematic choices gives impossible configuration.
21591 NTRY=0
21592 100 NTRY=NTRY+1
21593
21594C...Assign kT values on each side separately.
21595 DO 180 JS=1,2
21596
21597C...First zero all kT on this side. Skip if no kT to generate.
21598 DO 110 IM=1,NMI(JS)
21599 P(IMI(JS,IM,1),1)=0D0
21600 P(IMI(JS,IM,1),2)=0D0
21601 110 CONTINUE
21602 IF(MSTP(91).LE.0) GOTO 180
21603
21604C...Now assign kT to each (non-collapsed) parton in IMI.
21605 DO 170 IM=1,NMI(JS)
21606 I=IMI(JS,IM,1)
21607C...Select kT according to truncated gaussian or 1/kt6 tails.
21608C...For first interaction, either use rms width = PARP(91) or fitted.
21609 IF (IM.EQ.1) THEN
21610 SIGMA=PARP(91)
21611 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
21612 Q=SQRT(PT2MI(IM))
21613 SIGMA=SIGPT(Q)
21614 ENDIF
21615 ELSE
21616C...For subsequent interactions and BR partons use fragmentation width.
21617 SIGMA=PARJ(21)
21618 ENDIF
21619 PHI=PARU(2)*PYR(0)
21620 PT=0D0
21621 IF(NTRY.LE.100) THEN
21622 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
21623 PT=GETPT(Q,SIGMA)
21624 PTX=PT*COS(PHI)
21625 PTY=PT*SIN(PHI)
21626 ELSEIF (MSTP(91).EQ.2) THEN
21627 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
21628 & 'available, using MSTP(91)=1.')
21629 CALL PYGIVE('MSTP(91)=1')
21630 GOTO 111
21631 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
21632C...Use distribution with kt**6 tails, rms width = PARP(91).
21633 EPS=SQRT(3D0/2D0)*SIGMA
21634C...Generate PTX and PTY separately, each propto 1/KT**6
21635 DO 119 IXY=1,2
21636C...Decide which interval to try
21637 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
21638 IF (PYR(0).LT.P12) THEN
21639C...Use flat approx with accept/reject up to EPS.
21640 PT=PYR(0)*EPS
21641 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
21642 IF (PYR(0).GT.WT) GOTO 112
21643 ELSE
21644C...Above EPS, use 1/kt**6 approx with accept/reject.
21645 PT=EPS/(PYR(0)**(1D0/5D0))
21646 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
21647 IF (PYR(0).GT.WT) GOTO 112
21648 ENDIF
21649 MSIGN=1
21650 IF (PYR(0).GT.0.5D0) MSIGN=-1
21651 IF (IXY.EQ.1) PTX=MSIGN*PT
21652 IF (IXY.EQ.2) PTY=MSIGN*PT
21653 119 CONTINUE
21654 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
21655 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
21656 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
21657 ENDIF
21658C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
21659 PT=SQRT(PTX**2+PTY**2)
21660 WT=1D0
21661 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
21662 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
21663 PTX=PTX*WT
21664 PTY=PTY*WT
21665 PT=SQRT(PTX**2+PTY**2)
21666 ENDIF
21667
21668 P(I,1)=P(I,1)+PTX
21669 P(I,2)=P(I,2)+PTY
21670
21671C...Compensation kicks, with varying degree of local anticorrelations.
21672 MCORR=MSTP(90)
21673 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
21674 PTCX=-PTX/(NMI(JS)-1)
21675 PTCY=-PTY/(NMI(JS)-1)
21676 IF(ISUB.EQ.95) THEN
21677 PTCX=-PTX/(NMI(JS)-2)
21678 PTCY=-PTY/(NMI(JS)-2)
21679 ENDIF
21680 DO 120 IMC=1,NMI(JS)
21681 IF (IMC.EQ.IM) GOTO 120
21682 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
21683 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
21684 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
21685 120 CONTINUE
21686 ELSEIF (MCORR.GE.1) THEN
21687 DO 140 MSID=4,5
21688 NNXT(MSID-3)=0
21689C...Count up # of neighbours on either side
21690 IMO=I
21691 130 IMO=K(IMO,MSID)/MSTU(5)
21692 IF (IMO.EQ.0) GOTO 140
21693 NNXT(MSID-3)=NNXT(MSID-3)+1
21694C...Stop at quarks and junctions
21695 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
21696 140 CONTINUE
21697C...How should compensation be shared when unequal numbers on the
21698C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
21699 NSUM=NNXT(1)+NNXT(2)
21700 T1=0
21701 DO 160 MSID=4,5
21702C...Total momentum to be compensated on this side
21703 IF (NNXT(MSID-3).EQ.0) GOTO 160
21704 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
21705 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
21706C...RS: compensation supression factor as we go out from parton I.
21707C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
21708C...since (for now) MSTP(90) provides enough variability.
21709 RS=0.5D0
21710 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
21711 IMO=I
21712 150 IDA=IMO
21713 IMO=K(IMO,MSID)/MSTU(5)
21714 IF (IMO.EQ.0) GOTO 160
21715 FAC=FAC*RS
21716 IF (K(IMO,2).NE.88) THEN
21717 P(IMO,1)=P(IMO,1)+FAC*PTCX
21718 P(IMO,2)=P(IMO,2)+FAC*PTCY
21719 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
21720C...If we reach junction, divide out the kT that would have been
21721C...assigned to the junction on each of its other legs.
21722 ELSE
21723 L1=MOD(K(IMO,4),MSTU(5))
21724 L2=K(IMO,5)/MSTU(5)
21725 L3=MOD(K(IMO,5),MSTU(5))
21726 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
21727 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
21728 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
21729 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
21730 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
21731 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
21732 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
21733 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
21734 ENDIF
21735
21736 160 CONTINUE
21737 ENDIF
21738 170 CONTINUE
21739C...End assignment of kT values to initiators and remnants.
21740 180 CONTINUE
21741
21742C...Check kinematics constraints for non-BR partons.
21743 DO 190 IM=1,MINT(31)
21744 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
21745 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
21746 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
21747 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
21748 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
21749 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
21750 IF(NTRY.GE.100) THEN
21751C...Kill this event and start another.
21752 CALL PYERRM(11,
21753 & '(PYMIRM:) No consistent (x,kT) sets found')
21754 MINT(51)=1
21755 RETURN
21756 ENDIF
21757 GOTO 100
21758 ENDIF
21759 190 CONTINUE
21760
21761C...Calculate W+ and W- available for combined remnant system.
21762 W(0,1)=VINT(1)
21763 W(0,2)=VINT(1)
21764 DO 200 IM=1,MINT(31)
21765 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
21766 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
21767 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
21768 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
21769 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
21770 200 CONTINUE
21771C...Also store Wrem**2 = W+ * W-
21772 W(0,0)=W(0,1)*W(0,2)
21773
21774 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
21775 IF(NTRY.GE.100) THEN
21776C...Kill this event and start another.
21777 CALL PYERRM(11,
21778 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
21779 MINT(51)=1
21780 RETURN
21781 ENDIF
21782 GOTO 100
21783 ENDIF
21784
21785C...Assign unscaled x values to partons/hadrons in each of the
21786C...beam remnants and calculate unscaled W+ and W- from them.
21787 NTRYX=0
21788 210 NTRYX=NTRYX+1
21789 DO 280 JS=1,2
21790 W(JS,1)=0D0
21791 W(JS,2)=0D0
21792 DO 270 IM=MINT(31)+1,NMI(JS)
21793 I=IMI(JS,IM,1)
21794 KF=K(I,2)
21795 KFA=IABS(KF)
21796 ICOMP=IMI(JS,IM,2)
21797
21798C...Skip collapsed gluons and junctions. Reset.
21799 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
21800 IF (KFA.EQ.88) GOTO 270
21801 X=0D0
21802 IVALQ(1)=0
21803 IVALQ(2)=0
21804 ICOMQ(1)=0
21805 ICOMQ(2)=0
21806
21807C...If gluon then only beam remnant, so takes all.
21808 IF(KFA.EQ.21) THEN
21809 X=1D0
21810C...If valence quark then use parametrized valence distribution.
21811 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
21812 IVALQ(1)=KF
21813C...If companion quark then derive from companion x.
21814 ELSEIF(KFA.LE.6) THEN
21815 ICOMQ(1)=ICOMP
21816C...If valence diquark then use two parametrized valence distributions.
21817 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
21818 & ICOMP.EQ.0) THEN
21819 IVALQ(1)=ISIGN(KFA/1000,KF)
21820 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
21821C...If valence+sea diquark then combine valence + companion choices.
21822 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
21823 & ICOMP.LT.MSTU(5)) THEN
21824 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
21825 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
21826 ELSE
21827 IVALQ(1)=ISIGN(KFA/1000,KF)
21828 ENDIF
21829 ICOMQ(1)=ICOMP
21830C...Extra code: workaround for diquark made out of two sea
21831C...quarks, but where not (yet) ICOMP > MSTU(5).
21832 DO 220 IM1=1,MINT(31)
21833 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
21834 ICOMQ(2)=IMI(JS,IM1,1)
21835 IVALQ(1)=0
21836 ENDIF
21837 220 CONTINUE
21838C...If sea diquark then sum of two derived from companion x.
21839 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
21840 ICOMQ(1)=MOD(ICOMP,MSTU(5))
21841 ICOMQ(2)=ICOMP/MSTU(5)
21842C...If meson or baryon then use fragmentation function.
21843C...Somewhat arbitrary split into old and new flavour, but OK normally.
21844 ELSE
21845 KFL3=MOD(KFA/10,10)
21846 IF(MOD(KFA/1000,10).EQ.0) THEN
21847 KFL1=MOD(KFA/100,10)
21848 ELSE
21849 KFL1=MOD(KFA,10000)-10*KFL3-1
21850 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
21851 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
21852 ENDIF
21853 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
21854 CALL PYZDIS(KFL1,KFL3,PR,X)
21855 ENDIF
21856
21857 DO 260 IQ=1,2
21858C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
21859C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
21860C...In other baryons combine u and d from proton appropriately.
21861 IF(IVALQ(IQ).NE.0) THEN
21862 NVAL=0
21863 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
21864 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
21865 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
21866C...Meson.
21867 IF(KFIVAL(JS,3).EQ.0) THEN
21868 MDU=0
21869C...Baryon with three identical quarks: mix u and d forms.
21870 ELSEIF(NVAL.EQ.3) THEN
21871 MDU=INT(PYR(0)+5D0/3D0)
21872C...Baryon, one of two identical quarks: u form.
21873 ELSEIF(NVAL.EQ.2) THEN
21874 MDU=2
21875C...Baryon with two identical quarks, but not the one picked: d form.
21876 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
21877 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
21878 MDU=1
21879C...Baryon with three nonidentical quarks: mix u and d forms.
21880 ELSE
21881 MDU=INT(PYR(0)+5D0/3D0)
21882 ENDIF
21883 XPOW=0.8D0
21884 IF(MDU.EQ.1) XPOW=3.5D0
21885 IF(MDU.EQ.2) XPOW=2D0
21886 230 XX=PYR(0)**2
21887 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
21888 X=X+XX
21889 ENDIF
21890
21891C...Calculation of x of companion quark.
21892 IF(ICOMQ(IQ).NE.0) THEN
21893 XCOMP=1D-4
21894 DO 240 IM1=1,MINT(31)
21895 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
21896 240 CONTINUE
21897 NPOW=MAX(0,MIN(4,MSTP(87)))
21898 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
21899 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
21900 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
21901 IF(CORR.LT.PYR(0)) GOTO 250
21902 X=X+XX
21903 ENDIF
21904 260 CONTINUE
21905
21906C...Optionally enchance x of composite systems (e.g. diquarks)
21907 IF (KFA.GT.100) X=PARP(79)*X
21908
21909C...Store x. Also calculate light cone energies of each system.
21910 XMI(JS,IM)=X
21911 W(JS,JS)=W(JS,JS)+X
21912 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
21913 270 CONTINUE
21914 W(JS,JS)=W(JS,JS)*W(0,JS)
21915 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
21916 W(JS,0)=W(JS,1)*W(JS,2)
21917 280 CONTINUE
21918
21919C...Check W1 W2 < Wrem (can be done before rescaling, since W
21920C...insensitive to global rescalings of the BR x values).
21921 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
21922 & THEN
21923 GOTO 210
21924 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
21925 GOTO 100
21926 ELSEIF (NTRYX.GT.100) THEN
21927 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
21928 MINT(57)=MINT(57)+1
21929 MINT(51)=1
21930 RETURN
21931 ENDIF
21932
21933C...Compute x rescaling factors
21934 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
21935 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
21936 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
21937
21938 IF (R1.LT.0.OR.R2.LT.0) THEN
21939 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
21940 MINT(57)=MINT(57)+1
21941 MINT(51)=1
21942 ENDIF
21943
21944C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
21945 W(1,1)=W(1,1)*R1
21946 W(1,2)=W(1,2)/R1
21947 W(2,1)=W(2,1)/R2
21948 W(2,2)=W(2,2)*R2
21949
21950C...Rescale BR x values.
21951 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
21952 XMI(1,IM)=XMI(1,IM)*R1
21953 XMI(2,IM)=XMI(2,IM)*R2
21954 290 CONTINUE
21955
21956C...Now we have a consistent set of x and kT values.
21957C...First set up the initiators and their daughters correctly.
21958 DO 300 IM=1,MINT(31)
21959 I1=IMI(1,IM,1)
21960 I2=IMI(2,IM,1)
21961 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
21962 & (P(I1,2)+P(I2,2))**2
21963 PT12=P(I1,1)**2+P(I1,2)**2
21964 PT22=P(I2,1)**2+P(I2,2)**2
21965C...p_z
21966 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
21967 P(I2,3)=-P(I1,3)
21968C...Energies (masses should be zero at this stage)
21969 P(I1,4)=SQRT(PT12+P(I1,3)**2)
21970 P(I2,4)=SQRT(PT22+P(I2,3)**2)
21971
21972C...Transverse 12 system initiator velocity:
21973 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
21974 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
21975C...Boost to overall initiator system rest frame
21976 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
21977 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
21978C...Compute phi,theta coordinates of I1 and rotate z axis.
21979 PHI=PYANGL(P(I1,1),P(I1,2))
21980 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
21981 CALL PYROBO(I1,I1,0D0,-PHI,0D0,0D0,0D0)
21982 CALL PYROBO(I2,I2,0D0,-PHI,0D0,0D0,0D0)
21983 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
21984 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
21985
21986C...Now boost initiators + daughters back to LAB system
21987C...(also update documentation lines for MI = 1.)
21988 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21989 IMIN=IMISEP(IM-1)+1
21990 IF (IM.EQ.1) IMIN=MINT(83)+5
21991 IMAX=IMISEP(IM)
21992 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
21993 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
21994
21995 300 CONTINUE
21996
21997
21998C...For the beam remnant partons/hadrons, we only need to set pz and E.
21999 DO 320 JS=1,2
22000 DO 310 IM=MINT(31)+1,NMI(JS)
22001 I=IMI(JS,IM,1)
22002C...Skip collapsed gluons and junctions.
22003 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22004 IF (KFA.EQ.88) GOTO 310
22005 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22006 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22007 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22008 IF (JS.EQ.2) P(I,3)=-P(I,3)
22009 310 CONTINUE
22010 320 CONTINUE
22011
22012
22013C...Documentation lines
22014 DO 340 JS=1,2
22015 IN=MINT(83)+JS+2
22016 IO=IMI(JS,1,1)
22017 K(IN,1)=21
22018 K(IN,2)=K(IO,2)
22019 K(IN,3)=MINT(83)+JS
22020 K(IN,4)=0
22021 K(IN,5)=0
22022 DO 330 J=1,5
22023 P(IN,J)=P(IO,J)
22024 V(IN,J)=V(IO,J)
22025 330 CONTINUE
22026 MCT(IN,1)=MCT(IO,1)
22027 MCT(IN,2)=MCT(IO,2)
22028 340 CONTINUE
22029
22030C...Final state colour reconnections.
22031 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22032
22033C...Number of colour tags for which a recoupling will be tried.
22034 NTOT=NCT
22035C...Number of recouplings to try
22036 MINT(34)=0
22037 NRECP=0
22038 NITER=0
22039 350 NRECP=MINT(34)
22040 NITER=NITER+1
22041 IITER=0
22042 360 IITER=IITER+1
22043 IF (IITER.LE.PARP(78)*NTOT) THEN
22044C...Select two colour tags at random
22045C...NB: jj strings do not have colour tags assigned to them,
22046C...thus they are as yet not affected by anything done here.
22047 JCT=PYR(0)*NCT+1
22048 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22049 IJ1=0
22050 IJ2=0
22051 IK1=0
22052 IK2=0
22053C...Find final state partons with this (anti)colour
22054 DO 370 I=MINT(84)+1,N
22055 IF (K(I,1).EQ.3) THEN
22056 IF (MCT(I,1).EQ.JCT) IJ1=I
22057 IF (MCT(I,2).EQ.JCT) IJ2=I
22058 IF (MCT(I,1).EQ.KCT) IK1=I
22059 IF (MCT(I,2).EQ.KCT) IK2=I
22060 ENDIF
22061 370 CONTINUE
22062C...Only consider recouplings not involving junctions for now.
22063 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22064
22065 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22066 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22067 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22068 MCT(IJ2,2)=KCT
22069 MCT(IK2,2)=JCT
22070C...Count up number of reconnections
22071 MINT(34)=MINT(34)+1
22072 ENDIF
22073 IF (MINT(34).LE.1000) THEN
22074 GOTO 360
22075 ELSE
22076 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22077 GOTO 380
22078 ENDIF
22079 ENDIF
22080 IF (NRECP.LT.MINT(34)) GOTO 350
22081
22082C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22083 380 MINT(33)=1
22084
22085 RETURN
22086 END
22087
22088C*********************************************************************
22089
22090C...PYFSCR
22091C...Performs colour annealing.
22092C...MSTP(95) : CR Type
22093C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22094C... = 2 : Type I(no gg loops); hadron-hadron only
22095C... = 3 : Type I(no gg loops); all beams
22096C... = 4 : Type II(gg loops) ; hadron-hadron only
22097C... = 5 : Type II(gg loops) ; all beams
22098C... = 6 : Type S ; hadron-hadron only
22099C... = 7 : Type S ; all beams
22100C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22101C...Type S is driven by starting only from free triplets, not octets.
22102C...A string piece remains unchanged with probability
22103C... PKEEP = (1-PARP(78))**N
22104C...This scaling corresponds to each string piece having to go through
22105C...N other ones, each with probability PARP(78) for reconnection, where
22106C...N is here chosen simply as the number of multiple interactions,
22107C...for a rough scaling with the general level of activity.
22108
22109 SUBROUTINE PYFSCR(IP)
22110C...Double precision and integer declarations.
22111 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22112 INTEGER PYK,PYCHGE,PYCOMP
22113C...Commonblocks.
22114 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22115 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22116 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22118 COMMON/PYINT1/MINT(400),VINT(400)
22119C...The common block of colour tags.
22120 COMMON/PYCTAG/NCT,MCT(4000,2)
22121 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22122 &/PYPARS/
22123C...MCN: Temporary storage of new colour tags
22124 DOUBLE PRECISION MCN(4000,2)
22125
22126C...Function to give four-product.
22127 FOUR(I,J)=P(I,4)*P(J,4)
22128 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22129
22130C...Check valid range of MSTP(95), local copy
22131 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22132 MSTP95=MOD(MSTP(95),10)
22133C...Set whether CR allowed inside resonance systems or not
22134C...(not implemented yet)
22135C MRESCR=1
22136C IF (MSTP(95).GE.10) MRESCR=0
22137
22138C...Check whether colour tags already defined
22139 IF (MINT(33).EQ.0) THEN
22140C...Erase any existing colour tags for this event
22141 DO 100 I=1,N
22142 MCT(I,1)=0
22143 MCT(I,2)=0
22144 100 CONTINUE
22145C...Create colour tags for this event
22146 DO 120 I=1,N
22147 IF (K(I,1).EQ.3) THEN
22148 DO 110 KCS=4,5
22149 KCSIN=KCS
22150 IF (MCT(I,KCSIN-3).EQ.0) THEN
22151 CALL PYCTTR(I,KCSIN,I)
22152 ENDIF
22153 110 CONTINUE
22154 ENDIF
22155 120 CONTINUE
22156C...Instruct PYPREP to use colour tags
22157 MINT(33)=1
22158 ENDIF
22159
22160C...For MSTP(95) even, only apply to hadron-hadron
22161 IF (MOD(MSTP(95),2).EQ.0) THEN
22162 KA1=IABS(MINT(11))
22163 KA2=IABS(MINT(12))
22164 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22165 ENDIF
22166
22167C...Initialize new tag array (but do not delete old yet)
22168 LCT=NCT
22169 DO 130 I=MAX(1,IP),N
22170 MCN(I,1)=0
22171 MCN(I,2)=0
22172 130 CONTINUE
22173
22174C...For each final-state dipole, check whether string should be
22175C...preserved.
22176 DO 150 ICT=1,NCT
22177 IC=0
22178 IA=0
22179 DO 140 I=MAX(1,IP),N
22180 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22181 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22182 140 CONTINUE
22183 IF (IC.NE.0.AND.IA.NE.0) THEN
22184C...Chiefly consider large strings.
22185 PKEEP=(1D0-PARP(78))**MINT(31)
22186 IF (PYR(0).LE.PKEEP) THEN
22187 LCT=LCT+1
22188 MCN(IC,1)=LCT
22189 MCN(IA,2)=LCT
22190 ENDIF
22191 ENDIF
22192 150 CONTINUE
22193
22194C...Loop over event record, starting from IP
22195C...(Ignore junctions for now.)
22196 NLOOP=0
22197 160 NLOOP=NLOOP+1
22198 MCIMAX=0
22199 MCJMAX=0
22200 RLMAX=0D0
22201 ILMAX=0
22202 JLMAX=0
22203 DO 230 I=MAX(1,IP),N
22204 IF (K(I,1).NE.3) GOTO 230
22205C...Check colour charge
22206 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22207 IF (MCI.EQ.0) GOTO 230
22208C...For Seattle algorithm, only start from partons with one dangling
22209C...colour tag
22210 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22211 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22212 ENDIF
22213C... Find optimal partner
22214 JLOPT=0
22215 MCJOPT=0
22216 MBROPT=0
22217 MGGOPT=0
22218 RLOPT=1D19
22219C...Loop over I colour/anticolour, check whether already connected
22220 170 DO 220 ICL=1,2
22221 IF (MCN(I,ICL).NE.0) GOTO 220
22222 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22223 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22224C...Check whether this is a dangling colour tag (ie to junction!)
22225 IFOUND=0
22226 DO 180 J=MAX(1,IP),N
22227 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22228 180 CONTINUE
22229 IF (IFOUND.EQ.0) GOTO 220
22230 DO 210 J=MAX(1,IP),N
22231 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22232C...Do not make direct connections between partons in same Beam Remnant
22233 MBRSTR=0
22234 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22235 & MBRSTR=1
22236C...Check colour charge
22237 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22238 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22239C...Check for gluon loops
22240 MGGSTR=0
22241 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22242 ICLA=3-ICL
22243 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22244 & MCN(I,ICLA).NE.0) MGGSTR=1
22245 ENDIF
22246C...Loop over J colour/anticolour, check whether already connected
22247 DO 200 JCL=1,2
22248 IF (MCN(J,JCL).NE.0) GOTO 200
22249 IF (JCL.EQ.ICL) GOTO 200
22250 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22251 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22252C...Check whether this is a dangling colour tag (ie to junction!)
22253 IFOUND=0
22254 DO 190 J2=MAX(1,IP),N
22255 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22256 & IFOUND=1
22257 190 CONTINUE
22258 IF (IFOUND.EQ.0) GOTO 200
22259C...Save connection with smallest lambda measure
22260C...If best so far was a BR string and this is not, also save.
22261C...If best so far was a gg string and this is not, also save.
22262 RL=FOUR(I,J)
22263 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22264 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22265 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22266 RLOPT=RL
22267 JLOPT=J
22268 ICOPT=ICL
22269 JCOPT=JCL
22270 MCJOPT=MCJ
22271 MBROPT=MBRSTR
22272 MGGOPT=MGGSTR
22273 ENDIF
22274 200 CONTINUE
22275 210 CONTINUE
22276 220 CONTINUE
22277 IF (JLOPT.NE.0) THEN
22278C...Save pair with largest RLOPT so far
22279 IF (RLOPT.GE.RLMAX) THEN
22280 RLMAX=RLOPT
22281 ILMAX=I
22282 JLMAX=JLOPT
22283 ICMAX=ICOPT
22284 JCMAX=JCOPT
22285 MCJMAX=MCJOPT
22286 MCIMAX=MCI
22287 ENDIF
22288 ENDIF
22289 230 CONTINUE
22290C...Save and iterate
22291 IF (ILMAX.GT.0) THEN
22292 LCT=LCT+1
22293 MCN(ILMAX,ICMAX)=LCT
22294 MCN(JLMAX,JCMAX)=LCT
22295 IF (NLOOP.LE.2*(N-IP)) THEN
22296 GOTO 160
22297 ELSE
22298 PRINT*, 'infinite loop!'
22299 STOP
22300 ENDIF
22301 ELSE
22302C...Save and exit. First check for leftover gluon(s)
22303 DO 260 I=MAX(1,IP),N
22304C...Check colour charge
22305 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22306 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22307 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22308C...Decide where to put left-over gluon (minimal insertion)
22309 ILMAX=0
22310 RLMAX=1D19
22311 DO 250 KCT=NCT+1,LCT
22312 DO 240 IT=MAX(1,IP),N
22313 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22314 IF (MCN(IT,1).EQ.KCT) IC=IT
22315 IF (MCN(IT,2).EQ.KCT) IA=IT
22316 240 CONTINUE
22317 RL=FOUR(IC,I)*FOUR(IA,I)
22318 IF (RL.LT.RLMAX) THEN
22319 RLMAX=RL
22320 ICMAX=IC
22321 IAMAX=IA
22322 ENDIF
22323 250 CONTINUE
22324 LCT=LCT+1
22325 MCN(I,1)=MCN(ICMAX,1)
22326 MCN(I,2)=LCT
22327 MCN(ICMAX,1)=LCT
22328 ENDIF
22329 260 CONTINUE
22330 DO 270 I=MAX(1,IP),N
22331C...Do not erase parton shower colour history
22332 IF (K(I,1).NE.3) GOTO 270
22333C...Check colour charge
22334 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22335 IF (MCI.EQ.0) GOTO 270
22336 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22337 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22338 270 CONTINUE
22339 ENDIF
22340
22341 9999 RETURN
22342 END
22343
22344C*********************************************************************
22345
22346C...PYDIFF
22347C...Handles diffractive and elastic scattering.
22348
22349 SUBROUTINE PYDIFF
22350
22351C...Double precision and integer declarations.
22352 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22353 IMPLICIT INTEGER(I-N)
22354 INTEGER PYK,PYCHGE,PYCOMP
22355C...Commonblocks.
22356 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22357 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22358 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22359 COMMON/PYINT1/MINT(400),VINT(400)
22360 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22361
22362C...Reset K, P and V vectors. Store incoming particles.
22363 DO 110 JT=1,MSTP(126)+10
22364 I=MINT(83)+JT
22365 DO 100 J=1,5
22366 K(I,J)=0
22367 P(I,J)=0D0
22368 V(I,J)=0D0
22369 100 CONTINUE
22370 110 CONTINUE
22371 N=MINT(84)
22372 MINT(3)=0
22373 MINT(21)=0
22374 MINT(22)=0
22375 MINT(23)=0
22376 MINT(24)=0
22377 MINT(4)=4
22378 DO 130 JT=1,2
22379 I=MINT(83)+JT
22380 K(I,1)=21
22381 K(I,2)=MINT(10+JT)
22382 DO 120 J=1,5
22383 P(I,J)=VINT(285+5*JT+J)
22384 120 CONTINUE
22385 130 CONTINUE
22386 MINT(6)=2
22387
22388C...Subprocess; kinematics.
22389 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
22390 PZ=SQRT(SQLAM)/(2D0*VINT(1))
22391 DO 200 JT=1,2
22392 I=MINT(83)+JT
22393 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
22394 KFH=MINT(102+JT)
22395
22396C...Elastically scattered particle. (Except elastic GVMD states.)
22397 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
22398 & MINT(106+JT).NE.3)) THEN
22399 N=N+1
22400 K(N,1)=1
22401 K(N,2)=KFH
22402 K(N,3)=I+2
22403 P(N,3)=PZ*(-1)**(JT+1)
22404 P(N,4)=PE
22405 P(N,5)=SQRT(VINT(62+JT))
22406
22407C...Decay rho from elastic scattering of gamma with sin**2(theta)
22408C...distribution of decay products (in rho rest frame).
22409 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
22410 NSAV=N
22411 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
22412 P(N,3)=0D0
22413 P(N,4)=P(N,5)
22414 CALL PYDECY(NSAV)
22415 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
22416 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
22417 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
22418 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
22419 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
22420 140 CTHE=2D0*PYR(0)-1D0
22421 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
22422 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
22423 ENDIF
22424 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
22425 ENDIF
22426
22427C...Diffracted particle: low-mass system to two particles.
22428 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
22429 N=N+2
22430 K(N-1,1)=1
22431 K(N,1)=1
22432 K(N-1,3)=I+2
22433 K(N,3)=I+2
22434 PMMAS=SQRT(VINT(62+JT))
22435 NTRY=0
22436 150 NTRY=NTRY+1
22437 IF(NTRY.LT.20) THEN
22438 MINT(105)=MINT(102+JT)
22439 MINT(109)=MINT(106+JT)
22440 CALL PYSPLI(KFH,21,KFL1,KFL2)
22441 CALL PYKFDI(KFL1,0,KFL3,KF1)
22442 IF(KF1.EQ.0) GOTO 150
22443 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
22444 IF(KF2.EQ.0) GOTO 150
22445 ELSE
22446 KF1=KFH
22447 KF2=111
22448 ENDIF
22449 PM1=PYMASS(KF1)
22450 PM2=PYMASS(KF2)
22451 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
22452 K(N-1,2)=KF1
22453 K(N,2)=KF2
22454 P(N-1,5)=PM1
22455 P(N,5)=PM2
22456 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
22457 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
22458 P(N-1,3)=PZP
22459 P(N,3)=-PZP
22460 P(N-1,4)=SQRT(PM1**2+PZP**2)
22461 P(N,4)=SQRT(PM2**2+PZP**2)
22462 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
22463 & 0D0,0D0,0D0)
22464 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
22465 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
22466
22467C...Diffracted particle: valence quark kicked out.
22468 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
22469 & PARP(101))) THEN
22470 N=N+2
22471 K(N-1,1)=2
22472 K(N,1)=1
22473 K(N-1,3)=I+2
22474 K(N,3)=I+2
22475 MINT(105)=MINT(102+JT)
22476 MINT(109)=MINT(106+JT)
22477 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
22478 P(N-1,5)=PYMASS(K(N-1,2))
22479 P(N,5)=PYMASS(K(N,2))
22480 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
22481 & 4D0*P(N-1,5)**2*P(N,5)**2
22482 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
22483 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
22484 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
22485 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
22486 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
22487
22488C...Diffracted particle: gluon kicked out.
22489 ELSE
22490 N=N+3
22491 K(N-2,1)=2
22492 K(N-1,1)=2
22493 K(N,1)=1
22494 K(N-2,3)=I+2
22495 K(N-1,3)=I+2
22496 K(N,3)=I+2
22497 MINT(105)=MINT(102+JT)
22498 MINT(109)=MINT(106+JT)
22499 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
22500 K(N-1,2)=21
22501 P(N-2,5)=PYMASS(K(N-2,2))
22502 P(N-1,5)=0D0
22503 P(N,5)=PYMASS(K(N,2))
22504C...Energy distribution for particle into two jets.
22505 160 IMB=1
22506 IF(MOD(KFH/1000,10).NE.0) IMB=2
22507 CHIK=PARP(92+2*IMB)
22508 IF(MSTP(92).LE.1) THEN
22509 IF(IMB.EQ.1) CHI=PYR(0)
22510 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
22511 ELSEIF(MSTP(92).EQ.2) THEN
22512 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
22513 ELSEIF(MSTP(92).EQ.3) THEN
22514 CUT=2D0*0.3D0/VINT(1)
22515 170 CHI=PYR(0)**2
22516 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
22517 & PYR(0)) GOTO 170
22518 ELSEIF(MSTP(92).EQ.4) THEN
22519 CUT=2D0*0.3D0/VINT(1)
22520 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
22521 180 CHIR=CUT*CUTR**PYR(0)
22522 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
22523 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
22524 ELSE
22525 CUT=2D0*0.3D0/VINT(1)
22526 CUTA=CUT**(1D0-PARP(98))
22527 CUTB=(1D0+CUT)**(1D0-PARP(98))
22528 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
22529 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
22530 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
22531 ENDIF
22532 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
22533 & VINT(62+JT)) GOTO 160
22534 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
22535 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
22536 & (2D0*VINT(62+JT))
22537 PEI=SQRT(PZI**2+SQM)
22538 PQQP=(1D0-CHI)*(PEI+PZI)
22539 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
22540 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
22541 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
22542 P(N-1,3)=P(N-1,4)*(-1)**JT
22543 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
22544 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
22545 ENDIF
22546
22547C...Documentation lines.
22548 K(I+2,1)=21
22549 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
22550 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
22551 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
22552 K(I+2,3)=I
22553 P(I+2,3)=PZ*(-1)**(JT+1)
22554 P(I+2,4)=PE
22555 P(I+2,5)=SQRT(VINT(62+JT))
22556 200 CONTINUE
22557
22558C...Rotate outgoing partons/particles using cos(theta).
22559 IF(VINT(23).LT.0.9D0) THEN
22560 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
22561 ELSE
22562 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
22563 ENDIF
22564
22565 RETURN
22566 END
22567
22568C*********************************************************************
22569
22570C...PYDISG
22571C...Set up a DIS process as gamma* + f -> f, with beam remnant
22572C...and showering added consecutively. Photon flux by the PYGAGA
22573C...routine (if at all).
22574
22575 SUBROUTINE PYDISG
22576
22577C...Double precision and integer declarations.
22578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22579 IMPLICIT INTEGER(I-N)
22580 INTEGER PYK,PYCHGE,PYCOMP
22581C...Parameter statement to help give large particle numbers.
22582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
22583 &KEXCIT=4000000,KDIMEN=5000000)
22584C...Commonblocks.
22585 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22586 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22587 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22588 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22590 COMMON/PYINT1/MINT(400),VINT(400)
22591 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
22592C...Local arrays.
22593 DIMENSION PMS(4)
22594
22595C...Choice of subprocess, number of documentation lines
22596 IDOC=7
22597 MINT(3)=IDOC-6
22598 MINT(4)=IDOC
22599 IPU1=MINT(84)+1
22600 IPU2=MINT(84)+2
22601 IPU3=MINT(84)+3
22602 ISIDE=1
22603 IF(MINT(107).EQ.4) ISIDE=2
22604
22605C...Reset K, P and V vectors. Store incoming particles
22606 DO 110 JT=1,MSTP(126)+20
22607 I=MINT(83)+JT
22608 DO 100 J=1,5
22609 K(I,J)=0
22610 P(I,J)=0D0
22611 V(I,J)=0D0
22612 100 CONTINUE
22613 110 CONTINUE
22614 DO 130 JT=1,2
22615 I=MINT(83)+JT
22616 K(I,1)=21
22617 K(I,2)=MINT(10+JT)
22618 DO 120 J=1,5
22619 P(I,J)=VINT(285+5*JT+J)
22620 120 CONTINUE
22621 130 CONTINUE
22622 MINT(6)=2
22623
22624C...Store incoming partons in hadronic CM-frame
22625 DO 140 JT=1,2
22626 I=MINT(84)+JT
22627 K(I,1)=14
22628 K(I,2)=MINT(14+JT)
22629 K(I,3)=MINT(83)+2+JT
22630 140 CONTINUE
22631 IF(MINT(15).EQ.22) THEN
22632 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
22633 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
22634 P(MINT(84)+1,5)=-SQRT(VINT(307))
22635 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
22636 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
22637 KFRES=MINT(16)
22638 ISIDE=2
22639 ELSE
22640 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
22641 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
22642 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
22643 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
22644 P(MINT(84)+1,5)=-SQRT(VINT(308))
22645 KFRES=MINT(15)
22646 ISIDE=1
22647 ENDIF
22648 SIDESG=(-1D0)**(ISIDE-1)
22649
22650C...Copy incoming partons to documentation lines.
22651 DO 170 JT=1,2
22652 I1=MINT(83)+4+JT
22653 I2=MINT(84)+JT
22654 K(I1,1)=21
22655 K(I1,2)=K(I2,2)
22656 K(I1,3)=I1-2
22657 DO 150 J=1,5
22658 P(I1,J)=P(I2,J)
22659 150 CONTINUE
22660
22661C...Second copy for partons before ISR shower, since no such.
22662 I1=MINT(83)+2+JT
22663 K(I1,1)=21
22664 K(I1,2)=K(I2,2)
22665 K(I1,3)=I1-2
22666 DO 160 J=1,5
22667 P(I1,J)=P(I2,J)
22668 160 CONTINUE
22669 170 CONTINUE
22670
22671C...Define initial partons.
22672 NTRY=0
22673 180 NTRY=NTRY+1
22674 IF(NTRY.GT.100) THEN
22675 MINT(51)=1
22676 RETURN
22677 ENDIF
22678
22679C...Scattered quark in hadronic CM frame.
22680 I=MINT(83)+7
22681 K(IPU3,1)=3
22682 K(IPU3,2)=KFRES
22683 K(IPU3,3)=I
22684 P(IPU3,5)=PYMASS(KFRES)
22685 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
22686 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
22687 P(IPU3,5)=0D0
22688 K(I,1)=21
22689 K(I,2)=KFRES
22690 K(I,3)=MINT(83)+4+ISIDE
22691 P(I,3)=P(IPU3,3)
22692 P(I,4)=P(IPU3,4)
22693 P(I,5)=P(IPU3,5)
22694 N=IPU3
22695 MINT(21)=KFRES
22696 MINT(22)=0
22697
22698C...No primordial kT, or chosen according to truncated Gaussian or
22699C...exponential, or (for photon) predetermined or power law.
22700 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
22701 IF(MSTP(91).LE.0) THEN
22702 PT=0D0
22703 ELSEIF(MSTP(91).EQ.1) THEN
22704 PT=PARP(91)*SQRT(-LOG(PYR(0)))
22705 ELSE
22706 RPT1=PYR(0)
22707 RPT2=PYR(0)
22708 PT=-PARP(92)*LOG(RPT1*RPT2)
22709 ENDIF
22710 IF(PT.GT.PARP(93)) GOTO 190
22711 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
22712 PTA=SQRT(VINT(282+ISIDE))
22713 PTB=0D0
22714 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
22715 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
22716 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
22717 RPT1=PYR(0)
22718 RPT2=PYR(0)
22719 PTB=-PARP(99)*LOG(RPT1*RPT2)
22720 ENDIF
22721 IF(PTB.GT.PARP(100)) GOTO 190
22722 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
22723 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
22724 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
22725 IF(MSTP(93).LE.0) THEN
22726 PT=0D0
22727 ELSEIF(MSTP(93).EQ.1) THEN
22728 PT=PARP(99)*SQRT(-LOG(PYR(0)))
22729 ELSEIF(MSTP(93).EQ.2) THEN
22730 RPT1=PYR(0)
22731 RPT2=PYR(0)
22732 PT=-PARP(99)*LOG(RPT1*RPT2)
22733 ELSEIF(MSTP(93).EQ.3) THEN
22734 HA=PARP(99)**2
22735 HB=PARP(100)**2
22736 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
22737 ELSE
22738 HA=PARP(99)**2
22739 HB=PARP(100)**2
22740 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
22741 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
22742 ENDIF
22743 IF(PT.GT.PARP(100)) GOTO 190
22744 ELSE
22745 PT=0D0
22746 ENDIF
22747 VINT(156+ISIDE)=PT
22748 PHI=PARU(2)*PYR(0)
22749 P(IPU3,1)=PT*COS(PHI)
22750 P(IPU3,2)=PT*SIN(PHI)
22751 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
22752 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
22753 PCP=P(IPU3,4)+ABS(P(IPU3,3))
22754
22755C...Find one or two beam remnants.
22756 MINT(105)=MINT(102+ISIDE)
22757 MINT(109)=MINT(106+ISIDE)
22758 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
22759 IF(MINT(51).NE.0) THEN
22760 MINT(51)=0
22761 GOTO 180
22762 ENDIF
22763
22764C...Store first remnant parton, with colour info and kinematics.
22765 I=N+1
22766 K(I,1)=1
22767 K(I,2)=KFLSP
22768 K(I,3)=MINT(83)+ISIDE
22769 P(I,5)=PYMASS(K(I,2))
22770 KCOL=KCHG(PYCOMP(KFLSP),2)
22771 IF(KCOL.NE.0) THEN
22772 K(I,1)=3
22773 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
22774 K(I,KFLS+3)=MSTU(5)*IPU3
22775 K(IPU3,6-KFLS)=MSTU(5)*I
22776 ICOLR=I
22777 ENDIF
22778 IF(KFLCH.EQ.0) THEN
22779 P(I,1)=-P(IPU3,1)
22780 P(I,2)=-P(IPU3,2)
22781 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
22782 P(I,3)=-P(IPU3,3)
22783 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
22784 PRP=P(I,4)+ABS(P(I,3))
22785
22786C...When extra remnant parton or hadron: store extra remnant.
22787 ELSE
22788 I=I+1
22789 K(I,1)=1
22790 K(I,2)=KFLCH
22791 K(I,3)=MINT(83)+ISIDE
22792 P(I,5)=PYMASS(K(I,2))
22793 KCOL=KCHG(PYCOMP(KFLCH),2)
22794 IF(KCOL.NE.0) THEN
22795 K(I,1)=3
22796 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
22797 K(I,KFLS+3)=MSTU(5)*IPU3
22798 K(IPU3,6-KFLS)=MSTU(5)*I
22799 ICOLR=I
22800 ENDIF
22801
22802C...Relative transverse momentum when two remnants.
22803 LOOP=0
22804 200 LOOP=LOOP+1
22805 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
22806 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
22807 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
22808 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
22809 P(I,1)=-P(IPU3,1)-P(I-1,1)
22810 P(I,2)=-P(IPU3,2)-P(I-1,2)
22811 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
22812
22813C...Relative distribution of energy for particle into jet plus particle.
22814 IMB=1
22815 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
22816 IF(MSTP(94).LE.1) THEN
22817 IF(IMB.EQ.1) CHI=PYR(0)
22818 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
22819 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
22820 ELSEIF(MSTP(94).EQ.2) THEN
22821 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
22822 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
22823 ELSEIF(MSTP(94).EQ.3) THEN
22824 CALL PYZDIS(1,0,PMS(4),ZZ)
22825 CHI=ZZ
22826 ELSE
22827 CALL PYZDIS(1000,0,PMS(4),ZZ)
22828 CHI=ZZ
22829 ENDIF
22830
22831C...Construct total transverse mass; reject if too large.
22832 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
22833 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
22834 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
22835 IF(LOOP.LT.10) GOTO 200
22836 GOTO 180
22837 ENDIF
22838 VINT(158+ISIDE)=CHI
22839
22840C...Subdivide longitudinal momentum according to value selected above.
22841 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
22842 PW1=(1D0-CHI)*PRP
22843 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
22844 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
22845 PW2=CHI*PRP
22846 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
22847 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
22848 ENDIF
22849 N=I
22850
22851C...Boost current and remnant systems to correct frame.
22852 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
22853 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
22854 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
22855 &(2D0*VINT(1)*PCP)
22856 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
22857 &(2D0*VINT(1)*PRP)
22858 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
22859 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
22860 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
22861 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
22862
22863C...Let current quark shower; recoil but no showering by colour partner.
22864 QMAX=2D0*SQRT(VINT(309-ISIDE))
22865 MSTJ48=MSTJ(48)
22866 MSTJ(48)=1
22867 PARJ86=PARJ(86)
22868 PARJ(86)=0D0
22869 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
22870 MSTJ(48)=MSTJ48
22871 PARJ(86)=PARJ86
22872
22873 RETURN
22874 END
22875
22876C*********************************************************************
22877
22878C...PYDOCU
22879C...Handles the documentation of the process in MSTI and PARI,
22880C...and also computes cross-sections based on accumulated statistics.
22881
22882 SUBROUTINE PYDOCU
22883
22884C...Double precision and integer declarations.
22885 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22886 IMPLICIT INTEGER(I-N)
22887 INTEGER PYK,PYCHGE,PYCOMP
22888C...Commonblocks.
22889 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22890 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22891 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22892 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
22893 COMMON/PYINT1/MINT(400),VINT(400)
22894 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
22895 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
22896 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
22897 &/PYINT5/
22898
22899C...Calculate Monte Carlo estimates of cross-sections.
22900 ISUB=MINT(1)
22901 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
22902 NGEN(0,3)=NGEN(0,3)+1
22903 XSEC(0,3)=0D0
22904 DO 100 I=1,500
22905 IF(I.EQ.96.OR.I.EQ.97) THEN
22906 XSEC(I,3)=0D0
22907 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
22908 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
22909 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
22910 & DBLE(NGEN(96,2)))
22911 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
22912 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
22913 & DBLE(NGEN(96,2)))
22914 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
22915 XSEC(I,3)=0D0
22916 ELSEIF(NGEN(I,2).EQ.0) THEN
22917 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
22918 & DBLE(NGEN(0,2)))
22919 ELSE
22920 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
22921 & DBLE(NGEN(I,2)))
22922 ENDIF
22923 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
22924 100 CONTINUE
22925
22926C...Rescale to known low-pT cross-section for standard QCD processes.
22927 IF(MSUB(95).EQ.1) THEN
22928 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
22929 & XSEC(68,3)+XSEC(95,3)
22930 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
22931 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
22932 FAC=XSECW/XSECH
22933 XSEC(11,3)=FAC*XSEC(11,3)
22934 XSEC(12,3)=FAC*XSEC(12,3)
22935 XSEC(13,3)=FAC*XSEC(13,3)
22936 XSEC(28,3)=FAC*XSEC(28,3)
22937 XSEC(53,3)=FAC*XSEC(53,3)
22938 XSEC(68,3)=FAC*XSEC(68,3)
22939 XSEC(95,3)=FAC*XSEC(95,3)
22940 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
22941 ENDIF
22942 ENDIF
22943
22944C...Save information for gamma-p and gamma-gamma.
22945 IF(MINT(121).GT.1) THEN
22946 IGA=MINT(122)
22947 CALL PYSAVE(2,IGA)
22948 CALL PYSAVE(5,0)
22949 ENDIF
22950
22951C...Reset information on hard interaction.
22952 DO 110 J=1,200
22953 MSTI(J)=0
22954 PARI(J)=0D0
22955 110 CONTINUE
22956
22957C...Copy integer valued information from MINT into MSTI.
22958 DO 120 J=1,32
22959 MSTI(J)=MINT(J)
22960 120 CONTINUE
22961 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
22962
22963C...Store cross-section variables in PARI.
22964 PARI(1)=XSEC(0,3)
22965 PARI(2)=XSEC(0,3)/MINT(5)
22966 PARI(7)=VINT(97)
22967 PARI(9)=VINT(99)
22968 PARI(10)=VINT(100)
22969 VINT(98)=VINT(98)+VINT(100)
22970 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
22971
22972C...Store kinematics variables in PARI.
22973 PARI(11)=VINT(1)
22974 PARI(12)=VINT(2)
22975 IF(ISUB.NE.95) THEN
22976 DO 130 J=13,26
22977 PARI(J)=VINT(30+J)
22978 130 CONTINUE
22979 PARI(29)=VINT(39)
22980 PARI(30)=VINT(40)
22981 PARI(31)=VINT(141)
22982 PARI(32)=VINT(142)
22983 PARI(33)=VINT(41)
22984 PARI(34)=VINT(42)
22985 PARI(35)=PARI(33)-PARI(34)
22986 PARI(36)=VINT(21)
22987 PARI(37)=VINT(22)
22988 PARI(38)=VINT(26)
22989 PARI(39)=VINT(157)
22990 PARI(40)=VINT(158)
22991 PARI(41)=VINT(23)
22992 PARI(42)=2D0*VINT(47)/VINT(1)
22993 ENDIF
22994
22995C...Store information on scattered partons in PARI.
22996 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
22997 DO 140 IS=7,8
22998 I=MINT(IS)
22999 PARI(36+IS)=P(I,3)/VINT(1)
23000 PARI(38+IS)=P(I,4)/VINT(1)
23001 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23002 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23003 & SQRT(PR),1D20)),P(I,3))
23004 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23005 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23006 & SQRT(PR),1D20)),P(I,3))
23007 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23008 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23009 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23010 140 CONTINUE
23011 ENDIF
23012
23013C...Store sum up transverse and longitudinal momenta.
23014 PARI(65)=2D0*PARI(17)
23015 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23016 DO 150 I=MSTP(126)+1,N
23017 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23018 PT=SQRT(P(I,1)**2+P(I,2)**2)
23019 PARI(69)=PARI(69)+PT
23020 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23021 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23022 150 CONTINUE
23023 PARI(67)=PARI(68)
23024 PARI(71)=VINT(151)
23025 PARI(72)=VINT(152)
23026 PARI(73)=VINT(151)
23027 PARI(74)=VINT(152)
23028 ELSE
23029 PARI(66)=PARI(65)
23030 PARI(69)=PARI(65)
23031 ENDIF
23032
23033C...Store various other pieces of information into PARI.
23034 PARI(61)=VINT(148)
23035 PARI(75)=VINT(155)
23036 PARI(76)=VINT(156)
23037 PARI(77)=VINT(159)
23038 PARI(78)=VINT(160)
23039 PARI(81)=VINT(138)
23040
23041C...Store information on lepton -> lepton + gamma in PYGAGA.
23042 MSTI(71)=MINT(141)
23043 MSTI(72)=MINT(142)
23044 PARI(101)=VINT(301)
23045 PARI(102)=VINT(302)
23046 DO 160 I=103,114
23047 PARI(I)=VINT(I+202)
23048 160 CONTINUE
23049
23050C...Set information for PYTABU.
23051 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23052 MSTU(161)=MINT(21)
23053 MSTU(162)=0
23054 ELSEIF(ISET(ISUB).EQ.5) THEN
23055 MSTU(161)=MINT(23)
23056 MSTU(162)=0
23057 ELSE
23058 MSTU(161)=MINT(21)
23059 MSTU(162)=MINT(22)
23060 ENDIF
23061
23062 RETURN
23063 END
23064
23065C*********************************************************************
23066
23067C...PYFRAM
23068C...Performs transformations between different coordinate frames.
23069
23070 SUBROUTINE PYFRAM(IFRAME)
23071
23072C...Double precision and integer declarations.
23073 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23074 IMPLICIT INTEGER(I-N)
23075 INTEGER PYK,PYCHGE,PYCOMP
23076C...Commonblocks.
23077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23078 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23079 COMMON/PYINT1/MINT(400),VINT(400)
23080 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23081
23082C...Check that transformation can and should be done.
23083 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23084 &MINT(91).EQ.1)) THEN
23085 IF(IFRAME.EQ.MINT(6)) RETURN
23086 ELSE
23087 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23088 RETURN
23089 ENDIF
23090
23091 IF(MINT(6).EQ.1) THEN
23092C...Transform from fixed target or user specified frame to
23093C...overall CM frame.
23094 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23095 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23096 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23097 ELSEIF(MINT(6).EQ.3) THEN
23098C...Transform from hadronic CM frame in DIS to overall CM frame.
23099 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23100 & -VINT(225))
23101 ENDIF
23102
23103 IF(IFRAME.EQ.1) THEN
23104C...Transform from overall CM frame to fixed target or user specified
23105C...frame.
23106 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23107 ELSEIF(IFRAME.EQ.3) THEN
23108C...Transform from overall CM frame to hadronic CM frame in DIS.
23109 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23110 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23111 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23112 ENDIF
23113
23114C...Set information about new frame.
23115 MINT(6)=IFRAME
23116 MSTI(6)=IFRAME
23117
23118 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23119 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23120 &1X,I5)
23121
23122 RETURN
23123 END
23124
23125C*********************************************************************
23126
23127C...PYWIDT
23128C...Calculates full and partial widths of resonances.
23129
23130 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23131
23132C...Double precision and integer declarations.
23133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23134 IMPLICIT INTEGER(I-N)
23135 INTEGER PYK,PYCHGE,PYCOMP
23136C...Parameter statement to help give large particle numbers.
23137 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23138 &KEXCIT=4000000,KDIMEN=5000000)
23139C...Commonblocks.
23140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23142 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23143 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23144 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23145 COMMON/PYINT1/MINT(400),VINT(400)
23146 COMMON/PYINT4/MWID(500),WIDS(500,5)
23147 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23148 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23149 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23150 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23151 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23152 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23153C...Local arrays and saved variables.
23154 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23155 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23156 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23157 SAVE MOFSV,WIDWSV,WID2SV
23158 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23159
23160C...Compressed code and sign; mass.
23161 KFLA=IABS(KFLR)
23162 KFLS=ISIGN(1,KFLR)
23163 KC=PYCOMP(KFLA)
23164 SHR=SQRT(SH)
23165 PMR=PMAS(KC,1)
23166
23167C...Reset width information.
23168 DO 110 I=0,MDCY(KC,3)
23169 WDTP(I)=0D0
23170 DO 100 J=0,5
23171 WDTE(I,J)=0D0
23172 100 CONTINUE
23173 110 CONTINUE
23174
23175C...Allow for fudge factor to rescale resonance width.
23176 FUDGE=1D0
23177 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23178 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23179 IF(MSTP(110).EQ.KFLA) THEN
23180 FUDGE=PARP(110)
23181 ELSEIF(MSTP(110).EQ.-1) THEN
23182 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23183 ELSEIF(MSTP(110).EQ.-2) THEN
23184 FUDGE=PARP(110)
23185 ENDIF
23186 ENDIF
23187
23188C...Not to be treated as a resonance: return.
23189 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23190 &KFLA.NE.22) THEN
23191 WDTP(0)=1D0
23192 WDTE(0,0)=1D0
23193 MINT(61)=0
23194 MINT(62)=0
23195 MINT(63)=0
23196 RETURN
23197
23198C...Treatment as a resonance based on tabulated branching ratios.
23199 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23200C...Loop over possible decay channels; skip irrelevant ones.
23201 DO 120 I=1,MDCY(KC,3)
23202 IDC=I+MDCY(KC,2)-1
23203 IF(MDME(IDC,1).LT.0) GOTO 120
23204
23205C...Read out decay products and nominal masses.
23206 KFD1=KFDP(IDC,1)
23207 KFC1=PYCOMP(KFD1)
23208 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23209 PM1=PMAS(KFC1,1)
23210 KFD2=KFDP(IDC,2)
23211 KFC2=PYCOMP(KFD2)
23212 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23213 PM2=PMAS(KFC2,1)
23214 KFD3=KFDP(IDC,3)
23215 PM3=0D0
23216 IF(KFD3.NE.0) THEN
23217 KFC3=PYCOMP(KFD3)
23218 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23219 PM3=PMAS(KFC3,1)
23220 ENDIF
23221
23222C...Naive partial width and alternative threshold factors.
23223 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23224 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23225 & PM1+PM2+PM3.GE.SHR) THEN
23226 WDTP(I)=0D0
23227 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23228 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23229 & 4D0*PM1**2*PM2**2))/SH
23230 ELSEIF(MDME(IDC,2).EQ.52) THEN
23231 PMA=MAX(PM1,PM2,PM3)
23232 PMC=MIN(PM1,PM2,PM3)
23233 PMB=PM1+PM2+PM3-PMA-PMC
23234 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23235 PMAN=PMA**2/SH
23236 PMBN=PMB**2/SH
23237 PMCN=PMC**2/SH
23238 PMBCN=PMBC**2/SH
23239 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23240 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23241 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23242 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23243 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23244 & ((1D0-PMBCN)*PMBCN*SH)
23245 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23246 WDTP(I)=WDTP(I)*SQRT(
23247 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23248 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23249 ELSEIF(MDME(IDC,2).EQ.53) THEN
23250 PMA=MAX(PM1,PM2,PM3)
23251 PMC=MIN(PM1,PM2,PM3)
23252 PMB=PM1+PM2+PM3-PMA-PMC
23253 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23254 PMAN=PMA**2/SH
23255 PMBN=PMB**2/SH
23256 PMCN=PMC**2/SH
23257 PMBCN=PMBC**2/SH
23258 FACACT=SQRT(MAX(0D0,
23259 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23260 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23261 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23262 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23263 & ((1D0-PMBCN)*PMBCN*SH)
23264 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23265 PMAN=PMA**2/PMR**2
23266 PMBN=PMB**2/PMR**2
23267 PMCN=PMC**2/PMR**2
23268 PMBCN=PMBC**2/PMR**2
23269 FACNOM=SQRT(MAX(0D0,
23270 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23271 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23272 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23273 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23274 & ((1D0-PMBCN)*PMBCN*PMR**2)
23275 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23276 ENDIF
23277 WDTP(I)=FUDGE*WDTP(I)
23278 WDTP(0)=WDTP(0)+WDTP(I)
23279
23280C...Calculate secondary width (at most two identical/opposite).
23281 WID2=1D0
23282 IF(MDME(IDC,1).GT.0) THEN
23283 IF(KFD2.EQ.KFD1) THEN
23284 IF(KCHG(KFC1,3).EQ.0) THEN
23285 WID2=WIDS(KFC1,1)
23286 ELSEIF(KFD1.GT.0) THEN
23287 WID2=WIDS(KFC1,4)
23288 ELSE
23289 WID2=WIDS(KFC1,5)
23290 ENDIF
23291 IF(KFD3.GT.0) THEN
23292 WID2=WID2*WIDS(KFC3,2)
23293 ELSEIF(KFD3.LT.0) THEN
23294 WID2=WID2*WIDS(KFC3,3)
23295 ENDIF
23296 ELSEIF(KFD2.EQ.-KFD1) THEN
23297 WID2=WIDS(KFC1,1)
23298 IF(KFD3.GT.0) THEN
23299 WID2=WID2*WIDS(KFC3,2)
23300 ELSEIF(KFD3.LT.0) THEN
23301 WID2=WID2*WIDS(KFC3,3)
23302 ENDIF
23303 ELSEIF(KFD3.EQ.KFD1) THEN
23304 IF(KCHG(KFC1,3).EQ.0) THEN
23305 WID2=WIDS(KFC1,1)
23306 ELSEIF(KFD1.GT.0) THEN
23307 WID2=WIDS(KFC1,4)
23308 ELSE
23309 WID2=WIDS(KFC1,5)
23310 ENDIF
23311 IF(KFD2.GT.0) THEN
23312 WID2=WID2*WIDS(KFC2,2)
23313 ELSEIF(KFD2.LT.0) THEN
23314 WID2=WID2*WIDS(KFC2,3)
23315 ENDIF
23316 ELSEIF(KFD3.EQ.-KFD1) THEN
23317 WID2=WIDS(KFC1,1)
23318 IF(KFD2.GT.0) THEN
23319 WID2=WID2*WIDS(KFC2,2)
23320 ELSEIF(KFD2.LT.0) THEN
23321 WID2=WID2*WIDS(KFC2,3)
23322 ENDIF
23323 ELSEIF(KFD3.EQ.KFD2) THEN
23324 IF(KCHG(KFC2,3).EQ.0) THEN
23325 WID2=WIDS(KFC2,1)
23326 ELSEIF(KFD2.GT.0) THEN
23327 WID2=WIDS(KFC2,4)
23328 ELSE
23329 WID2=WIDS(KFC2,5)
23330 ENDIF
23331 IF(KFD1.GT.0) THEN
23332 WID2=WID2*WIDS(KFC1,2)
23333 ELSEIF(KFD1.LT.0) THEN
23334 WID2=WID2*WIDS(KFC1,3)
23335 ENDIF
23336 ELSEIF(KFD3.EQ.-KFD2) THEN
23337 WID2=WIDS(KFC2,1)
23338 IF(KFD1.GT.0) THEN
23339 WID2=WID2*WIDS(KFC1,2)
23340 ELSEIF(KFD1.LT.0) THEN
23341 WID2=WID2*WIDS(KFC1,3)
23342 ENDIF
23343 ELSE
23344 IF(KFD1.GT.0) THEN
23345 WID2=WIDS(KFC1,2)
23346 ELSE
23347 WID2=WIDS(KFC1,3)
23348 ENDIF
23349 IF(KFD2.GT.0) THEN
23350 WID2=WID2*WIDS(KFC2,2)
23351 ELSE
23352 WID2=WID2*WIDS(KFC2,3)
23353 ENDIF
23354 IF(KFD3.GT.0) THEN
23355 WID2=WID2*WIDS(KFC3,2)
23356 ELSEIF(KFD3.LT.0) THEN
23357 WID2=WID2*WIDS(KFC3,3)
23358 ENDIF
23359 ENDIF
23360
23361C...Store effective widths according to case.
23362 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23363 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23364 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23365 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23366 ENDIF
23367 120 CONTINUE
23368C...Return.
23369 MINT(61)=0
23370 MINT(62)=0
23371 MINT(63)=0
23372 RETURN
23373 ENDIF
23374
23375C...Here begins detailed dynamical calculation of resonance widths.
23376C...Shared treatment of Higgs states.
23377 KFHIGG=25
23378 IHIGG=1
23379 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23380 KFHIGG=KFLA
23381 IHIGG=KFLA-33
23382 ENDIF
23383
23384C...Common electroweak and strong constants.
23385 XW=PARU(102)
23386 XWV=XW
23387 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
23388 XW1=1D0-XW
23389 AEM=PYALEM(SH)
23390 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
23391 AS=PYALPS(SH)
23392 RADC=1D0+AS/PARU(1)
23393
23394 IF(KFLA.EQ.6) THEN
23395C...t quark.
23396 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23397 RADCT=1D0-2.5D0*AS/PARU(1)
23398 DO 140 I=1,MDCY(KC,3)
23399 IDC=I+MDCY(KC,2)-1
23400 IF(MDME(IDC,1).LT.0) GOTO 140
23401 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23402 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23403 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
23404 WID2=1D0
23405 IF(I.GE.4.AND.I.LE.7) THEN
23406C...t -> W + q; including approximate QCD correction factor.
23407 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
23408 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23409 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23410 IF(KFLR.GT.0) THEN
23411 WID2=WIDS(24,2)
23412 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
23413 ELSE
23414 WID2=WIDS(24,3)
23415 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
23416 ENDIF
23417 ELSEIF(I.EQ.9) THEN
23418C...t -> H + b.
23419 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
23420 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23421 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
23422 & 4D0*SQRT(RM2R*RM2))
23423 WID2=WIDS(37,2)
23424 IF(KFLR.LT.0) WID2=WIDS(37,3)
23425CMRENNA++
23426 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
23427C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
23428 BETA=ATAN(RMSS(5))
23429 SINB=SIN(BETA)
23430 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
23431 ET=KCHG(6,1)/3D0
23432 T3L=SIGN(0.5D0,ET)
23433 KFC1=PYCOMP(KFDP(IDC,1))
23434 KFC2=PYCOMP(KFDP(IDC,2))
23435 PMNCHI=PMAS(KFC1,1)
23436 PMSTOP=PMAS(KFC2,1)
23437 IF(SHR.GT.PMNCHI+PMSTOP) THEN
23438 IZ=I-9
23439 DO 130 IK=1,4
23440 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
23441 130 CONTINUE
23442 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
23443 AR=-ET*ZMIXC(IZ,1)*TANW
23444 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
23445 BR=AL
23446 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
23447 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
23448 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
23449 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
23450 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
23451 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
23452 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
23453 IF(KFLR.GT.0) THEN
23454 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
23455 ELSE
23456 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
23457 ENDIF
23458 ENDIF
23459 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
23460C...t -> ~g + ~t
23461 KFC1=PYCOMP(KFDP(IDC,1))
23462 KFC2=PYCOMP(KFDP(IDC,2))
23463 PMNCHI=PMAS(KFC1,1)
23464 PMSTOP=PMAS(KFC2,1)
23465 IF(SHR.GT.PMNCHI+PMSTOP) THEN
23466 RL=SFMIX(6,1)
23467 RR=-SFMIX(6,2)
23468 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
23469 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
23470 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
23471 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
23472 IF(KFLR.GT.0) THEN
23473 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
23474 ELSE
23475 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
23476 ENDIF
23477 ENDIF
23478 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
23479C...t -> ~gravitino + ~t
23480 XMP2=RMSS(29)**2
23481 KFC1=PYCOMP(KFDP(IDC,1))
23482 XMGR2=PMAS(KFC1,1)**2
23483 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
23484 KFC2=PYCOMP(KFDP(IDC,2))
23485 WID2=WIDS(KFC2,2)
23486 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
23487CMRENNA--
23488 ENDIF
23489 WDTP(I)=FUDGE*WDTP(I)
23490 WDTP(0)=WDTP(0)+WDTP(I)
23491 IF(MDME(IDC,1).GT.0) THEN
23492 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23493 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23494 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23495 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23496 ENDIF
23497 140 CONTINUE
23498
23499 ELSEIF(KFLA.EQ.7) THEN
23500C...b' quark.
23501 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23502 DO 150 I=1,MDCY(KC,3)
23503 IDC=I+MDCY(KC,2)-1
23504 IF(MDME(IDC,1).LT.0) GOTO 150
23505 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23506 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23507 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
23508 WID2=1D0
23509 IF(I.GE.4.AND.I.LE.7) THEN
23510C...b' -> W + q.
23511 WDTP(I)=FAC*VCKM(I-3,4)*
23512 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23513 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23514 IF(KFLR.GT.0) THEN
23515 WID2=WIDS(24,3)
23516 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
23517 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
23518 ELSE
23519 WID2=WIDS(24,2)
23520 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
23521 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
23522 ENDIF
23523 WID2=WIDS(24,3)
23524 IF(KFLR.LT.0) WID2=WIDS(24,2)
23525 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
23526C...b' -> H + q.
23527 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23528 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
23529 IF(KFLR.GT.0) THEN
23530 WID2=WIDS(37,3)
23531 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
23532 ELSE
23533 WID2=WIDS(37,2)
23534 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
23535 ENDIF
23536 ENDIF
23537 WDTP(I)=FUDGE*WDTP(I)
23538 WDTP(0)=WDTP(0)+WDTP(I)
23539 IF(MDME(IDC,1).GT.0) THEN
23540 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23541 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23542 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23543 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23544 ENDIF
23545 150 CONTINUE
23546
23547 ELSEIF(KFLA.EQ.8) THEN
23548C...t' quark.
23549 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23550 DO 160 I=1,MDCY(KC,3)
23551 IDC=I+MDCY(KC,2)-1
23552 IF(MDME(IDC,1).LT.0) GOTO 160
23553 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23554 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23555 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
23556 WID2=1D0
23557 IF(I.GE.4.AND.I.LE.7) THEN
23558C...t' -> W + q.
23559 WDTP(I)=FAC*VCKM(4,I-3)*
23560 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23561 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23562 IF(KFLR.GT.0) THEN
23563 WID2=WIDS(24,2)
23564 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
23565 ELSE
23566 WID2=WIDS(24,3)
23567 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
23568 ENDIF
23569 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
23570C...t' -> H + q.
23571 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23572 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
23573 IF(KFLR.GT.0) THEN
23574 WID2=WIDS(37,2)
23575 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
23576 ELSE
23577 WID2=WIDS(37,3)
23578 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
23579 ENDIF
23580 ENDIF
23581 WDTP(I)=FUDGE*WDTP(I)
23582 WDTP(0)=WDTP(0)+WDTP(I)
23583 IF(MDME(IDC,1).GT.0) THEN
23584 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23585 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23586 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23587 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23588 ENDIF
23589 160 CONTINUE
23590
23591 ELSEIF(KFLA.EQ.17) THEN
23592C...tau' lepton.
23593 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23594 DO 170 I=1,MDCY(KC,3)
23595 IDC=I+MDCY(KC,2)-1
23596 IF(MDME(IDC,1).LT.0) GOTO 170
23597 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23598 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23599 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
23600 WID2=1D0
23601 IF(I.EQ.3) THEN
23602C...tau' -> W + nu'_tau.
23603 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23604 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23605 IF(KFLR.GT.0) THEN
23606 WID2=WIDS(24,3)
23607 WID2=WID2*WIDS(18,2)
23608 ELSE
23609 WID2=WIDS(24,2)
23610 WID2=WID2*WIDS(18,3)
23611 ENDIF
23612 ELSEIF(I.EQ.5) THEN
23613C...tau' -> H + nu'_tau.
23614 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23615 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
23616 IF(KFLR.GT.0) THEN
23617 WID2=WIDS(37,3)
23618 WID2=WID2*WIDS(18,2)
23619 ELSE
23620 WID2=WIDS(37,2)
23621 WID2=WID2*WIDS(18,3)
23622 ENDIF
23623 ENDIF
23624 WDTP(I)=FUDGE*WDTP(I)
23625 WDTP(0)=WDTP(0)+WDTP(I)
23626 IF(MDME(IDC,1).GT.0) THEN
23627 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23628 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23629 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23630 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23631 ENDIF
23632 170 CONTINUE
23633
23634 ELSEIF(KFLA.EQ.18) THEN
23635C...nu'_tau neutrino.
23636 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23637 DO 180 I=1,MDCY(KC,3)
23638 IDC=I+MDCY(KC,2)-1
23639 IF(MDME(IDC,1).LT.0) GOTO 180
23640 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23641 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
23642 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
23643 WID2=1D0
23644 IF(I.EQ.2) THEN
23645C...nu'_tau -> W + tau'.
23646 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23647 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
23648 IF(KFLR.GT.0) THEN
23649 WID2=WIDS(24,2)
23650 WID2=WID2*WIDS(17,2)
23651 ELSE
23652 WID2=WIDS(24,3)
23653 WID2=WID2*WIDS(17,3)
23654 ENDIF
23655 ELSEIF(I.EQ.3) THEN
23656C...nu'_tau -> H + tau'.
23657 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
23658 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
23659 IF(KFLR.GT.0) THEN
23660 WID2=WIDS(37,2)
23661 WID2=WID2*WIDS(17,2)
23662 ELSE
23663 WID2=WIDS(37,3)
23664 WID2=WID2*WIDS(17,3)
23665 ENDIF
23666 ENDIF
23667 WDTP(I)=FUDGE*WDTP(I)
23668 WDTP(0)=WDTP(0)+WDTP(I)
23669 IF(MDME(IDC,1).GT.0) THEN
23670 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23671 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23672 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23673 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23674 ENDIF
23675 180 CONTINUE
23676
23677 ELSEIF(KFLA.EQ.21) THEN
23678C...QCD:
23679C***Note that widths are not given in dimensional quantities here.
23680 DO 190 I=1,MDCY(KC,3)
23681 IDC=I+MDCY(KC,2)-1
23682 IF(MDME(IDC,1).LT.0) GOTO 190
23683 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23684 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23685 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
23686 WID2=1D0
23687 IF(I.LE.8) THEN
23688C...QCD -> q + qbar
23689 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
23690 IF(I.EQ.6) WID2=WIDS(6,1)
23691 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23692 ENDIF
23693 WDTP(I)=FUDGE*WDTP(I)
23694 WDTP(0)=WDTP(0)+WDTP(I)
23695 IF(MDME(IDC,1).GT.0) THEN
23696 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23697 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23698 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23699 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23700 ENDIF
23701 190 CONTINUE
23702
23703 ELSEIF(KFLA.EQ.22) THEN
23704C...QED photon.
23705C***Note that widths are not given in dimensional quantities here.
23706 DO 200 I=1,MDCY(KC,3)
23707 IDC=I+MDCY(KC,2)-1
23708 IF(MDME(IDC,1).LT.0) GOTO 200
23709 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23710 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23711 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
23712 WID2=1D0
23713 IF(I.LE.8) THEN
23714C...QED -> q + qbar.
23715 EF=KCHG(I,1)/3D0
23716 FCOF=3D0*RADC
23717 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
23718 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
23719 IF(I.EQ.6) WID2=WIDS(6,1)
23720 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23721 ELSEIF(I.LE.12) THEN
23722C...QED -> l+ + l-.
23723 EF=KCHG(9+2*(I-8),1)/3D0
23724 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
23725 IF(I.EQ.12) WID2=WIDS(17,1)
23726 ENDIF
23727 WDTP(I)=FUDGE*WDTP(I)
23728 WDTP(0)=WDTP(0)+WDTP(I)
23729 IF(MDME(IDC,1).GT.0) THEN
23730 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23731 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23732 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23733 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23734 ENDIF
23735 200 CONTINUE
23736
23737 ELSEIF(KFLA.EQ.23) THEN
23738C...Z0:
23739 ICASE=1
23740 XWC=1D0/(16D0*XW*XW1)
23741 FAC=(AEM*XWC/3D0)*SHR
23742 210 CONTINUE
23743 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
23744 VINT(111)=0D0
23745 VINT(112)=0D0
23746 VINT(114)=0D0
23747 ENDIF
23748 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
23749 KFI=IABS(MINT(15))
23750 IF(KFI.GT.20) KFI=IABS(MINT(16))
23751 EI=KCHG(KFI,1)/3D0
23752 AI=SIGN(1D0,EI)
23753 VI=AI-4D0*EI*XWV
23754 SQMZ=PMAS(23,1)**2
23755 HZ=SHR*WDTP(0)
23756 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
23757 IF(MSTP(43).EQ.3) VINT(112)=
23758 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
23759 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
23760 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
23761 ENDIF
23762 DO 220 I=1,MDCY(KC,3)
23763 IDC=I+MDCY(KC,2)-1
23764 IF(MDME(IDC,1).LT.0) GOTO 220
23765 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23766 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23767 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
23768 WID2=1D0
23769 IF(I.LE.8) THEN
23770C...Z0 -> q + qbar
23771 EF=KCHG(I,1)/3D0
23772 AF=SIGN(1D0,EF+0.1D0)
23773 VF=AF-4D0*EF*XWV
23774 FCOF=3D0*RADC
23775 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
23776 IF(I.EQ.6) WID2=WIDS(6,1)
23777 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23778 ELSEIF(I.LE.16) THEN
23779C...Z0 -> l+ + l-, nu + nubar
23780 EF=KCHG(I+2,1)/3D0
23781 AF=SIGN(1D0,EF+0.1D0)
23782 VF=AF-4D0*EF*XWV
23783 FCOF=1D0
23784 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
23785 ENDIF
23786 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
23787 IF(ICASE.EQ.1) THEN
23788 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
23789 & BE34
23790 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
23791 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
23792 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
23793 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
23794 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
23795 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
23796 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
23797 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
23798 ENDIF
23799 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
23800 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
23801 IF(MDME(IDC,1).GT.0) THEN
23802 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
23803 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
23804 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23805 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
23806 & WDTE(I,MDME(IDC,1))
23807 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23808 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23809 ENDIF
23810 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
23811 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
23812 & VINT(111)+FGGF*WID2
23813 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
23814 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
23815 & VINT(114)+FZZF*WID2
23816 ENDIF
23817 ENDIF
23818 220 CONTINUE
23819 IF(MINT(61).GE.1) ICASE=3-ICASE
23820 IF(ICASE.EQ.2) GOTO 210
23821
23822 ELSEIF(KFLA.EQ.24) THEN
23823C...W+/-:
23824 FAC=(AEM/(24D0*XW))*SHR
23825 DO 230 I=1,MDCY(KC,3)
23826 IDC=I+MDCY(KC,2)-1
23827 IF(MDME(IDC,1).LT.0) GOTO 230
23828 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
23829 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
23830 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
23831 WID2=1D0
23832 IF(I.LE.16) THEN
23833C...W+/- -> q + qbar'
23834 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
23835 IF(KFLR.GT.0) THEN
23836 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
23837 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
23838 IF(I.GE.13) WID2=WID2*WIDS(7,3)
23839 ELSE
23840 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
23841 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
23842 IF(I.GE.13) WID2=WID2*WIDS(7,2)
23843 ENDIF
23844 ELSEIF(I.LE.20) THEN
23845C...W+/- -> l+/- + nu
23846 FCOF=1D0
23847 IF(KFLR.GT.0) THEN
23848 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
23849 ELSE
23850 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
23851 ENDIF
23852 ENDIF
23853 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
23854 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
23855 WDTP(I)=FUDGE*WDTP(I)
23856 WDTP(0)=WDTP(0)+WDTP(I)
23857 IF(MDME(IDC,1).GT.0) THEN
23858 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23859 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23860 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23861 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23862 ENDIF
23863 230 CONTINUE
23864
23865 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23866C...h0 (or H0, or A0):
23867 SHFS=SH
23868 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
23869 DO 270 I=1,MDCY(KFHIGG,3)
23870 IDC=I+MDCY(KFHIGG,2)-1
23871 IF(MDME(IDC,1).LT.0) GOTO 270
23872 KFC1=PYCOMP(KFDP(IDC,1))
23873 KFC2=PYCOMP(KFDP(IDC,2))
23874 RM1=PMAS(KFC1,1)**2/SH
23875 RM2=PMAS(KFC2,1)**2/SH
23876 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
23877 & GOTO 270
23878 WID2=1D0
23879
23880 IF(I.LE.8) THEN
23881C...h0 -> q + qbar
23882 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
23883 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
23884C...A0 behaves like beta, ho and H0 like beta**3.
23885 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
23886 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23887 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
23888 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
23889 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
23890 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
23891 IF(IHIGG.NE.3) THEN
23892 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
23893 & PARU(151+10*IHIGG))**2
23894 ENDIF
23895 ENDIF
23896 ENDIF
23897 IF(I.EQ.6) WID2=WIDS(6,1)
23898 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
23899 ELSEIF(I.LE.12) THEN
23900C...h0 -> l+ + l-
23901 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
23902C...A0 behaves like beta, ho and H0 like beta**3.
23903 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
23904 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
23905 & PARU(153+10*IHIGG)**2
23906 IF(I.EQ.12) WID2=WIDS(17,1)
23907
23908 ELSEIF(I.EQ.13) THEN
23909C...h0 -> g + g; quark loop contribution only
23910 ETARE=0D0
23911 ETAIM=0D0
23912 DO 240 J=1,2*MSTP(1)
23913 EPS=(2D0*PMAS(J,1))**2/SH
23914C...Loop integral; function of eps=4m^2/shat; different for A0.
23915 IF(EPS.LE.1D0) THEN
23916 IF(EPS.GT.1D-4) THEN
23917 ROOT=SQRT(1D0-EPS)
23918 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
23919 ELSE
23920 RLN=LOG(4D0/EPS-2D0)
23921 ENDIF
23922 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
23923 PHIIM=0.5D0*PARU(1)*RLN
23924 ELSE
23925 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
23926 PHIIM=0D0
23927 ENDIF
23928 IF(IHIGG.LE.2) THEN
23929 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
23930 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
23931 ELSE
23932 ETAREJ=-0.5D0*EPS*PHIRE
23933 ETAIMJ=-0.5D0*EPS*PHIIM
23934 ENDIF
23935C...Couplings (=1 for standard model Higgs).
23936 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
23937 IF(MOD(J,2).EQ.1) THEN
23938 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
23939 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
23940 ELSE
23941 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
23942 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
23943 ENDIF
23944 ENDIF
23945 ETARE=ETARE+ETAREJ
23946 ETAIM=ETAIM+ETAIMJ
23947 240 CONTINUE
23948 ETA2=ETARE**2+ETAIM**2
23949 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
23950
23951 ELSEIF(I.EQ.14) THEN
23952C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
23953 ETARE=0D0
23954 ETAIM=0D0
23955 JMAX=3*MSTP(1)+1
23956 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
23957 DO 250 J=1,JMAX
23958 IF(J.LE.2*MSTP(1)) THEN
23959 EJ=KCHG(J,1)/3D0
23960 EPS=(2D0*PMAS(J,1))**2/SH
23961 ELSEIF(J.LE.3*MSTP(1)) THEN
23962 JL=2*(J-2*MSTP(1))-1
23963 EJ=KCHG(10+JL,1)/3D0
23964 EPS=(2D0*PMAS(10+JL,1))**2/SH
23965 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
23966 EPS=(2D0*PMAS(24,1))**2/SH
23967 ELSE
23968 EPS=(2D0*PMAS(37,1))**2/SH
23969 ENDIF
23970C...Loop integral; function of eps=4m^2/shat.
23971 IF(EPS.LE.1D0) THEN
23972 IF(EPS.GT.1D-4) THEN
23973 ROOT=SQRT(1D0-EPS)
23974 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
23975 ELSE
23976 RLN=LOG(4D0/EPS-2D0)
23977 ENDIF
23978 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
23979 PHIIM=0.5D0*PARU(1)*RLN
23980 ELSE
23981 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
23982 PHIIM=0D0
23983 ENDIF
23984 IF(J.LE.3*MSTP(1)) THEN
23985C...Fermion loops: loop integral different for A0; charges.
23986 IF(IHIGG.LE.2) THEN
23987 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
23988 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
23989 ELSE
23990 PHIPRE=-0.5D0*EPS*PHIRE
23991 PHIPIM=-0.5D0*EPS*PHIIM
23992 ENDIF
23993 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
23994 EJC=3D0*EJ**2
23995 EJH=PARU(151+10*IHIGG)
23996 ELSEIF(J.LE.2*MSTP(1)) THEN
23997 EJC=3D0*EJ**2
23998 EJH=PARU(152+10*IHIGG)
23999 ELSE
24000 EJC=EJ**2
24001 EJH=PARU(153+10*IHIGG)
24002 ENDIF
24003 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24004 ETAREJ=EJC*EJH*PHIPRE
24005 ETAIMJ=EJC*EJH*PHIPIM
24006 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24007C...W loops: loop integral and charges.
24008 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24009 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24010 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24011 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24012 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24013 ENDIF
24014 ELSE
24015C...Charged H loops: loop integral and charges.
24016 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24017 & PARU(158+10*IHIGG+2*(IHIGG/3))
24018 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24019 ETAIMJ=-EPS**2*PHIIM*FACHHH
24020 ENDIF
24021 ETARE=ETARE+ETAREJ
24022 ETAIM=ETAIM+ETAIMJ
24023 250 CONTINUE
24024 ETA2=ETARE**2+ETAIM**2
24025 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24026
24027 ELSEIF(I.EQ.15) THEN
24028C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24029 ETARE=0D0
24030 ETAIM=0D0
24031 JMAX=3*MSTP(1)+1
24032 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24033 DO 260 J=1,JMAX
24034 IF(J.LE.2*MSTP(1)) THEN
24035 EJ=KCHG(J,1)/3D0
24036 AJ=SIGN(1D0,EJ+0.1D0)
24037 VJ=AJ-4D0*EJ*XWV
24038 EPS=(2D0*PMAS(J,1))**2/SH
24039 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24040 ELSEIF(J.LE.3*MSTP(1)) THEN
24041 JL=2*(J-2*MSTP(1))-1
24042 EJ=KCHG(10+JL,1)/3D0
24043 AJ=SIGN(1D0,EJ+0.1D0)
24044 VJ=AJ-4D0*EJ*XWV
24045 EPS=(2D0*PMAS(10+JL,1))**2/SH
24046 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24047 ELSE
24048 EPS=(2D0*PMAS(24,1))**2/SH
24049 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24050 ENDIF
24051C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24052 IF(EPS.LE.1D0) THEN
24053 ROOT=SQRT(1D0-EPS)
24054 IF(EPS.GT.1D-4) THEN
24055 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24056 ELSE
24057 RLN=LOG(4D0/EPS-2D0)
24058 ENDIF
24059 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24060 PHIIM=0.5D0*PARU(1)*RLN
24061 PSIRE=0.5D0*ROOT*RLN
24062 PSIIM=-0.5D0*ROOT*PARU(1)
24063 ELSE
24064 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24065 PHIIM=0D0
24066 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24067 PSIIM=0D0
24068 ENDIF
24069 IF(EPSP.LE.1D0) THEN
24070 ROOT=SQRT(1D0-EPSP)
24071 IF(EPSP.GT.1D-4) THEN
24072 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24073 ELSE
24074 RLN=LOG(4D0/EPSP-2D0)
24075 ENDIF
24076 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24077 PHIIMP=0.5D0*PARU(1)*RLN
24078 PSIREP=0.5D0*ROOT*RLN
24079 PSIIMP=-0.5D0*ROOT*PARU(1)
24080 ELSE
24081 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24082 PHIIMP=0D0
24083 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24084 PSIIMP=0D0
24085 ENDIF
24086 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24087 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24088 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24089 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24090 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24091 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24092 IF(J.LE.3*MSTP(1)) THEN
24093C...Fermion loops: loop integral different for A0; charges.
24094 IF(IHIGG.EQ.3) FXYRE=0D0
24095 IF(IHIGG.EQ.3) FXYIM=0D0
24096 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24097 EJC=-3D0*EJ*VJ
24098 EJH=PARU(151+10*IHIGG)
24099 ELSEIF(J.LE.2*MSTP(1)) THEN
24100 EJC=-3D0*EJ*VJ
24101 EJH=PARU(152+10*IHIGG)
24102 ELSE
24103 EJC=-EJ*VJ
24104 EJH=PARU(153+10*IHIGG)
24105 ENDIF
24106 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24107 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24108 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24109 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24110C...W loops: loop integral and charges.
24111 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24112 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24113 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24114 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24115 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24116 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24117 ENDIF
24118 ELSE
24119C...Charged H loops: loop integral and charges.
24120 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24121 & PARU(158+10*IHIGG+2*(IHIGG/3))
24122 ETAREJ=FACHHH*FXYRE
24123 ETAIMJ=FACHHH*FXYIM
24124 ENDIF
24125 ETARE=ETARE+ETAREJ
24126 ETAIM=ETAIM+ETAIMJ
24127 260 CONTINUE
24128 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24129 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24130 WID2=WIDS(23,2)
24131
24132 ELSEIF(I.LE.17) THEN
24133C...h0 -> Z0 + Z0, W+ + W-
24134 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24135 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24136 IF(MINT(62).GE.1) THEN
24137 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24138 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24139 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24140 MOFSV(IHIGG,I-15)=0
24141 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24142 & 1D0-4D0*RM1))
24143 WID2=1D0
24144 ELSE
24145 MOFSV(IHIGG,I-15)=1
24146 RMAS=SQRT(MAX(0D0,SH))
24147 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24148 & WID2)
24149 WIDWSV(IHIGG,I-15)=WIDW
24150 WID2SV(IHIGG,I-15)=WID2
24151 ENDIF
24152 ELSE
24153 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24154 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24155 & 1D0-4D0*RM1))
24156 WID2=1D0
24157 ELSE
24158 WIDW=WIDWSV(IHIGG,I-15)
24159 WID2=WID2SV(IHIGG,I-15)
24160 ENDIF
24161 ENDIF
24162 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24163 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24164 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24165 & PARU(138+I+10*IHIGG)**2
24166 WID2=WID2*WIDS(7+I,1)
24167
24168 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24169C...H0 -> Z0 + h0, A0-> Z0 + h0
24170 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24171 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24172 IF(IHIGG.EQ.2) THEN
24173 WDTP(I)=WDTP(I)*PARU(179)**2
24174 ELSEIF(IHIGG.EQ.3) THEN
24175 WDTP(I)=WDTP(I)*PARU(186)**2
24176 ENDIF
24177 WID2=WIDS(23,2)*WIDS(25,2)
24178
24179 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24180C...H0 -> h0 + h0, A0-> h0 + h0
24181 WDTP(I)=FAC*0.25D0*
24182 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24183 IF(IHIGG.EQ.2) THEN
24184 WDTP(I)=WDTP(I)*PARU(176)**2
24185 ELSEIF(IHIGG.EQ.3) THEN
24186 WDTP(I)=WDTP(I)*PARU(169)**2
24187 ENDIF
24188 WID2=WIDS(25,1)
24189 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24190C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24191 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24192 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24193 & *PARU(195+IHIGG)**2
24194 IF(I.EQ.20) THEN
24195 WID2=WIDS(24,2)*WIDS(37,3)
24196 ELSEIF(I.EQ.21) THEN
24197 WID2=WIDS(24,3)*WIDS(37,2)
24198 ENDIF
24199
24200 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24201C...H0 -> Z0 + A0.
24202 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24203 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0
24204 WID2=WIDS(36,2)*WIDS(23,2)
24205
24206 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24207C...H0 -> h0 + A0.
24208 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24209 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24210 WID2=WIDS(25,2)*WIDS(36,2)
24211
24212 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24213C...H0 -> A0 + A0
24214 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24215 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24216 WID2=WIDS(36,1)
24217
24218CMRENNA++
24219 ELSE
24220C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24221 RM10=RM1*SH/PMR**2
24222 RM20=RM2*SH/PMR**2
24223 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24224 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24225 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24226 WFAC=0D0
24227 ELSE
24228 WFAC=WFAC/WFAC0
24229 ENDIF
24230 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24231CMRENNA--
24232 IF(KFC2.EQ.KFC1) THEN
24233 WID2=WIDS(KFC1,1)
24234 ELSE
24235 KSGN1=2
24236 IF(KFDP(IDC,1).LT.0) KSGN1=3
24237 KSGN2=2
24238 IF(KFDP(IDC,2).LT.0) KSGN2=3
24239 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24240 ENDIF
24241 ENDIF
24242 WDTP(I)=FUDGE*WDTP(I)
24243 WDTP(0)=WDTP(0)+WDTP(I)
24244 IF(MDME(IDC,1).GT.0) THEN
24245 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24246 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24247 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24248 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24249 ENDIF
24250 270 CONTINUE
24251
24252 ELSEIF(KFLA.EQ.32) THEN
24253C...Z'0:
24254 ICASE=1
24255 XWC=1D0/(16D0*XW*XW1)
24256 FAC=(AEM*XWC/3D0)*SHR
24257 VINT(117)=0D0
24258 280 CONTINUE
24259 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24260 VINT(111)=0D0
24261 VINT(112)=0D0
24262 VINT(113)=0D0
24263 VINT(114)=0D0
24264 VINT(115)=0D0
24265 VINT(116)=0D0
24266 ENDIF
24267 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24268 KFAI=IABS(MINT(15))
24269 EI=KCHG(KFAI,1)/3D0
24270 AI=SIGN(1D0,EI+0.1D0)
24271 VI=AI-4D0*EI*XWV
24272 KFAIC=1
24273 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24274 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24275 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24276 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24277 VPI=PARU(119+2*KFAIC)
24278 API=PARU(120+2*KFAIC)
24279 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24280 VPI=PARJ(178+2*KFAIC)
24281 API=PARJ(179+2*KFAIC)
24282 ELSE
24283 VPI=PARJ(186+2*KFAIC)
24284 API=PARJ(187+2*KFAIC)
24285 ENDIF
24286 SQMZ=PMAS(23,1)**2
24287 HZ=SHR*VINT(117)
24288 SQMZP=PMAS(32,1)**2
24289 HZP=SHR*WDTP(0)
24290 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24291 & MSTP(44).EQ.7) VINT(111)=1D0
24292 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24293 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24294 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24295 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24296 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24297 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24298 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24299 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24300 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24301 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24302 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24303 ENDIF
24304 DO 290 I=1,MDCY(KC,3)
24305 IDC=I+MDCY(KC,2)-1
24306 IF(MDME(IDC,1).LT.0) GOTO 290
24307 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24308 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24309 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24310 WID2=1D0
24311 IF(I.LE.16) THEN
24312 IF(I.LE.8) THEN
24313C...Z'0 -> q + qbar
24314 EF=KCHG(I,1)/3D0
24315 AF=SIGN(1D0,EF+0.1D0)
24316 VF=AF-4D0*EF*XWV
24317 IF(I.LE.2) THEN
24318 VPF=PARU(123-2*MOD(I,2))
24319 APF=PARU(124-2*MOD(I,2))
24320 ELSEIF(I.LE.4) THEN
24321 VPF=PARJ(182-2*MOD(I,2))
24322 APF=PARJ(183-2*MOD(I,2))
24323 ELSE
24324 VPF=PARJ(190-2*MOD(I,2))
24325 APF=PARJ(191-2*MOD(I,2))
24326 ENDIF
24327 FCOF=3D0*RADC
24328 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24329 & PYHFTH(SH,SH*RM1,1D0)
24330 IF(I.EQ.6) WID2=WIDS(6,1)
24331 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24332 ELSEIF(I.LE.16) THEN
24333C...Z'0 -> l+ + l-, nu + nubar
24334 EF=KCHG(I+2,1)/3D0
24335 AF=SIGN(1D0,EF+0.1D0)
24336 VF=AF-4D0*EF*XWV
24337 IF(I.LE.10) THEN
24338 VPF=PARU(127-2*MOD(I,2))
24339 APF=PARU(128-2*MOD(I,2))
24340 ELSEIF(I.LE.12) THEN
24341 VPF=PARJ(186-2*MOD(I,2))
24342 APF=PARJ(187-2*MOD(I,2))
24343 ELSE
24344 VPF=PARJ(194-2*MOD(I,2))
24345 APF=PARJ(195-2*MOD(I,2))
24346 ENDIF
24347 FCOF=1D0
24348 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24349 ENDIF
24350 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24351 IF(ICASE.EQ.1) THEN
24352 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24353 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24354 & APF**2*(1D0-4D0*RM1))*BE34
24355 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24356 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24357 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24358 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24359 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24360 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24361 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24362 ELSEIF(MINT(61).EQ.2) THEN
24363 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24364 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24365 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24366 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24367 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24368 & BE34
24369 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24370 & BE34
24371 ENDIF
24372 ELSEIF(I.EQ.17) THEN
24373C...Z'0 -> W+ + W-
24374 WDTPZP=PARU(129)**2*XW1**2*
24375 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24376 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24377 IF(ICASE.EQ.1) THEN
24378 WDTPZ=0D0
24379 WDTP(I)=FAC*WDTPZP
24380 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24381 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24382 ELSEIF(MINT(61).EQ.2) THEN
24383 FGGF=0D0
24384 FGZF=0D0
24385 FGZPF=0D0
24386 FZZF=0D0
24387 FZZPF=0D0
24388 FZPZPF=WDTPZP
24389 ENDIF
24390 WID2=WIDS(24,1)
24391 ELSEIF(I.EQ.18) THEN
24392C...Z'0 -> H+ + H-
24393 CZC=2D0*(1D0-2D0*XW)
24394 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24395 IF(ICASE.EQ.1) THEN
24396 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
24397 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
24398 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24399 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
24400 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
24401 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
24402 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
24403 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
24404 ELSEIF(MINT(61).EQ.2) THEN
24405 FGGF=0.25D0*BE34C
24406 FGZF=0.25D0*PARU(142)*CZC*BE34C
24407 FGZPF=0.25D0*PARU(143)*CZC*BE34C
24408 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
24409 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
24410 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
24411 ENDIF
24412 WID2=WIDS(37,1)
24413 ELSEIF(I.EQ.19) THEN
24414C...Z'0 -> Z0 + gamma.
24415 ELSEIF(I.EQ.20) THEN
24416C...Z'0 -> Z0 + h0
24417 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24418 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
24419 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
24420 IF(ICASE.EQ.1) THEN
24421 WDTPZ=0D0
24422 WDTP(I)=FAC*WDTPZP
24423 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24424 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24425 ELSEIF(MINT(61).EQ.2) THEN
24426 FGGF=0D0
24427 FGZF=0D0
24428 FGZPF=0D0
24429 FZZF=0D0
24430 FZZPF=0D0
24431 FZPZPF=WDTPZP
24432 ENDIF
24433 WID2=WIDS(23,2)*WIDS(25,2)
24434 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
24435C...Z' -> h0 + A0 or H0 + A0.
24436 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24437 IF(I.EQ.21) THEN
24438 CZAH=PARU(186)
24439 CZPAH=PARU(188)
24440 ELSE
24441 CZAH=PARU(187)
24442 CZPAH=PARU(189)
24443 ENDIF
24444 IF(ICASE.EQ.1) THEN
24445 WDTPZ=CZAH**2*BE34C
24446 WDTP(I)=FAC*CZPAH**2*BE34C
24447 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24448 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
24449 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
24450 & VINT(116))*BE34C
24451 ELSEIF(MINT(61).EQ.2) THEN
24452 FGGF=0D0
24453 FGZF=0D0
24454 FGZPF=0D0
24455 FZZF=CZAH**2*BE34C
24456 FZZPF=CZAH*CZPAH*BE34C
24457 FZPZPF=CZPAH**2*BE34C
24458 ENDIF
24459 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
24460 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
24461 ENDIF
24462 IF(ICASE.EQ.1) THEN
24463 VINT(117)=VINT(117)+FAC*WDTPZ
24464 WDTP(I)=FUDGE*WDTP(I)
24465 WDTP(0)=WDTP(0)+WDTP(I)
24466 ENDIF
24467 IF(MDME(IDC,1).GT.0) THEN
24468 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24469 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24470 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24471 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24472 & WDTE(I,MDME(IDC,1))
24473 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24474 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24475 ENDIF
24476 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24477 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24478 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
24479 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
24480 & FGZF*WID2
24481 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
24482 & FGZPF*WID2
24483 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24484 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
24485 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
24486 & FZZPF*WID2
24487 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24488 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
24489 ENDIF
24490 ENDIF
24491 290 CONTINUE
24492 IF(MINT(61).GE.1) ICASE=3-ICASE
24493 IF(ICASE.EQ.2) GOTO 280
24494
24495 ELSEIF(KFLA.EQ.34) THEN
24496C...W'+/-:
24497 FAC=(AEM/(24D0*XW))*SHR
24498 DO 300 I=1,MDCY(KC,3)
24499 IDC=I+MDCY(KC,2)-1
24500 IF(MDME(IDC,1).LT.0) GOTO 300
24501 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24502 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
24504 WID2=1D0
24505 IF(I.LE.20) THEN
24506 IF(I.LE.16) THEN
24507C...W'+/- -> q + qbar'
24508 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
24509 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
24510 IF(KFLR.GT.0) THEN
24511 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24512 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24513 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24514 ELSE
24515 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24516 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24517 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24518 ENDIF
24519 ELSEIF(I.LE.20) THEN
24520C...W'+/- -> l+/- + nu
24521 FCOF=PARU(133)**2+PARU(134)**2
24522 IF(KFLR.GT.0) THEN
24523 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24524 ELSE
24525 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24526 ENDIF
24527 ENDIF
24528 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
24529 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24530 ELSEIF(I.EQ.21) THEN
24531C...W'+/- -> W+/- + Z0
24532 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
24533 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24534 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24535 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
24536 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
24537 ELSEIF(I.EQ.23) THEN
24538C...W'+/- -> W+/- + h0
24539 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24540 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
24541 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
24542 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
24543 ENDIF
24544 WDTP(I)=FUDGE*WDTP(I)
24545 WDTP(0)=WDTP(0)+WDTP(I)
24546 IF(MDME(IDC,1).GT.0) THEN
24547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24551 ENDIF
24552 300 CONTINUE
24553
24554 ELSEIF(KFLA.EQ.37) THEN
24555C...H+/-:
24556C IF(MSTP(49).EQ.0) THEN
24557 SHFS=SH
24558C ELSE
24559C SHFS=PMAS(37,1)**2
24560C ENDIF
24561 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24562 DO 310 I=1,MDCY(KC,3)
24563 IDC=I+MDCY(KC,2)-1
24564 IF(MDME(IDC,1).LT.0) GOTO 310
24565 KFC1=PYCOMP(KFDP(IDC,1))
24566 KFC2=PYCOMP(KFDP(IDC,2))
24567 RM1=PMAS(KFC1,1)**2/SH
24568 RM2=PMAS(KFC2,1)**2/SH
24569 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
24570 WID2=1D0
24571 IF(I.LE.4) THEN
24572C...H+/- -> q + qbar'
24573 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
24574 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24575 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
24576 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
24577 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
24578 IF(KFLR.GT.0) THEN
24579 IF(I.EQ.3) WID2=WIDS(6,2)
24580 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
24581 ELSE
24582 IF(I.EQ.3) WID2=WIDS(6,3)
24583 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
24584 ENDIF
24585 ELSEIF(I.LE.8) THEN
24586C...H+/- -> l+/- + nu
24587 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
24588 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
24589 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
24590 IF(KFLR.GT.0) THEN
24591 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
24592 ELSE
24593 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
24594 ENDIF
24595 ELSEIF(I.EQ.9) THEN
24596C...H+/- -> W+/- + h0.
24597 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
24598 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24599 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
24600 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
24601
24602CMRENNA++
24603 ELSE
24604C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24605 RM10=RM1*SH/PMR**2
24606 RM20=RM2*SH/PMR**2
24607 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24608 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24609 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24610 WFAC=0D0
24611 ELSE
24612 WFAC=WFAC/WFAC0
24613 ENDIF
24614 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24615CMRENNA--
24616 KSGN1=2
24617 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
24618 KSGN2=2
24619 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
24620 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24621 ENDIF
24622 WDTP(I)=FUDGE*WDTP(I)
24623 WDTP(0)=WDTP(0)+WDTP(I)
24624 IF(MDME(IDC,1).GT.0) THEN
24625 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24626 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24627 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24628 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24629 ENDIF
24630 310 CONTINUE
24631
24632 ELSEIF(KFLA.EQ.41) THEN
24633C...R:
24634 FAC=(AEM/(12D0*XW))*SHR
24635 DO 320 I=1,MDCY(KC,3)
24636 IDC=I+MDCY(KC,2)-1
24637 IF(MDME(IDC,1).LT.0) GOTO 320
24638 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24639 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24640 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
24641 WID2=1D0
24642 IF(I.LE.6) THEN
24643C...R -> q + qbar'
24644 FCOF=3D0*RADC
24645 ELSEIF(I.LE.9) THEN
24646C...R -> l+ + l'-
24647 FCOF=1D0
24648 ENDIF
24649 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24650 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24651 IF(KFLR.GT.0) THEN
24652 IF(I.EQ.4) WID2=WIDS(6,3)
24653 IF(I.EQ.5) WID2=WIDS(7,3)
24654 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
24655 IF(I.EQ.9) WID2=WIDS(17,3)
24656 ELSE
24657 IF(I.EQ.4) WID2=WIDS(6,2)
24658 IF(I.EQ.5) WID2=WIDS(7,2)
24659 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
24660 IF(I.EQ.9) WID2=WIDS(17,2)
24661 ENDIF
24662 WDTP(I)=FUDGE*WDTP(I)
24663 WDTP(0)=WDTP(0)+WDTP(I)
24664 IF(MDME(IDC,1).GT.0) THEN
24665 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24666 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24667 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24668 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24669 ENDIF
24670 320 CONTINUE
24671
24672 ELSEIF(KFLA.EQ.42) THEN
24673C...LQ (leptoquark).
24674 FAC=(AEM/4D0)*PARU(151)*SHR
24675 DO 330 I=1,MDCY(KC,3)
24676 IDC=I+MDCY(KC,2)-1
24677 IF(MDME(IDC,1).LT.0) GOTO 330
24678 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24679 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24680 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
24681 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24682 WID2=1D0
24683 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
24684 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
24685 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
24686 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
24687 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
24688 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
24689 WDTP(I)=FUDGE*WDTP(I)
24690 WDTP(0)=WDTP(0)+WDTP(I)
24691 IF(MDME(IDC,1).GT.0) THEN
24692 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24693 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24694 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24695 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24696 ENDIF
24697 330 CONTINUE
24698
24699 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
24700C...Techni-pi0 and techni-pi0':
24701 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
24702 DO 340 I=1,MDCY(KC,3)
24703 IDC=I+MDCY(KC,2)-1
24704 IF(MDME(IDC,1).LT.0) GOTO 340
24705 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
24706 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
24707 RM1=PM1**2/SH
24708 RM2=PM2**2/SH
24709 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
24710 WID2=1D0
24711C...pi_tc -> g + g
24712 IF(I.EQ.8) THEN
24713 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
24714 & /(8D0*PARU(1))*SH*SHR
24715 IF(KFLA.EQ.KTECHN+111) THEN
24716 FACP=FACP*RTCM(9)
24717 ELSE
24718 FACP=FACP*RTCM(10)
24719 ENDIF
24720 WDTP(I)=FACP
24721 ELSE
24722C...pi_tc -> f + fbar.
24723 FCOF=1D0
24724 IKA=IABS(KFDP(IDC,1))
24725 IF(IKA.LT.10) FCOF=3D0*RADC
24726 HM1=PM1
24727 HM2=PM2
24728 IF(IKA.GE.4.AND.IKA.LE.6) THEN
24729 FCOF=FCOF*RTCM(1+IKA)**2
24730 HM1=PYMRUN(KFDP(IDC,1),SH)
24731 HM2=PYMRUN(KFDP(IDC,2),SH)
24732 ELSEIF(IKA.EQ.15) THEN
24733 FCOF=FCOF*RTCM(8)**2
24734 ENDIF
24735 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
24736 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24737 ENDIF
24738 WDTP(I)=FUDGE*WDTP(I)
24739 WDTP(0)=WDTP(0)+WDTP(I)
24740 IF(MDME(IDC,1).GT.0) THEN
24741 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24742 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24743 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24744 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24745 ENDIF
24746 340 CONTINUE
24747
24748 ELSEIF(KFLA.EQ.KTECHN+211) THEN
24749C...pi+_tc
24750 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
24751 DO 350 I=1,MDCY(KC,3)
24752 IDC=I+MDCY(KC,2)-1
24753 IF(MDME(IDC,1).LT.0) GOTO 350
24754 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
24755 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
24756 PM3=0D0
24757 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
24758 RM1=PM1**2/SH
24759 RM2=PM2**2/SH
24760 RM3=PM3**2/SH
24761 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
24762 WID2=1D0
24763C...pi_tc -> f + f'.
24764 FCOF=1D0
24765 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
24766C...pi_tc+ -> W b b~
24767 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
24768 FCOF=3D0*RADC
24769 XMT2=PMAS(6,1)**2/SH
24770 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
24771 KFC3=PYCOMP(KFDP(IDC,3))
24772 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
24773 CHECK = SQRT(RM1)
24774 T0 = (1D0-CHECK**2)*
24775 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
24776 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
24777 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
24778 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
24779 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
24780 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
24781 & +T3*LOG(CHECK))
24782 IF(KFLR.GT.0) THEN
24783 WID2=WIDS(24,2)
24784 ELSE
24785 WID2=WIDS(24,3)
24786 ENDIF
24787 ELSE
24788 FCOF=1D0
24789 IKA=IABS(KFDP(IDC,1))
24790 IF(IKA.LT.10) FCOF=3D0*RADC
24791 HM1=PM1
24792 HM2=PM2
24793 IF(I.GE.1.AND.I.LE.5) THEN
24794 IF(I.LE.2) THEN
24795 FCOF=FCOF*RTCM(5)**2
24796 ELSEIF(I.LE.4) THEN
24797 FCOF=FCOF*RTCM(6)**2
24798 ELSEIF(I.EQ.5) THEN
24799 FCOF=FCOF*RTCM(7)**2
24800 ENDIF
24801 HM1=PYMRUN(KFDP(IDC,1),SH)
24802 HM2=PYMRUN(KFDP(IDC,2),SH)
24803 ELSEIF(I.EQ.8) THEN
24804 FCOF=FCOF*RTCM(8)**2
24805 ENDIF
24806 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
24807 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24808 ENDIF
24809 WDTP(I)=FUDGE*WDTP(I)
24810 WDTP(0)=WDTP(0)+WDTP(I)
24811 IF(MDME(IDC,1).GT.0) THEN
24812 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24813 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24814 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24815 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24816 ENDIF
24817 350 CONTINUE
24818
24819 ELSEIF(KFLA.EQ.KTECHN+331) THEN
24820C...Techni-eta.
24821 FAC=(SH/PARP(46)**2)*SHR
24822 DO 360 I=1,MDCY(KC,3)
24823 IDC=I+MDCY(KC,2)-1
24824 IF(MDME(IDC,1).LT.0) GOTO 360
24825 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24826 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24827 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
24828 WID2=1D0
24829 IF(I.LE.2) THEN
24830 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
24831 IF(I.EQ.2) WID2=WIDS(6,1)
24832 ELSE
24833 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
24834 ENDIF
24835 WDTP(I)=FUDGE*WDTP(I)
24836 WDTP(0)=WDTP(0)+WDTP(I)
24837 IF(MDME(IDC,1).GT.0) THEN
24838 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24839 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24840 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24841 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24842 ENDIF
24843 360 CONTINUE
24844
24845 ELSEIF(KFLA.EQ.KTECHN+113) THEN
24846C...Techni-rho0:
24847 ALPRHT=2.91D0*(3D0/ITCM(1))
24848 FAC=(ALPRHT/12D0)*SHR
24849 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
24850 SQMZ=PMAS(23,1)**2
24851 SQMW=PMAS(24,1)**2
24852 SHP=SH
24853 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
24854 GMMZ=SHR*WDTPP(0)
24855 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
24856 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
24857 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
24858 DO 370 I=1,MDCY(KC,3)
24859 IDC=I+MDCY(KC,2)-1
24860 IF(MDME(IDC,1).LT.0) GOTO 370
24861 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24862 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24863 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
24864 WID2=1D0
24865 IF(I.EQ.1) THEN
24866C...rho_tc0 -> W+ + W-.
24867 WDTP(I)=FAC*RTCM(3)**4*
24868 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24869 WID2=WIDS(24,1)
24870 ELSEIF(I.EQ.2) THEN
24871C...rho_tc0 -> W+ + pi_tc-.
24872 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24873 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24874 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24875 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
24876 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
24877 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
24878 ELSEIF(I.EQ.3) THEN
24879C...rho_tc0 -> pi_tc+ + W-.
24880 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24881 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24882 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24883 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
24884 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
24885 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
24886 ELSEIF(I.EQ.4) THEN
24887C...rho_tc0 -> pi_tc+ + pi_tc-.
24888 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
24889 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24890 WID2=WIDS(PYCOMP(KTECHN+211),1)
24891 ELSEIF(I.EQ.5) THEN
24892C...rho_tc0 -> gamma + pi_tc0
24893 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24894 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
24895 & SHR**3
24896 WID2=WIDS(PYCOMP(KTECHN+111),2)
24897 ELSEIF(I.EQ.6) THEN
24898C...rho_tc0 -> gamma + pi_tc0'
24899 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24900 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
24901 WID2=WIDS(PYCOMP(KTECHN+221),2)
24902 ELSEIF(I.EQ.7) THEN
24903C...rho_tc0 -> Z0 + pi_tc0
24904 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24905 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
24906 & XW/XW1*SHR**3
24907 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
24908 ELSEIF(I.EQ.8) THEN
24909C...rho_tc0 -> Z0 + pi_tc0'
24910 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24911 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
24912 & XW/XW1*SHR**3
24913 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
24914 ELSE
24915C...rho_tc0 -> f + fbar.
24916 WID2=1D0
24917 IF(I.LE.16) THEN
24918 IA=I-8
24919 FCOF=3D0*RADC
24920 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
24921 ELSE
24922 IA=I-6
24923 FCOF=1D0
24924 IF(IA.GE.17) WID2=WIDS(IA,1)
24925 ENDIF
24926 EI=KCHG(IA,1)/3D0
24927 AI=SIGN(1D0,EI+0.1D0)
24928 VI=AI-4D0*EI*XWV
24929 VALI=0.5D0*(VI+AI)
24930 VARI=0.5D0*(VI-AI)
24931 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
24932 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
24933 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
24934 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
24935 ENDIF
24936 WDTP(I)=FUDGE*WDTP(I)
24937 WDTP(0)=WDTP(0)+WDTP(I)
24938 IF(MDME(IDC,1).GT.0) THEN
24939 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24940 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24941 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24942 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24943 ENDIF
24944 370 CONTINUE
24945
24946 ELSEIF(KFLA.EQ.KTECHN+213) THEN
24947C...Techni-rho+/-:
24948 ALPRHT=2.91D0*(3D0/ITCM(1))
24949 FAC=(ALPRHT/12D0)*SHR
24950 SQMZ=PMAS(23,1)**2
24951 SQMW=PMAS(24,1)**2
24952 SHP=SH
24953 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
24954 GMMW=SHR*WDTPP(0)
24955 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
24956 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
24957 DO 380 I=1,MDCY(KC,3)
24958 IDC=I+MDCY(KC,2)-1
24959 IF(MDME(IDC,1).LT.0) GOTO 380
24960 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24961 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24962 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
24963 WID2=1D0
24964 IF(I.EQ.1) THEN
24965C...rho_tc+ -> W+ + Z0.
24966 WDTP(I)=FAC*RTCM(3)**4*
24967 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24968 IF(KFLR.GT.0) THEN
24969 WID2=WIDS(24,2)*WIDS(23,2)
24970 ELSE
24971 WID2=WIDS(24,3)*WIDS(23,2)
24972 ENDIF
24973 ELSEIF(I.EQ.2) THEN
24974C...rho_tc+ -> W+ + pi_tc0.
24975 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24976 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24977 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24978 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
24979 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
24980 IF(KFLR.GT.0) THEN
24981 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
24982 ELSE
24983 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
24984 ENDIF
24985 ELSEIF(I.EQ.3) THEN
24986C...rho_tc+ -> pi_tc+ + Z0.
24987 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
24988 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
24989 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24990 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
24991 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
24992 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24993 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
24994 & SHR**3*XW/XW1
24995 IF(KFLR.GT.0) THEN
24996 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
24997 ELSE
24998 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
24999 ENDIF
25000 ELSEIF(I.EQ.4) THEN
25001C...rho_tc+ -> pi_tc+ + pi_tc0.
25002 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25003 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25004 IF(KFLR.GT.0) THEN
25005 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25006 ELSE
25007 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25008 ENDIF
25009 ELSEIF(I.EQ.5) THEN
25010C...rho_tc+ -> pi_tc+ + gamma
25011 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25012 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25013 & SHR**3
25014 IF(KFLR.GT.0) THEN
25015 WID2=WIDS(PYCOMP(KTECHN+211),2)
25016 ELSE
25017 WID2=WIDS(PYCOMP(KTECHN+211),3)
25018 ENDIF
25019 ELSEIF(I.EQ.6) THEN
25020C...rho_tc+ -> W+ + pi_tc0'
25021 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25022 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25023 IF(KFLR.GT.0) THEN
25024 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25025 ELSE
25026 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25027 ENDIF
25028 ELSE
25029C...rho_tc+ -> f + fbar'.
25030 IA=I-6
25031 WID2=1D0
25032 IF(IA.LE.16) THEN
25033 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25034 IF(KFLR.GT.0) THEN
25035 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25036 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25037 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25038 ELSE
25039 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25040 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25041 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25042 ENDIF
25043 ELSE
25044 FCOF=1D0
25045 IF(KFLR.GT.0) THEN
25046 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25047 ELSE
25048 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25049 ENDIF
25050 ENDIF
25051 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25052 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25053 ENDIF
25054 WDTP(I)=FUDGE*WDTP(I)
25055 WDTP(0)=WDTP(0)+WDTP(I)
25056 IF(MDME(IDC,1).GT.0) THEN
25057 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25058 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25059 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25060 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25061 ENDIF
25062 380 CONTINUE
25063
25064 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25065C...Techni-omega:
25066 ALPRHT=2.91D0*(3D0/ITCM(1))
25067 FAC=(ALPRHT/12D0)*SHR
25068 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25069 SQMZ=PMAS(23,1)**2
25070 SHP=SH
25071 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25072 GMMZ=SHR*WDTPP(0)
25073 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25074 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25075 DO 390 I=1,MDCY(KC,3)
25076 IDC=I+MDCY(KC,2)-1
25077 IF(MDME(IDC,1).LT.0) GOTO 390
25078 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25079 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25080 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25081 WID2=1D0
25082 IF(I.EQ.1) THEN
25083C...omega_tc0 -> gamma + pi_tc0.
25084 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25085 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25086 WID2=WIDS(PYCOMP(KTECHN+111),2)
25087 ELSEIF(I.EQ.2) THEN
25088C...omega_tc0 -> Z0 + pi_tc0
25089 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25090 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25091 & XW/XW1*SHR**3
25092 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25093 ELSEIF(I.EQ.3) THEN
25094C...omega_tc0 -> gamma + pi_tc0'
25095 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25096 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25097 & SHR**3
25098 WID2=WIDS(PYCOMP(KTECHN+221),2)
25099 ELSEIF(I.EQ.4) THEN
25100C...omega_tc0 -> Z0 + pi_tc0'
25101 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25102 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25103 & XW/XW1*SHR**3
25104 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25105 ELSEIF(I.EQ.5) THEN
25106C...omega_tc0 -> W+ + pi_tc-
25107 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25108 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25109 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25110 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25111 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25112 ELSEIF(I.EQ.6) THEN
25113C...omega_tc0 -> pi_tc+ + W-
25114 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25115 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25116 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25117 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25118 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25119 ELSEIF(I.EQ.7) THEN
25120C...omega_tc0 -> W+ + W-.
25121 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25122 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25123 WID2=WIDS(24,1)
25124 ELSEIF(I.EQ.8) THEN
25125C...omega_tc0 -> pi_tc+ + pi_tc-.
25126 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25127 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25128 WID2=WIDS(PYCOMP(KTECHN+211),1)
25129 ELSE
25130C...omega_tc0 -> f + fbar.
25131 WID2=1D0
25132 IF(I.LE.14) THEN
25133 IA=I-8
25134 FCOF=3D0*RADC
25135 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25136 ELSE
25137 IA=I-6
25138 FCOF=1D0
25139 IF(IA.GE.17) WID2=WIDS(IA,1)
25140 ENDIF
25141 EI=KCHG(IA,1)/3D0
25142 AI=SIGN(1D0,EI+0.1D0)
25143 VI=AI-4D0*EI*XWV
25144 VALI=-0.5D0*(VI+AI)
25145 VARI=-0.5D0*(VI-AI)
25146 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25147 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25148 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25149 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25150 ENDIF
25151 WDTP(I)=FUDGE*WDTP(I)
25152 WDTP(0)=WDTP(0)+WDTP(I)
25153 IF(MDME(IDC,1).GT.0) THEN
25154 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25155 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25156 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25157 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25158 ENDIF
25159 390 CONTINUE
25160
25161C.....V8 -> quark anti-quark
25162 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25163 FAC=AS/6D0*SHR
25164 TANT3=RTCM(21)
25165 IF(ITCM(2).EQ.0) THEN
25166 IMDL=1
25167 ELSEIF(ITCM(2).EQ.1) THEN
25168 IMDL=2
25169 ENDIF
25170 DO 400 I=1,MDCY(KC,3)
25171 IDC=I+MDCY(KC,2)-1
25172 IF(MDME(IDC,1).LT.0) GOTO 400
25173 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25174 RM1=PM1**2/SH
25175 IF(RM1.GT.0.25D0) GOTO 400
25176 WID2=1D0
25177 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25178 FMIX=1D0/TANT3**2
25179 ELSE
25180 FMIX=TANT3**2
25181 ENDIF
25182 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25183 IF(I.EQ.6) WID2=WIDS(6,1)
25184 WDTP(I)=FUDGE*WDTP(I)
25185 WDTP(0)=WDTP(0)+WDTP(I)
25186 IF(MDME(IDC,1).GT.0) THEN
25187 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25188 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25189 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25190 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25191 ENDIF
25192 400 CONTINUE
25193
25194 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25195 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25196 CLEBF=0D0
25197 DO 410 I=1,MDCY(KC,3)
25198 IDC=I+MDCY(KC,2)-1
25199 IF(MDME(IDC,1).LT.0) GOTO 410
25200 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25201 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25202 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25203 WID2=1D0
25204C...pi_tc -> g + g
25205 IF(I.EQ.7) THEN
25206 IF(KFLA.EQ.KTECHN+100111) THEN
25207 CLEBG=4D0/3D0
25208 ELSE
25209 CLEBG=5D0/3D0
25210 ENDIF
25211 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25212 & /(2D0*PARU(1))*SH*SHR*CLEBG
25213 WDTP(I)=FACP
25214 ELSE
25215C...pi_tc -> f + fbar.
25216 IF(I.EQ.6) WID2=WIDS(6,1)
25217 FCOF=1D0
25218 IKA=IABS(KFDP(IDC,1))
25219 IF(IKA.LT.10) FCOF=3D0*RADC
25220 HM1=PYMRUN(KFDP(IDC,1),SH)
25221 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25222 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25223 ENDIF
25224 WDTP(I)=FUDGE*WDTP(I)
25225 WDTP(0)=WDTP(0)+WDTP(I)
25226 IF(MDME(IDC,1).GT.0) THEN
25227 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25228 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25229 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25230 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25231 ENDIF
25232 410 CONTINUE
25233
25234 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25235 FAC=AS/6D0*SHR
25236 ALPRHT=2.91D0*(3D0/ITCM(1))
25237 TANT3=RTCM(21)
25238 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25239 SINT3=TANT3/SQRT(TANT3**2+1D0)
25240 CSXPP=RTCM(22)
25241 RM82=RTCM(27)**2
25242 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25243 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25244 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25245 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25246 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25247 & SINT3**2)*2D0
25248 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25249 & SINT3**2)*2D0
25250 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25251
25252 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25253 GMV8=SHR*WDTPP(0)
25254 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25255 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25256 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25257 IF(ITCM(2).EQ.0) THEN
25258 IMDL=1
25259 ELSE
25260 IMDL=2
25261 ENDIF
25262 DO 420 I=1,MDCY(KC,3)
25263 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25264 & KFLA.EQ.KTECHN+300113)) GOTO 420
25265 IDC=I+MDCY(KC,2)-1
25266 IF(MDME(IDC,1).LT.0) GOTO 420
25267 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25268 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25269 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25270 WID2=1D0
25271 IF(I.LE.6) THEN
25272 IF(I.EQ.6) WID2=WIDS(6,1)
25273 XIG=1D0
25274 IF(KFLA.EQ.KTECHN+200113) THEN
25275 XIG=0D0
25276 XIJ=X12
25277 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25278 XIG=0D0
25279 XIJ=X21
25280 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25281 XIJ=X11
25282 ELSE
25283 XIJ=X22
25284 ENDIF
25285 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25286 FMIX=1D0/TANT3/SIN2T
25287 ELSE
25288 FMIX=-TANT3/SIN2T
25289 ENDIF
25290 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25291 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25292 ELSEIF(I.EQ.7) THEN
25293 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25294 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25295 PSH=SHR*(1D0-RM1)/2D0
25296 WDTP(I)=AS/9D0*PSH**3/RM82
25297 IF(I.EQ.8) THEN
25298 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25299 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25300 ELSE
25301 WDTP(I)=5D0*WDTP(I)
25302 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25303 ENDIF
25304 ENDIF
25305 WDTP(I)=FUDGE*WDTP(I)
25306 WDTP(0)=WDTP(0)+WDTP(I)
25307 IF(MDME(IDC,1).GT.0) THEN
25308 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25309 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25310 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25311 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25312 ENDIF
25313 420 CONTINUE
25314
25315 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25316C...d* excited quark.
25317 FAC=(SH/RTCM(41)**2)*SHR
25318 DO 430 I=1,MDCY(KC,3)
25319 IDC=I+MDCY(KC,2)-1
25320 IF(MDME(IDC,1).LT.0) GOTO 430
25321 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25322 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25323 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25324 WID2=1D0
25325 IF(I.EQ.1) THEN
25326C...d* -> g + d.
25327 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25328 WID2=1D0
25329 ELSEIF(I.EQ.2) THEN
25330C...d* -> gamma + d.
25331 QF=-RTCM(43)/2D0+RTCM(44)/6D0
25332 WDTP(I)=FAC*AEM*QF**2/4D0
25333 WID2=1D0
25334 ELSEIF(I.EQ.3) THEN
25335C...d* -> Z0 + d.
25336 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25337 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25338 & (1D0-RM1)**2*(2D0+RM1)
25339 WID2=WIDS(23,2)
25340 ELSEIF(I.EQ.4) THEN
25341C...d* -> W- + u.
25342 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25343 & (1D0-RM1)**2*(2D0+RM1)
25344 IF(KFLR.GT.0) WID2=WIDS(24,3)
25345 IF(KFLR.LT.0) WID2=WIDS(24,2)
25346 ENDIF
25347 WDTP(I)=FUDGE*WDTP(I)
25348 WDTP(0)=WDTP(0)+WDTP(I)
25349 IF(MDME(IDC,1).GT.0) THEN
25350 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25351 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25352 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25353 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25354 ENDIF
25355 430 CONTINUE
25356
25357 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
25358C...u* excited quark.
25359 FAC=(SH/RTCM(41)**2)*SHR
25360 DO 440 I=1,MDCY(KC,3)
25361 IDC=I+MDCY(KC,2)-1
25362 IF(MDME(IDC,1).LT.0) GOTO 440
25363 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25364 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25365 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
25366 WID2=1D0
25367 IF(I.EQ.1) THEN
25368C...u* -> g + u.
25369 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25370 WID2=1D0
25371 ELSEIF(I.EQ.2) THEN
25372C...u* -> gamma + u.
25373 QF=RTCM(43)/2D0+RTCM(44)/6D0
25374 WDTP(I)=FAC*AEM*QF**2/4D0
25375 WID2=1D0
25376 ELSEIF(I.EQ.3) THEN
25377C...u* -> Z0 + u.
25378 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25379 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25380 & (1D0-RM1)**2*(2D0+RM1)
25381 WID2=WIDS(23,2)
25382 ELSEIF(I.EQ.4) THEN
25383C...u* -> W+ + d.
25384 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25385 & (1D0-RM1)**2*(2D0+RM1)
25386 IF(KFLR.GT.0) WID2=WIDS(24,2)
25387 IF(KFLR.LT.0) WID2=WIDS(24,3)
25388 ENDIF
25389 WDTP(I)=FUDGE*WDTP(I)
25390 WDTP(0)=WDTP(0)+WDTP(I)
25391 IF(MDME(IDC,1).GT.0) THEN
25392 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25393 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25394 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25395 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25396 ENDIF
25397 440 CONTINUE
25398
25399 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
25400C...e* excited lepton.
25401 FAC=(SH/RTCM(41)**2)*SHR
25402 DO 450 I=1,MDCY(KC,3)
25403 IDC=I+MDCY(KC,2)-1
25404 IF(MDME(IDC,1).LT.0) GOTO 450
25405 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25406 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25407 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
25408 WID2=1D0
25409 IF(I.EQ.1) THEN
25410C...e* -> gamma + e.
25411 QF=-RTCM(43)/2D0-RTCM(44)/2D0
25412 WDTP(I)=FAC*AEM*QF**2/4D0
25413 WID2=1D0
25414 ELSEIF(I.EQ.2) THEN
25415C...e* -> Z0 + e.
25416 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
25417 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25418 & (1D0-RM1)**2*(2D0+RM1)
25419 WID2=WIDS(23,2)
25420 ELSEIF(I.EQ.3) THEN
25421C...e* -> W- + nu.
25422 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25423 & (1D0-RM1)**2*(2D0+RM1)
25424 IF(KFLR.GT.0) WID2=WIDS(24,3)
25425 IF(KFLR.LT.0) WID2=WIDS(24,2)
25426 ENDIF
25427 WDTP(I)=FUDGE*WDTP(I)
25428 WDTP(0)=WDTP(0)+WDTP(I)
25429 IF(MDME(IDC,1).GT.0) THEN
25430 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25431 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25432 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25433 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25434 ENDIF
25435 450 CONTINUE
25436
25437 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
25438C...nu*_e excited neutrino.
25439 FAC=(SH/RTCM(41)**2)*SHR
25440 DO 460 I=1,MDCY(KC,3)
25441 IDC=I+MDCY(KC,2)-1
25442 IF(MDME(IDC,1).LT.0) GOTO 460
25443 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25444 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
25446 WID2=1D0
25447 IF(I.EQ.1) THEN
25448C...nu*_e -> Z0 + nu*_e.
25449 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
25450 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25451 & (1D0-RM1)**2*(2D0+RM1)
25452 WID2=WIDS(23,2)
25453 ELSEIF(I.EQ.2) THEN
25454C...nu*_e -> W+ + e.
25455 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25456 & (1D0-RM1)**2*(2D0+RM1)
25457 IF(KFLR.GT.0) WID2=WIDS(24,2)
25458 IF(KFLR.LT.0) WID2=WIDS(24,3)
25459 ENDIF
25460 WDTP(I)=FUDGE*WDTP(I)
25461 WDTP(0)=WDTP(0)+WDTP(I)
25462 IF(MDME(IDC,1).GT.0) THEN
25463 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25464 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25465 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25466 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25467 ENDIF
25468 460 CONTINUE
25469
25470 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
25471C...G* (graviton resonance):
25472 FAC=(PARP(50)**2/PARU(1))*SHR
25473 DO 470 I=1,MDCY(KC,3)
25474 IDC=I+MDCY(KC,2)-1
25475 IF(MDME(IDC,1).LT.0) GOTO 470
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 470
25479 WID2=1D0
25480 IF(I.LE.8) THEN
25481C...G* -> q + qbar
25482 FCOF=3D0*RADC
25483 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25484 & PYHFTH(SH,SH*RM1,1D0)
25485 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
25486 & (1D0+8D0*RM1/3D0)/320D0
25487 IF(I.EQ.6) WID2=WIDS(6,1)
25488 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
25489 ELSEIF(I.LE.16) THEN
25490C...G* -> l+ + l-, nu + nubar
25491 FCOF=1D0
25492 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
25493 & (1D0+8D0*RM1/3D0)/320D0
25494 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
25495 ELSEIF(I.EQ.17) THEN
25496C...G* -> g + g.
25497 WDTP(I)=FAC/20D0
25498 ELSEIF(I.EQ.18) THEN
25499C...G* -> gamma + gamma.
25500 WDTP(I)=FAC/160D0
25501 ELSEIF(I.EQ.19) THEN
25502C...G* -> Z0 + Z0.
25503 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
25504 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
25505 WID2=WIDS(23,1)
25506 ELSEIF(I.EQ.20) THEN
25507C...G* -> W+ + W-.
25508 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
25509 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
25510 WID2=WIDS(24,1)
25511 ENDIF
25512 WDTP(I)=FUDGE*WDTP(I)
25513 WDTP(0)=WDTP(0)+WDTP(I)
25514 IF(MDME(IDC,1).GT.0) THEN
25515 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25516 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25517 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25518 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25519 ENDIF
25520 470 CONTINUE
25521
25522 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
25523C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
25524 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
25525 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
25526 DO 480 I=1,MDCY(KC,3)
25527 IDC=I+MDCY(KC,2)-1
25528 IF(MDME(IDC,1).LT.0) GOTO 480
25529 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25530 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25531 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25532 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
25533 WID2=1D0
25534 IF(I.LE.9) THEN
25535C...nu_lR -> l- qbar q'
25536 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
25537 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
25538 ELSEIF(I.LE.18) THEN
25539C...nu_lR -> l+ q qbar'
25540 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
25541 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
25542 ELSE
25543C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
25544 FCOF=1D0
25545 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
25546 ENDIF
25547 X=(PM1+PM2+PM3)/SHR
25548 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
25549 Y=(SHR/PMWR)**2
25550 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
25551 WDTP(I)=FAC*FCOF*FX*FY
25552 WDTP(I)=FUDGE*WDTP(I)
25553 WDTP(0)=WDTP(0)+WDTP(I)
25554 IF(MDME(IDC,1).GT.0) THEN
25555 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25556 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25557 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25558 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25559 ENDIF
25560 480 CONTINUE
25561
25562 ELSEIF(KFLA.EQ.9900023) THEN
25563C...Z_R0:
25564 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
25565 DO 490 I=1,MDCY(KC,3)
25566 IDC=I+MDCY(KC,2)-1
25567 IF(MDME(IDC,1).LT.0) GOTO 490
25568 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25569 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25570 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
25571 WID2=1D0
25572 SYMMET=1D0
25573 IF(I.LE.6) THEN
25574C...Z_R0 -> q + qbar
25575 EF=KCHG(I,1)/3D0
25576 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
25577 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
25578 FCOF=3D0*RADC
25579 IF(I.EQ.6) WID2=WIDS(6,1)
25580 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
25581C...Z_R0 -> l+ + l-
25582 AF=-(1D0-2D0*XW)
25583 VF=-1D0+4D0*XW
25584 FCOF=1D0
25585 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
25586C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
25587 AF=-2D0*XW
25588 VF=0D0
25589 FCOF=1D0
25590 SYMMET=0.5D0
25591 ELSEIF(I.LE.15) THEN
25592C...Z0 -> nu_R + nu_R, assumed Majorana.
25593 AF=2D0*XW1
25594 VF=0D0
25595 FCOF=1D0
25596 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
25597 SYMMET=0.5D0
25598 ENDIF
25599 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25600 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
25601 WDTP(I)=FUDGE*WDTP(I)
25602 WDTP(0)=WDTP(0)+WDTP(I)
25603 IF(MDME(IDC,1).GT.0) THEN
25604 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25605 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25606 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25607 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25608 ENDIF
25609 490 CONTINUE
25610
25611 ELSEIF(KFLA.EQ.9900024) THEN
25612C...W_R+/-:
25613 FAC=(AEM/(24D0*XW))*SHR
25614 DO 500 I=1,MDCY(KC,3)
25615 IDC=I+MDCY(KC,2)-1
25616 IF(MDME(IDC,1).LT.0) GOTO 500
25617 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25618 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25619 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
25620 WID2=1D0
25621 IF(I.LE.9) THEN
25622C...W_R+/- -> q + qbar'
25623 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
25624 IF(KFLR.GT.0) THEN
25625 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
25626 ELSE
25627 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
25628 ENDIF
25629 ELSEIF(I.LE.12) THEN
25630C...W_R+/- -> l+/- + nu_R
25631 FCOF=1D0
25632 ENDIF
25633 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25634 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25635 WDTP(I)=FUDGE*WDTP(I)
25636 WDTP(0)=WDTP(0)+WDTP(I)
25637 IF(MDME(IDC,1).GT.0) THEN
25638 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25639 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25640 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25641 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25642 ENDIF
25643 500 CONTINUE
25644
25645 ELSEIF(KFLA.EQ.9900041) THEN
25646C...H_L++/--:
25647 FAC=(1D0/(8D0*PARU(1)))*SHR
25648 DO 510 I=1,MDCY(KC,3)
25649 IDC=I+MDCY(KC,2)-1
25650 IF(MDME(IDC,1).LT.0) GOTO 510
25651 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25652 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25653 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
25654 WID2=1D0
25655 IF(I.LE.6) THEN
25656C...H_L++/-- -> l+/- + l'+/-
25657 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
25658 & (IABS(KFDP(IDC,2))-9)/2)**2
25659 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
25660 ELSEIF(I.EQ.7) THEN
25661C...H_L++/-- -> W_L+/- + W_L+/-
25662 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
25663 & (3D0*RM1+0.25D0/RM1-1D0)
25664 WID2=WIDS(24,4+(1-KFLS)/2)
25665 ENDIF
25666 WDTP(I)=FAC*FCOF*
25667 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25668 WDTP(I)=FUDGE*WDTP(I)
25669 WDTP(0)=WDTP(0)+WDTP(I)
25670 IF(MDME(IDC,1).GT.0) THEN
25671 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25672 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25673 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25674 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25675 ENDIF
25676 510 CONTINUE
25677
25678 ELSEIF(KFLA.EQ.9900042) THEN
25679C...H_R++/--:
25680 FAC=(1D0/(8D0*PARU(1)))*SHR
25681 DO 520 I=1,MDCY(KC,3)
25682 IDC=I+MDCY(KC,2)-1
25683 IF(MDME(IDC,1).LT.0) GOTO 520
25684 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25685 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25686 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
25687 WID2=1D0
25688 IF(I.LE.6) THEN
25689C...H_R++/-- -> l+/- + l'+/-
25690 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
25691 & (IABS(KFDP(IDC,2))-9)/2)**2
25692 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
25693 ELSEIF(I.EQ.7) THEN
25694C...H_R++/-- -> W_R+/- + W_R+/-
25695 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
25696 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
25697 ENDIF
25698 WDTP(I)=FAC*FCOF*
25699 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25700 WDTP(I)=FUDGE*WDTP(I)
25701 WDTP(0)=WDTP(0)+WDTP(I)
25702 IF(MDME(IDC,1).GT.0) THEN
25703 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25704 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25705 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25706 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25707 ENDIF
25708 520 CONTINUE
25709
25710 ENDIF
25711 MINT(61)=0
25712 MINT(62)=0
25713 MINT(63)=0
25714 RETURN
25715 END
25716
25717C***********************************************************************
25718
25719C...PYOFSH
25720C...Calculates partial width and differential cross-section maxima
25721C...of channels/processes not allowed on mass-shell, and selects
25722C...masses in such channels/processes.
25723
25724 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
25725
25726C...Double precision and integer declarations.
25727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25728 IMPLICIT INTEGER(I-N)
25729 INTEGER PYK,PYCHGE,PYCOMP
25730C...Commonblocks.
25731 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25732 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25733 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25734 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
25735 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25736 COMMON/PYINT1/MINT(400),VINT(400)
25737 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
25738 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
25739 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
25740 &/PYINT2/,/PYINT5/
25741C...Local arrays.
25742 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
25743 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
25744 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
25745 &WDTE(0:400,0:5)
25746
25747C...Find if particles equal, maximum mass, matrix elements, etc.
25748 MINT(51)=0
25749 ISUB=MINT(1)
25750 KFD(1)=IABS(KFD1)
25751 KFD(2)=IABS(KFD2)
25752 MEQL=0
25753 IF(KFD(1).EQ.KFD(2)) MEQL=1
25754 MLM=0
25755 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
25756 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
25757 NOFF=44
25758 PMMX=PMMO
25759 ELSE
25760 NOFF=40
25761 PMMX=VINT(1)
25762 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
25763 ENDIF
25764 MMED=0
25765 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
25766 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
25767 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
25768 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
25769 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
25770 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
25771 LOOP=1
25772
25773C...Find where Breit-Wigners are required, else select discrete masses.
25774 100 DO 110 I=1,2
25775 KFCA=PYCOMP(KFD(I))
25776 IF(KFCA.GT.0) THEN
25777 PMD(I)=PMAS(KFCA,1)
25778 PGD(I)=PMAS(KFCA,2)
25779 ELSE
25780 PMD(I)=0D0
25781 PGD(I)=0D0
25782 ENDIF
25783 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
25784 MBW(I)=0
25785 PMG(I)=PMD(I)
25786 RMG(I)=(PMG(I)/PMMX)**2
25787 ELSE
25788 MBW(I)=1
25789 ENDIF
25790 110 CONTINUE
25791
25792C...Find allowed mass range and Breit-Wigner parameters.
25793 DO 120 I=1,2
25794 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
25795 PML(I)=PARP(42)
25796 PMU(I)=PMMX-PARP(42)
25797 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
25798 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
25799 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
25800 ILM=I
25801 IF(MLM.EQ.2) ILM=3-I
25802 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
25803 IF(MBW(3-I).EQ.0) THEN
25804 PMU(I)=PMMX-PMD(3-I)
25805 ELSE
25806 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
25807 ENDIF
25808 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
25809 & MIN(PMU(I),CKIN(NOFF+2*ILM))
25810 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
25811 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
25812 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
25813 IF(MBW(I).EQ.1) THEN
25814 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25815 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25816 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
25817 & PGD(I)))
25818 ENDIF
25819 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
25820 ILM=I
25821 IF(MLM.EQ.2) ILM=3-I
25822 PML(I)=MAX(CKIN(48+I),PARP(42))
25823 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
25824 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
25825 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
25826 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
25827 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
25828 IF(MBW(I).EQ.1) THEN
25829 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25830 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
25831 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
25832 & PGD(I)))
25833 ENDIF
25834 ENDIF
25835 120 CONTINUE
25836 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
25837 &THEN
25838 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
25839 MINT(51)=1
25840 RETURN
25841 ENDIF
25842
25843C...Calculation of partial width of resonance.
25844 IF(MOFSH.EQ.1) THEN
25845
25846C..If only one integration, pick that to be the inner.
25847 IF(MBW(1).EQ.0) THEN
25848 PM2=PMD(1)
25849 PMD(1)=PMD(2)
25850 PGD(1)=PGD(2)
25851 PML(1)=PML(2)
25852 PMU(1)=PMU(2)
25853 ELSEIF(MBW(2).EQ.0) THEN
25854 PM2=PMD(2)
25855 ENDIF
25856
25857C...Start outer loop of integration.
25858 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
25859 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
25860 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
25861 NPT2=1
25862 XPT2(1)=1D0
25863 INX2(1)=0
25864 FMAX2=0D0
25865 ENDIF
25866 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
25867 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
25868 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
25869 ENDIF
25870 RM2=(PM2/PMMX)**2
25871
25872C...Start inner loop of integration.
25873 PML1=PML(1)
25874 PMU1=MIN(PMU(1),PMMX-PM2)
25875 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
25876 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
25877 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
25878 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
25879 FUNC2=0D0
25880 GOTO 180
25881 ENDIF
25882 NPT1=1
25883 XPT1(1)=1D0
25884 INX1(1)=0
25885 FMAX1=0D0
25886 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
25887 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
25888 RM1=(PM1/PMMX)**2
25889
25890C...Evaluate function value - inner loop.
25891 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25892 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
25893 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
25894 & RM2**2+10D0*RM1*RM2)
25895 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
25896 FPT1(NPT1)=FUNC1
25897
25898C...Go to next position in inner loop.
25899 IF(NPT1.EQ.1) THEN
25900 NPT1=NPT1+1
25901 XPT1(NPT1)=0D0
25902 INX1(NPT1)=1
25903 GOTO 140
25904 ELSEIF(NPT1.LE.8) THEN
25905 NPT1=NPT1+1
25906 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
25907 ISH1=ISH1+1
25908 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
25909 INX1(NPT1)=INX1(ISH1)
25910 INX1(ISH1)=NPT1
25911 GOTO 140
25912 ELSEIF(NPT1.LT.100) THEN
25913 ISN1=ISH1
25914 150 ISH1=ISH1+1
25915 IF(ISH1.GT.NPT1) ISH1=2
25916 IF(ISH1.EQ.ISN1) GOTO 160
25917 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
25918 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
25919 NPT1=NPT1+1
25920 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
25921 INX1(NPT1)=INX1(ISH1)
25922 INX1(ISH1)=NPT1
25923 GOTO 140
25924 ENDIF
25925
25926C...Calculate integral over inner loop.
25927 160 FSUM1=0D0
25928 DO 170 IPT1=2,NPT1
25929 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
25930 & (XPT1(INX1(IPT1))-XPT1(IPT1))
25931 170 CONTINUE
25932 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
25933 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
25934 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
25935 FPT2(NPT2)=FUNC2
25936
25937C...Go to next position in outer loop.
25938 IF(NPT2.EQ.1) THEN
25939 NPT2=NPT2+1
25940 XPT2(NPT2)=0D0
25941 INX2(NPT2)=1
25942 GOTO 130
25943 ELSEIF(NPT2.LE.8) THEN
25944 NPT2=NPT2+1
25945 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
25946 ISH2=ISH2+1
25947 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
25948 INX2(NPT2)=INX2(ISH2)
25949 INX2(ISH2)=NPT2
25950 GOTO 130
25951 ELSEIF(NPT2.LT.100) THEN
25952 ISN2=ISH2
25953 190 ISH2=ISH2+1
25954 IF(ISH2.GT.NPT2) ISH2=2
25955 IF(ISH2.EQ.ISN2) GOTO 200
25956 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
25957 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
25958 NPT2=NPT2+1
25959 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
25960 INX2(NPT2)=INX2(ISH2)
25961 INX2(ISH2)=NPT2
25962 GOTO 130
25963 ENDIF
25964
25965C...Calculate integral over outer loop.
25966 200 FSUM2=0D0
25967 DO 210 IPT2=2,NPT2
25968 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
25969 & (XPT2(INX2(IPT2))-XPT2(IPT2))
25970 210 CONTINUE
25971 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
25972 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
25973 ELSE
25974 FSUM2=FUNC2
25975 ENDIF
25976
25977C...Save result; second integration for user-selected mass range.
25978 IF(LOOP.EQ.1) WIDW=FSUM2
25979 WID2=FSUM2
25980 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
25981 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
25982 LOOP=2
25983 GOTO 100
25984 ENDIF
25985 RET1=WIDW
25986 RET2=WID2/WIDW
25987
25988C...Select two decay product masses of a resonance.
25989 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
25990 220 DO 230 I=1,2
25991 IF(MBW(I).EQ.0) GOTO 230
25992 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
25993 & (ATU(I)-ATL(I)))
25994 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
25995 RMG(I)=(PMG(I)/PMMX)**2
25996 230 CONTINUE
25997 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
25998 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
25999
26000C...Weight with matrix element (if none known, use beta factor).
26001 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26002 IF(MMED.EQ.1) THEN
26003 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26004 ELSEIF(MMED.EQ.2) THEN
26005 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26006 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26007 ELSEIF(MMED.EQ.3) THEN
26008 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26009 ELSE
26010 WTBE=FLAM
26011 ENDIF
26012 IF(WTBE.LT.PYR(0)) GOTO 220
26013 RET1=PMG(1)
26014 RET2=PMG(2)
26015
26016C...Find suitable set of masses for initialization of 2 -> 2 processes.
26017 ELSEIF(MOFSH.EQ.3) THEN
26018 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26019 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26020 PMG(2)=PMD(2)
26021 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26022 PMG(1)=PMD(1)
26023 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26024 ELSE
26025 IDIV=-1
26026 240 IDIV=IDIV+1
26027 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26028 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26029 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26030 ENDIF
26031 RET1=PMG(1)
26032 RET2=PMG(2)
26033
26034C...Evaluate importance of excluded tails of Breit-Wigners.
26035 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26036 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26037 IF(MEQL.LE.1) THEN
26038 VINT(80)=1D0
26039 DO 250 I=1,2
26040 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26041 & PARU(1)
26042 250 CONTINUE
26043 ELSE
26044 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26045 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26046 ENDIF
26047 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26048 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26049 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26050 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26051
26052C...Pick one particle to be the lighter (if improves efficiency).
26053 ELSEIF(MOFSH.EQ.4) THEN
26054 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26055 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26056 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26057
26058C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26059 DO 270 I=1,2
26060 IF(MBW(I).EQ.0) GOTO 270
26061 PMV=PMU(I)
26062 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26063 ATV=ATU(I)
26064 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26065 RBR=PYR(0)
26066 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26067 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26068 IF(RBR.LT.0.8D0) THEN
26069 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26070 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26071 ELSEIF(RBR.LT.0.9D0) THEN
26072 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26073 ELSEIF(RBR.LT.1.5D0) THEN
26074 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26075 ELSE
26076 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26077 & (PMV**2-PML(I)**2))))
26078 ENDIF
26079 270 CONTINUE
26080 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26081 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26082 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26083 NGEN(0,1)=NGEN(0,1)+1
26084 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26085 GOTO 260
26086 ELSE
26087 MINT(51)=1
26088 RETURN
26089 ENDIF
26090 ENDIF
26091 RET1=PMG(1)
26092 RET2=PMG(2)
26093
26094C...Give weight for selected mass distribution.
26095 VINT(80)=1D0
26096 DO 280 I=1,2
26097 IF(MBW(I).EQ.0) GOTO 280
26098 PMV=PMU(I)
26099 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26100 ATV=ATU(I)
26101 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26102 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26103 & (PMD(I)*PGD(I))**2)/PARU(1)
26104 F1=1D0
26105 F2=1D0/PMG(I)**2
26106 F3=1D0/PMG(I)**4
26107 FI0=(ATV-ATL(I))/PARU(1)
26108 FI1=PMV**2-PML(I)**2
26109 FI2=2D0*LOG(PMV/PML(I))
26110 FI3=1D0/PML(I)**2-1D0/PMV**2
26111 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26112 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
26113 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
26114 & 5D0*F3/FI3))
26115 ELSE
26116 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
26117 ENDIF
26118 VINT(80)=VINT(80)*FI0
26119 280 CONTINUE
26120 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26121 ENDIF
26122
26123 RETURN
26124 END
26125
26126C***********************************************************************
26127
26128C...PYRECO
26129C...Handles the possibility of colour reconnection in W+W- events,
26130C...Based on the main scenarios of the Sjostrand and Khoze study:
26131C...I, II, II', intermediate and instantaneous; plus one model
26132C...along the lines of the Gustafson and Hakkinen: GH.
26133C...Note: also handles Z0 Z0 and W-W+ events, but notation below
26134C...is as if first resonance is W+ and second W-.
26135
26136 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
26137
26138C...Double precision and integer declarations.
26139 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26140 IMPLICIT INTEGER(I-N)
26141 INTEGER PYK,PYCHGE,PYCOMP
26142C...Parameter value; number of points in MC integration.
26143 PARAMETER (NPT=100)
26144C...Commonblocks.
26145 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
26146 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26147 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26149 COMMON/PYINT1/MINT(400),VINT(400)
26150 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
26151C...Local arrays.
26152 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
26153 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
26154 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
26155 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
26156 &TMC(20),IJOIN(100)
26157
26158C...Functions to give four-product and to do determinants.
26159 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)
26160 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
26161 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
26162 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
26163
26164C...Only allow fraction of recoupling for GH, intermediate and
26165C...instantaneous.
26166 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
26167 IF(PYR(0).GT.PARP(120)) RETURN
26168 ENDIF
26169 ISUB=MINT(1)
26170
26171C...Common part for scenarios I, II, II', and GH.
26172 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
26173 &MSTP(115).EQ.5) THEN
26174
26175C...Read out frequently-used parameters.
26176 PI=PARU(1)
26177 HBAR=PARU(3)
26178 PMW=PMAS(24,1)
26179 IF(ISUB.EQ.22) PMW=PMAS(23,1)
26180 PGW=PMAS(24,2)
26181 IF(ISUB.EQ.22) PGW=PMAS(23,2)
26182 TFRAG=PARP(115)
26183 RHAD=PARP(116)
26184 FACT=PARP(117)
26185 BLOWR=PARP(118)
26186 BLOWT=PARP(119)
26187
26188C...Find range of decay products of the W's.
26189C...Background: the W's are stored in IW1 and IW2.
26190C...Their direct decay products in NSD1+1 through NSD1+4.
26191C...Products after shower (if any) in NSD1+5 through NAFT1
26192C...for first W and in NAFT1+1 through N for the second.
26193 IF(NAFT1.GT.NSD1+4) THEN
26194 NBEG(1)=NSD1+5
26195 NEND(1)=NAFT1
26196 ELSE
26197 NBEG(1)=NSD1+1
26198 NEND(1)=NSD1+2
26199 ENDIF
26200 IF(N.GT.NAFT1) THEN
26201 NBEG(2)=NAFT1+1
26202 NEND(2)=N
26203 ELSE
26204 NBEG(2)=NSD1+3
26205 NEND(2)=NSD1+4
26206 ENDIF
26207
26208C...Rearrange parton shower products along strings.
26209 NOLD=N
26210 CALL PYPREP(NSD1+1)
26211 IF(MINT(51).NE.0) RETURN
26212
26213C...Find partons pointing back to W+ and W-; store them with quark
26214C...end of string first.
26215 NNP=0
26216 NNM=0
26217 ISGP=0
26218 ISGM=0
26219 DO 120 I=NOLD+1,N
26220 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
26221 IF(IABS(K(I,2)).GE.22) GOTO 120
26222 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
26223 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
26224 NNP=NNP+1
26225 IF(ISGP.EQ.1) THEN
26226 INP(NNP)=I
26227 ELSE
26228 DO 100 I1=NNP,2,-1
26229 INP(I1)=INP(I1-1)
26230 100 CONTINUE
26231 INP(1)=I
26232 ENDIF
26233 IF(K(I,1).EQ.1) ISGP=0
26234 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
26235 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
26236 NNM=NNM+1
26237 IF(ISGM.EQ.1) THEN
26238 INM(NNM)=I
26239 ELSE
26240 DO 110 I1=NNM,2,-1
26241 INM(I1)=INM(I1-1)
26242 110 CONTINUE
26243 INM(1)=I
26244 ENDIF
26245 IF(K(I,1).EQ.1) ISGM=0
26246 ENDIF
26247 120 CONTINUE
26248
26249C...Boost to W+W- rest frame (not strictly needed).
26250 DO 130 J=1,3
26251 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
26252 130 CONTINUE
26253 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
26254 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
26255 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
26256
26257C...Select decay vertices of W+ and W-.
26258 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
26259 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
26260 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
26261 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
26262 GTMAX=MAX(TP,TM)
26263 DO 140 J=1,3
26264 XP(J)=TP*P(IW1,J)/P(IW1,4)
26265 XM(J)=TM*P(IW2,J)/P(IW2,4)
26266 140 CONTINUE
26267
26268C...Begin scenario I specifics.
26269 IF(MSTP(115).EQ.1) THEN
26270
26271C...Reconstruct velocity and direction of W+ string pieces.
26272 DO 170 IIP=1,NNP-1
26273 IF(K(INP(IIP),2).LT.0) GOTO 170
26274 I1=INP(IIP)
26275 I2=INP(IIP+1)
26276 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
26277 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
26278 DO 150 J=1,3
26279 V1(J)=P(I1,J)/P1A
26280 V2(J)=P(I2,J)/P2A
26281 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
26282 DIRP(IIP,J)=V1(J)-V2(J)
26283 150 CONTINUE
26284 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
26285 & BETP(IIP,3)**2)
26286 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
26287 DO 160 J=1,3
26288 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
26289 160 CONTINUE
26290 170 CONTINUE
26291
26292C...Reconstruct velocity and direction of W- string pieces.
26293 DO 200 IIM=1,NNM-1
26294 IF(K(INM(IIM),2).LT.0) GOTO 200
26295 I1=INM(IIM)
26296 I2=INM(IIM+1)
26297 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
26298 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
26299 DO 180 J=1,3
26300 V1(J)=P(I1,J)/P1A
26301 V2(J)=P(I2,J)/P2A
26302 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
26303 DIRM(IIM,J)=V1(J)-V2(J)
26304 180 CONTINUE
26305 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
26306 & BETM(IIM,3)**2)
26307 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
26308 DO 190 J=1,3
26309 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
26310 190 CONTINUE
26311 200 CONTINUE
26312
26313C...Loop over number of space-time points.
26314 NACC=0
26315 SUM=0D0
26316 DO 250 IPT=1,NPT
26317
26318C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
26319 R=SQRT(-LOG(PYR(0)))
26320 PHI=2D0*PI*PYR(0)
26321 X=BLOWR*RHAD*R*COS(PHI)
26322 Y=BLOWR*RHAD*R*SIN(PHI)
26323 R=SQRT(-LOG(PYR(0)))
26324 PHI=2D0*PI*PYR(0)
26325 Z=BLOWR*RHAD*R*COS(PHI)
26326 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
26327
26328C...Reject impossible points. Weight for sample distribution.
26329 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
26330 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
26331 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
26332
26333C...Loop over W+ string pieces and find one with largest weight.
26334 IMAXP=0
26335 WTMAXP=1D-10
26336 XD(1)=X-XP(1)
26337 XD(2)=Y-XP(2)
26338 XD(3)=Z-XP(3)
26339 XD(4)=T-TP
26340 DO 220 IIP=1,NNP-1
26341 IF(K(INP(IIP),2).LT.0) GOTO 220
26342 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
26343 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
26344 DO 210 J=1,3
26345 XB(J)=XD(J)+BEDG*BETP(IIP,J)
26346 210 CONTINUE
26347 XB(4)=BETP(IIP,4)*(XD(4)-BED)
26348 SR2=XB(1)**2+XB(2)**2+XB(3)**2
26349 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
26350 & DIRP(IIP,3)*XB(3))**2
26351 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
26352 & TFRAG**2)
26353 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
26354 IF(WTP.GT.WTMAXP) THEN
26355 IMAXP=IIP
26356 WTMAXP=WTP
26357 ENDIF
26358 220 CONTINUE
26359
26360C...Loop over W- string pieces and find one with largest weight.
26361 IMAXM=0
26362 WTMAXM=1D-10
26363 XD(1)=X-XM(1)
26364 XD(2)=Y-XM(2)
26365 XD(3)=Z-XM(3)
26366 XD(4)=T-TM
26367 DO 240 IIM=1,NNM-1
26368 IF(K(INM(IIM),2).LT.0) GOTO 240
26369 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
26370 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
26371 DO 230 J=1,3
26372 XB(J)=XD(J)+BEDG*BETM(IIM,J)
26373 230 CONTINUE
26374 XB(4)=BETM(IIM,4)*(XD(4)-BED)
26375 SR2=XB(1)**2+XB(2)**2+XB(3)**2
26376 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
26377 & DIRM(IIM,3)*XB(3))**2
26378 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
26379 & TFRAG**2)
26380 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
26381 IF(WTM.GT.WTMAXM) THEN
26382 IMAXM=IIM
26383 WTMAXM=WTM
26384 ENDIF
26385 240 CONTINUE
26386
26387C...Result of integration.
26388 WT=0D0
26389 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
26390 WT=WTMAXP*WTMAXM/WTSMP
26391 SUM=SUM+WT
26392 NACC=NACC+1
26393 IAP(NACC)=IMAXP
26394 IAM(NACC)=IMAXM
26395 WTA(NACC)=WT
26396 ENDIF
26397 250 CONTINUE
26398 RES=BLOWR**3*BLOWT*SUM/NPT
26399
26400C...Decide whether to reconnect and, if so, where.
26401 IACC=0
26402 PREC=1D0-EXP(-FACT*RES)
26403 IF(PREC.GT.PYR(0)) THEN
26404 RSUM=PYR(0)*SUM
26405 DO 260 IA=1,NACC
26406 IACC=IA
26407 RSUM=RSUM-WTA(IA)
26408 IF(RSUM.LE.0D0) GOTO 270
26409 260 CONTINUE
26410 270 IIP=IAP(IACC)
26411 IIM=IAM(IACC)
26412 ENDIF
26413
26414C...Begin scenario II and II' specifics.
26415 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
26416
26417C...Loop through all string pieces, one from W+ and one from W-.
26418 NCROSS=0
26419 TC(0)=0D0
26420 DO 340 IIP=1,NNP-1
26421 IF(K(INP(IIP),2).LT.0) GOTO 340
26422 I1P=INP(IIP)
26423 I2P=INP(IIP+1)
26424 DO 330 IIM=1,NNM-1
26425 IF(K(INM(IIM),2).LT.0) GOTO 330
26426 I1M=INM(IIM)
26427 I2M=INM(IIM+1)
26428
26429C...Find endpoint velocity vectors.
26430 DO 280 J=1,3
26431 V1P(J)=P(I1P,J)/P(I1P,4)
26432 V2P(J)=P(I2P,J)/P(I2P,4)
26433 V1M(J)=P(I1M,J)/P(I1M,4)
26434 V2M(J)=P(I2M,J)/P(I2M,4)
26435 280 CONTINUE
26436
26437C...Define q matrix and find t.
26438 DO 290 J=1,3
26439 Q(1,J)=V2P(J)-V1P(J)
26440 Q(2,J)=-(V2M(J)-V1M(J))
26441 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
26442 Q(4,J)=V1P(J)-V1M(J)
26443 290 CONTINUE
26444 T=-DETER(1,2,3)/DETER(1,2,4)
26445
26446C...Find alpha and beta; i.e. coordinates of crossing point.
26447 S11=Q(1,1)*(T-TP)
26448 S12=Q(2,1)*(T-TM)
26449 S13=Q(3,1)+Q(4,1)*T
26450 S21=Q(1,2)*(T-TP)
26451 S22=Q(2,2)*(T-TM)
26452 S23=Q(3,2)+Q(4,2)*T
26453 DEN=S11*S22-S12*S21
26454 ALP=(S12*S23-S22*S13)/DEN
26455 BET=(S21*S13-S11*S23)/DEN
26456
26457C...Check if solution acceptable.
26458 IANSW=1
26459 IF(T.LT.GTMAX) IANSW=0
26460 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
26461 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
26462
26463C...Find point of crossing and check that not inconsistent.
26464 DO 300 J=1,3
26465 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
26466 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
26467 300 CONTINUE
26468 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
26469 & (XPP(3)-XMM(3))**2
26470 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
26471 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
26472 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
26473
26474C...Find string eigentimes at crossing.
26475 IF(IANSW.EQ.1) THEN
26476 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
26477 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
26478 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
26479 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
26480 ELSE
26481 TAUP=0D0
26482 TAUM=0D0
26483 ENDIF
26484
26485C...Order crossings by time. End loop over crossings.
26486 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
26487 NCROSS=NCROSS+1
26488 DO 310 I1=NCROSS,1,-1
26489 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
26490 IPC(I1)=IIP
26491 IMC(I1)=IIM
26492 TC(I1)=T
26493 TPC(I1)=TAUP
26494 TMC(I1)=TAUM
26495 GOTO 320
26496 ELSE
26497 IPC(I1)=IPC(I1-1)
26498 IMC(I1)=IMC(I1-1)
26499 TC(I1)=TC(I1-1)
26500 TPC(I1)=TPC(I1-1)
26501 TMC(I1)=TMC(I1-1)
26502 ENDIF
26503 310 CONTINUE
26504 320 CONTINUE
26505 ENDIF
26506 330 CONTINUE
26507 340 CONTINUE
26508
26509C...Loop over crossings; find first (if any) acceptable one.
26510 IACC=0
26511 IF(NCROSS.GE.1) THEN
26512 DO 350 IC=1,NCROSS
26513 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
26514 IF(PNFRAG.GT.PYR(0)) THEN
26515C...Scenario II: only compare with fragmentation time.
26516 IF(MSTP(115).EQ.2) THEN
26517 IACC=IC
26518 IIP=IPC(IACC)
26519 IIM=IMC(IACC)
26520 GOTO 360
26521C...Scenario II': also require that string length decreases.
26522 ELSE
26523 IIP=IPC(IC)
26524 IIM=IMC(IC)
26525 I1P=INP(IIP)
26526 I2P=INP(IIP+1)
26527 I1M=INM(IIM)
26528 I2M=INM(IIM+1)
26529 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
26530 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
26531 IF(ELNEW.LT.ELOLD) THEN
26532 IACC=IC
26533 IIP=IPC(IACC)
26534 IIM=IMC(IACC)
26535 GOTO 360
26536 ENDIF
26537 ENDIF
26538 ENDIF
26539 350 CONTINUE
26540 360 CONTINUE
26541 ENDIF
26542
26543C...Begin scenario GH specifics.
26544 ELSEIF(MSTP(115).EQ.5) THEN
26545
26546C...Loop through all string pieces, one from W+ and one from W-.
26547 IACC=0
26548 ELMIN=1D0
26549 DO 380 IIP=1,NNP-1
26550 IF(K(INP(IIP),2).LT.0) GOTO 380
26551 I1P=INP(IIP)
26552 I2P=INP(IIP+1)
26553 DO 370 IIM=1,NNM-1
26554 IF(K(INM(IIM),2).LT.0) GOTO 370
26555 I1M=INM(IIM)
26556 I2M=INM(IIM+1)
26557
26558C...Look for largest decrease of (exponent of) Lambda measure.
26559 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
26560 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
26561 ELDIF=ELNEW/MAX(1D-10,ELOLD)
26562 IF(ELDIF.LT.ELMIN) THEN
26563 IACC=IIP+IIM
26564 ELMIN=ELDIF
26565 IPC(1)=IIP
26566 IMC(1)=IIM
26567 ENDIF
26568 370 CONTINUE
26569 380 CONTINUE
26570 IIP=IPC(1)
26571 IIM=IMC(1)
26572 ENDIF
26573
26574C...Common for scenarios I, II, II' and GH: reconnect strings.
26575 IF(IACC.NE.0) THEN
26576 MINT(32)=1
26577 NJOIN=0
26578 DO 390 IS=1,NNP+NNM
26579 NJOIN=NJOIN+1
26580 IF(IS.LE.IIP) THEN
26581 I=INP(IS)
26582 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
26583 I=INM(IS-IIP+IIM)
26584 ELSEIF(IS.LE.IIP+NNM) THEN
26585 I=INM(IS-IIP-NNM+IIM)
26586 ELSE
26587 I=INP(IS-NNM)
26588 ENDIF
26589 IJOIN(NJOIN)=I
26590 IF(K(I,2).LT.0) THEN
26591 CALL PYJOIN(NJOIN,IJOIN)
26592 NJOIN=0
26593 ENDIF
26594 390 CONTINUE
26595
26596C...Restore original event record if no reconnection.
26597 ELSE
26598 DO 400 I=NSD1+1,NOLD
26599 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
26600 K(I,4)=MOD(K(I,4),MSTU(5)**2)
26601 K(I,5)=MOD(K(I,5),MSTU(5)**2)
26602 ENDIF
26603 400 CONTINUE
26604 DO 410 I=NOLD+1,N
26605 K(K(I,3),1)=3
26606 410 CONTINUE
26607 N=NOLD
26608 ENDIF
26609
26610C...Boost back system.
26611 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
26612 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
26613 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
26614 & BEWW(1),BEWW(2),BEWW(3))
26615
26616C...Common part for intermediate and instantaneous scenarios.
26617 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
26618 MINT(32)=1
26619
26620C...Remove old shower products and reset showering ones.
26621 N=NSD1+4
26622 DO 420 I=NSD1+1,NSD1+4
26623 K(I,1)=3
26624 K(I,4)=MOD(K(I,4),MSTU(5)**2)
26625 K(I,5)=MOD(K(I,5),MSTU(5)**2)
26626 420 CONTINUE
26627
26628C...Identify quark-antiquark pairs.
26629 IQ1=NSD1+1
26630 IQ2=NSD1+2
26631 IQ3=NSD1+3
26632 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
26633 IQ4=2*NSD1+7-IQ3
26634
26635C...Reconnect strings.
26636 IJOIN(1)=IQ1
26637 IJOIN(2)=IQ4
26638 CALL PYJOIN(2,IJOIN)
26639 IJOIN(1)=IQ3
26640 IJOIN(2)=IQ2
26641 CALL PYJOIN(2,IJOIN)
26642
26643C...Do new parton showers in intermediate scenario.
26644 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
26645 MSTJ50=MSTJ(50)
26646 MSTJ(50)=0
26647 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
26648 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
26649 MSTJ(50)=MSTJ50
26650
26651C...Do new parton showers in instantaneous scenario.
26652 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
26653 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
26654 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
26655 PPM=SQRT(MAX(0D0,PPM2))
26656 CALL PYSHOW(IQ1,IQ4,PPM)
26657 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
26658 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
26659 PPM=SQRT(MAX(0D0,PPM2))
26660 CALL PYSHOW(IQ3,IQ2,PPM)
26661 ENDIF
26662 ENDIF
26663
26664 RETURN
26665 END
26666
26667C***********************************************************************
26668
26669C...PYKLIM
26670C...Checks generated variables against pre-set kinematical limits;
26671C...also calculates limits on variables used in generation.
26672
26673 SUBROUTINE PYKLIM(ILIM)
26674
26675C...Double precision and integer declarations.
26676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26677 IMPLICIT INTEGER(I-N)
26678 INTEGER PYK,PYCHGE,PYCOMP
26679C...Commonblocks.
26680 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
26681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26682 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26683 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26684 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26685 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26686 COMMON/PYINT1/MINT(400),VINT(400)
26687 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26688 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
26689 &/PYINT1/,/PYINT2/
26690
26691C...Common kinematical expressions.
26692 MINT(51)=0
26693 ISUB=MINT(1)
26694 ISTSB=ISET(ISUB)
26695 IF(ISUB.EQ.96) GOTO 100
26696 SQM3=VINT(63)
26697 SQM4=VINT(64)
26698 IF(ILIM.NE.0) THEN
26699 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
26700 CKIN09=MAX(CKIN(9),CKIN(13))
26701 CKIN10=MIN(CKIN(10),CKIN(14))
26702 CKIN11=MAX(CKIN(11),CKIN(15))
26703 CKIN12=MIN(CKIN(12),CKIN(16))
26704 ELSE
26705 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
26706 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
26707 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
26708 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
26709 ENDIF
26710 ENDIF
26711 IF(ILIM.NE.1) THEN
26712 TAU=VINT(21)
26713 RM3=SQM3/(TAU*VINT(2))
26714 RM4=SQM4/(TAU*VINT(2))
26715 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
26716 ENDIF
26717 PTHMIN=CKIN(3)
26718 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
26719 &PTHMIN=MAX(CKIN(3),CKIN(5))
26720
26721 IF(ILIM.EQ.0) THEN
26722C...Check generated values of tau, y*, cos(theta-hat), and tau' against
26723C...pre-set kinematical limits.
26724 YST=VINT(22)
26725 CTH=VINT(23)
26726 TAUP=VINT(26)
26727 TAUE=TAU
26728 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
26729 X1=SQRT(TAUE)*EXP(YST)
26730 X2=SQRT(TAUE)*EXP(-YST)
26731 XF=X1-X2
26732 IF(MINT(47).NE.1) THEN
26733 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
26734 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
26735 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
26736 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
26737 ENDIF
26738 IF(MINT(45).NE.1) THEN
26739 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
26740 ENDIF
26741 IF(MINT(46).NE.1) THEN
26742 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
26743 ENDIF
26744 IF(MINT(45).EQ.2) THEN
26745 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
26746 ENDIF
26747 IF(MINT(46).EQ.2) THEN
26748 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
26749 ENDIF
26750 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
26751 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
26752 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
26753 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
26754 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
26755 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
26756 Y3=YST+0.5D0*LOG(EXPY3)
26757 Y4=YST+0.5D0*LOG(EXPY4)
26758 YLARGE=MAX(Y3,Y4)
26759 YSMALL=MIN(Y3,Y4)
26760 ETALAR=20D0
26761 ETASMA=-20D0
26762 STH=SQRT(MAX(0D0,1D0-CTH**2))
26763 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
26764 & CTH)**2-4D0*RM3))
26765 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
26766 & CTH)**2-4D0*RM4))
26767 IF(STH.GE.1D-10) THEN
26768 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
26769 & (BE34*STH)
26770 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
26771 & (BE34*STH)
26772 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
26773 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
26774 ETALAR=MAX(ETA3,ETA4)
26775 ETASMA=MIN(ETA3,ETA4)
26776 ENDIF
26777 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
26778 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
26779 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
26780 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
26781 SH=TAU*VINT(2)
26782 RPTS=4D0*VINT(71)**2/SH
26783 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
26784 RM34=MAX(1D-20,2D0*RM3*RM4)
26785 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
26786 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
26787 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
26788 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
26789 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
26790 IF(PTH.LT.PTHMIN) MINT(51)=1
26791 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
26792 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
26793 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
26794 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
26795 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
26796 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
26797 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
26798 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
26799 IF(THA.LT.CKIN(35)) MINT(51)=1
26800 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
26801 IF(UHA.LT.CKIN(37)) MINT(51)=1
26802 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
26803 ENDIF
26804 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
26805 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
26806 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
26807 ENDIF
26808
26809C...Additional cuts on W2 (approximately) in DIS.
26810 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
26811 XBJ=X2
26812 IF(IABS(MINT(12)).LT.20) XBJ=X1
26813 Q2BJ=THA
26814 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
26815 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
26816 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
26817 ENDIF
26818
26819 ELSEIF(ILIM.EQ.1) THEN
26820C...Calculate limits on tau
26821C...0) due to definition
26822 TAUMN0=0D0
26823 TAUMX0=1D0
26824C...1) due to limits on subsystem mass
26825 TAUMN1=CKIN(1)**2/VINT(2)
26826 TAUMX1=1D0
26827 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
26828C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
26829 TM3=SQRT(SQM3+PTHMIN**2)
26830 TM4=SQRT(SQM4+PTHMIN**2)
26831 YDCOSH=1D0
26832 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
26833 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
26834 TAUMX2=1D0
26835C...3) due to limits on pT-hat and cos(theta-hat)
26836 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
26837 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
26838 TAUMN3=0D0
26839 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
26840 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
26841 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
26842 TAUMX3=1D0
26843 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
26844 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
26845 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
26846C...4) due to limits on x1 and x2
26847 TAUMN4=CKIN(21)*CKIN(23)
26848 TAUMX4=CKIN(22)*CKIN(24)
26849C...5) due to limits on xF
26850 TAUMN5=0D0
26851 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
26852C...6) due to limits on that and uhat
26853 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
26854 TAUMX6=1D0
26855 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
26856 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
26857
26858C...Net effect of all separate limits.
26859 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
26860 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
26861 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
26862 VINT(11)=1D0-1D-9
26863 VINT(31)=1D0+1D-9
26864 ELSEIF(MINT(47).EQ.5) THEN
26865 VINT(31)=MIN(VINT(31),1D0-2D-10)
26866 ELSEIF(MINT(47).GE.6) THEN
26867 VINT(31)=MIN(VINT(31),1D0-1D-10)
26868 ENDIF
26869 IF(VINT(31).LE.VINT(11)) MINT(51)=1
26870
26871 ELSEIF(ILIM.EQ.2) THEN
26872C...Calculate limits on y*
26873 TAUE=TAU
26874 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
26875 TAURT=SQRT(TAUE)
26876C...0) due to kinematics
26877 YSTMN0=LOG(TAURT)
26878 YSTMX0=-YSTMN0
26879C...1) due to explicit limits
26880 YSTMN1=CKIN(7)
26881 YSTMX1=CKIN(8)
26882C...2) due to limits on x1
26883 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
26884 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
26885C...3) due to limits on x2
26886 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
26887 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
26888C...4) due to limits on xF
26889 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
26890 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
26891 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
26892 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
26893C...5) due to simultaneous limits on y-large and y-small
26894 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
26895 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
26896 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
26897 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
26898 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
26899 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
26900C...6) due to simultaneous limits on cos(theta-hat) and y-large or
26901C... y-small
26902 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
26903 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
26904 RZMX=BE34*MIN(CKIN(28),CTHLIM)
26905 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
26906 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
26907 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
26908 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
26909 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
26910 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
26911
26912C...Net effect of all separate limits.
26913 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
26914 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
26915 IF(MINT(47).EQ.1) THEN
26916 VINT(12)=-1D-9
26917 VINT(32)=1D-9
26918 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
26919 VINT(12)=(1D0-1D-9)*YSTMX0
26920 VINT(32)=(1D0+1D-9)*YSTMX0
26921 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
26922 VINT(12)=-(1D0+1D-9)*YSTMX0
26923 VINT(32)=-(1D0-1D-9)*YSTMX0
26924 ELSEIF(MINT(47).EQ.5) THEN
26925 YSTEE=LOG((1D0-1D-10)/TAURT)
26926 VINT(12)=MAX(VINT(12),-YSTEE)
26927 VINT(32)=MIN(VINT(32),YSTEE)
26928 ENDIF
26929 IF(VINT(32).LE.VINT(12)) MINT(51)=1
26930
26931 ELSEIF(ILIM.EQ.3) THEN
26932C...Calculate limits on cos(theta-hat)
26933 YST=VINT(22)
26934C...0) due to definition
26935 CTNMN0=-1D0
26936 CTNMX0=0D0
26937 CTPMN0=0D0
26938 CTPMX0=1D0
26939C...1) due to explicit limits
26940 CTNMN1=MIN(0D0,CKIN(27))
26941 CTNMX1=MIN(0D0,CKIN(28))
26942 CTPMN1=MAX(0D0,CKIN(27))
26943 CTPMX1=MAX(0D0,CKIN(28))
26944C...2) due to limits on pT-hat
26945 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
26946 CTPMX2=-CTNMN2
26947 CTNMX2=0D0
26948 CTPMN2=0D0
26949 IF(CKIN(4).GE.0D0) THEN
26950 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
26951 & (BE34**2*TAU*VINT(2))))
26952 CTPMN2=-CTNMX2
26953 ENDIF
26954C...3) due to limits on y-large and y-small
26955 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
26956 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
26957 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
26958 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
26959 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
26960 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
26961 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
26962 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
26963C...4) due to limits on that
26964 CTNMN4=-1D0
26965 CTNMX4=0D0
26966 CTPMN4=0D0
26967 CTPMX4=1D0
26968 SH=TAU*VINT(2)
26969 IF(CKIN(35).GT.0D0) THEN
26970 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
26971 IF(CTLIM.GT.0D0) THEN
26972 CTPMX4=CTLIM
26973 ELSE
26974 CTPMX4=0D0
26975 CTNMX4=CTLIM
26976 ENDIF
26977 ENDIF
26978 IF(CKIN(36).GT.0D0) THEN
26979 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
26980 IF(CTLIM.LT.0D0) THEN
26981 CTNMN4=CTLIM
26982 ELSE
26983 CTNMN4=0D0
26984 CTPMN4=CTLIM
26985 ENDIF
26986 ENDIF
26987C...5) due to limits on uhat
26988 CTNMN5=-1D0
26989 CTNMX5=0D0
26990 CTPMN5=0D0
26991 CTPMX5=1D0
26992 IF(CKIN(37).GT.0D0) THEN
26993 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
26994 IF(CTLIM.LT.0D0) THEN
26995 CTNMN5=CTLIM
26996 ELSE
26997 CTNMN5=0D0
26998 CTPMN5=CTLIM
26999 ENDIF
27000 ENDIF
27001 IF(CKIN(38).GT.0D0) THEN
27002 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27003 IF(CTLIM.GT.0D0) THEN
27004 CTPMX5=CTLIM
27005 ELSE
27006 CTPMX5=0D0
27007 CTNMX5=CTLIM
27008 ENDIF
27009 ENDIF
27010
27011C...Net effect of all separate limits.
27012 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27013 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27014 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27015 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27016 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27017
27018 ELSEIF(ILIM.EQ.4) THEN
27019C...Calculate limits on tau'
27020C...0) due to kinematics
27021 TAPMN0=TAU
27022 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27023 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27024 TAPMN0=(SQRT(TAU)+PQRAT)**2
27025 ENDIF
27026 TAPMX0=1D0
27027C...1) due to explicit limits
27028 TAPMN1=CKIN(31)**2/VINT(2)
27029 TAPMX1=1D0
27030 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27031
27032C...Net effect of all separate limits.
27033 VINT(16)=MAX(TAPMN0,TAPMN1)
27034 VINT(36)=MIN(TAPMX0,TAPMX1)
27035 IF(MINT(47).EQ.1) THEN
27036 VINT(16)=1D0-1D-9
27037 VINT(36)=1D0+1D-9
27038 ELSEIF(MINT(47).EQ.5) THEN
27039 VINT(36)=MIN(VINT(36),1D0-2D-10)
27040 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27041 VINT(36)=MIN(VINT(36),1D0-1D-10)
27042 ENDIF
27043 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27044
27045 ENDIF
27046 RETURN
27047
27048C...Special case for low-pT and multiple interactions:
27049C...effective kinematical limits for tau, y*, cos(theta-hat).
27050 100 IF(ILIM.EQ.0) THEN
27051 ELSEIF(ILIM.EQ.1) THEN
27052 IF(MSTP(82).LE.1) THEN
27053 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27054 & VINT(2)
27055 ELSE
27056 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27057 ENDIF
27058 VINT(31)=1D0
27059 ELSEIF(ILIM.EQ.2) THEN
27060 VINT(12)=0.5D0*LOG(VINT(21))
27061 VINT(32)=-VINT(12)
27062 ELSEIF(ILIM.EQ.3) THEN
27063 IF(MSTP(82).LE.1) THEN
27064 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27065 & (VINT(21)*VINT(2))
27066 ELSE
27067 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27068 & (VINT(21)*VINT(2))
27069 ENDIF
27070 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27071 VINT(33)=0D0
27072 VINT(14)=0D0
27073 VINT(34)=-VINT(13)
27074 ENDIF
27075
27076 RETURN
27077 END
27078
27079C*********************************************************************
27080
27081C...PYKMAP
27082C...Maps a uniform distribution into a distribution of a kinematical
27083C...variable according to one of the possibilities allowed. It is
27084C...assumed that kinematical limits have been set by a PYKLIM call.
27085
27086 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27087
27088C...Double precision and integer declarations.
27089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27090 IMPLICIT INTEGER(I-N)
27091 INTEGER PYK,PYCHGE,PYCOMP
27092C...Commonblocks.
27093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27094 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27095 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27096 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27097 COMMON/PYINT1/MINT(400),VINT(400)
27098 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27099 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
27100
27101C...Convert VVAR to tau variable.
27102 ISUB=MINT(1)
27103 ISTSB=ISET(ISUB)
27104 IF(IVAR.EQ.1) THEN
27105 TAUMIN=VINT(11)
27106 TAUMAX=VINT(31)
27107 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
27108 TAURE=VINT(73)
27109 GAMRE=VINT(74)
27110 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
27111 TAURE=VINT(75)
27112 GAMRE=VINT(76)
27113 ENDIF
27114 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27115 TAU=1D0
27116 ELSEIF(MVAR.EQ.1) THEN
27117 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
27118 ELSEIF(MVAR.EQ.2) THEN
27119 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
27120 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN
27121 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
27122 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
27123 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN
27124 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
27125 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
27126 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
27127 ELSEIF(MINT(47).EQ.5) THEN
27128 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
27129 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
27130 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27131 ELSE
27132 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
27133 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
27134 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27135 ENDIF
27136 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
27137
27138C...Convert VVAR to y* variable.
27139 ELSEIF(IVAR.EQ.2) THEN
27140 YSTMIN=VINT(12)
27141 YSTMAX=VINT(32)
27142 TAUE=VINT(21)
27143 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27144 IF(MINT(47).EQ.1) THEN
27145 YST=0D0
27146 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27147 YST=-0.5D0*LOG(TAUE)
27148 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27149 YST=0.5D0*LOG(TAUE)
27150 ELSEIF(MVAR.EQ.1) THEN
27151 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
27152 ELSEIF(MVAR.EQ.2) THEN
27153 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
27154 ELSEIF(MVAR.EQ.3) THEN
27155 AUPP=ATAN(EXP(YSTMAX))
27156 ALOW=ATAN(EXP(YSTMIN))
27157 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
27158 ELSEIF(MVAR.EQ.4) THEN
27159 YST0=-0.5D0*LOG(TAUE)
27160 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
27161 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
27162 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
27163 ELSE
27164 YST0=-0.5D0*LOG(TAUE)
27165 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
27166 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
27167 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
27168 ENDIF
27169 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
27170
27171C...Convert VVAR to cos(theta-hat) variable.
27172 ELSEIF(IVAR.EQ.3) THEN
27173 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
27174 RSQM=1D0+RM34
27175 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27176 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27177 CTNMIN=VINT(13)
27178 CTNMAX=VINT(33)
27179 CTPMIN=VINT(14)
27180 CTPMAX=VINT(34)
27181 IF(MVAR.EQ.1) THEN
27182 ANEG=CTNMAX-CTNMIN
27183 APOS=CTPMAX-CTPMIN
27184 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27185 VCTN=VVAR*(ANEG+APOS)/ANEG
27186 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
27187 ELSE
27188 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27189 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
27190 ENDIF
27191 ELSEIF(MVAR.EQ.2) THEN
27192 RMNMIN=MAX(RM34,RSQM-CTNMIN)
27193 RMNMAX=MAX(RM34,RSQM-CTNMAX)
27194 RMPMIN=MAX(RM34,RSQM-CTPMIN)
27195 RMPMAX=MAX(RM34,RSQM-CTPMAX)
27196 ANEG=LOG(RMNMIN/RMNMAX)
27197 APOS=LOG(RMPMIN/RMPMAX)
27198 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27199 VCTN=VVAR*(ANEG+APOS)/ANEG
27200 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
27201 ELSE
27202 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27203 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
27204 ENDIF
27205 ELSEIF(MVAR.EQ.3) THEN
27206 RMNMIN=MAX(RM34,RSQM+CTNMIN)
27207 RMNMAX=MAX(RM34,RSQM+CTNMAX)
27208 RMPMIN=MAX(RM34,RSQM+CTPMIN)
27209 RMPMAX=MAX(RM34,RSQM+CTPMAX)
27210 ANEG=LOG(RMNMAX/RMNMIN)
27211 APOS=LOG(RMPMAX/RMPMIN)
27212 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27213 VCTN=VVAR*(ANEG+APOS)/ANEG
27214 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
27215 ELSE
27216 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27217 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
27218 ENDIF
27219 ELSEIF(MVAR.EQ.4) THEN
27220 RMNMIN=MAX(RM34,RSQM-CTNMIN)
27221 RMNMAX=MAX(RM34,RSQM-CTNMAX)
27222 RMPMIN=MAX(RM34,RSQM-CTPMIN)
27223 RMPMAX=MAX(RM34,RSQM-CTPMAX)
27224 ANEG=1D0/RMNMAX-1D0/RMNMIN
27225 APOS=1D0/RMPMAX-1D0/RMPMIN
27226 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27227 VCTN=VVAR*(ANEG+APOS)/ANEG
27228 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
27229 ELSE
27230 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27231 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
27232 ENDIF
27233 ELSEIF(MVAR.EQ.5) THEN
27234 RMNMIN=MAX(RM34,RSQM+CTNMIN)
27235 RMNMAX=MAX(RM34,RSQM+CTNMAX)
27236 RMPMIN=MAX(RM34,RSQM+CTPMIN)
27237 RMPMAX=MAX(RM34,RSQM+CTPMAX)
27238 ANEG=1D0/RMNMIN-1D0/RMNMAX
27239 APOS=1D0/RMPMIN-1D0/RMPMAX
27240 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
27241 VCTN=VVAR*(ANEG+APOS)/ANEG
27242 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
27243 ELSE
27244 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
27245 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
27246 ENDIF
27247 ENDIF
27248 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
27249 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
27250 VINT(23)=CTH
27251
27252C...Convert VVAR to tau' variable.
27253 ELSEIF(IVAR.EQ.4) THEN
27254 TAU=VINT(21)
27255 TAUPMN=VINT(16)
27256 TAUPMX=VINT(36)
27257 IF(MINT(47).EQ.1) THEN
27258 TAUP=1D0
27259 ELSEIF(MVAR.EQ.1) THEN
27260 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
27261 ELSEIF(MVAR.EQ.2) THEN
27262 AUPP=(1D0-TAU/TAUPMX)**4
27263 ALOW=(1D0-TAU/TAUPMN)**4
27264 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
27265 ELSEIF(MINT(47).EQ.5) THEN
27266 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
27267 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
27268 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27269 ELSE
27270 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
27271 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
27272 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
27273 ENDIF
27274 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
27275
27276C...Selection of extra variables needed in 2 -> 3 process:
27277C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
27278C...Since no options are available, the functions of PYKLIM
27279C...and PYKMAP are joint for these choices.
27280 ELSEIF(IVAR.EQ.5) THEN
27281
27282C...Read out total energy and particle masses.
27283 MINT(51)=0
27284 MPTPK=1
27285 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
27286 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
27287 & MPTPK=2
27288 SHP=VINT(26)*VINT(2)
27289 SHPR=SQRT(SHP)
27290 PM1=VINT(201)
27291 PM2=VINT(206)
27292 PM3=SQRT(VINT(21))*VINT(1)
27293 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
27294 MINT(51)=1
27295 RETURN
27296 ENDIF
27297 PMRS1=VINT(204)**2
27298 PMRS2=VINT(209)**2
27299
27300C...Specify coefficients of pT choice; upper and lower limits.
27301 IF(MPTPK.EQ.1) THEN
27302 HWT1=0.4D0
27303 HWT2=0.4D0
27304 ELSE
27305 HWT1=0.05D0
27306 HWT2=0.05D0
27307 ENDIF
27308 HWT3=1D0-HWT1-HWT2
27309 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
27310 & (4D0*SHP)
27311 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
27312 PTSMN1=CKIN(51)**2
27313 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
27314 & (4D0*SHP)
27315 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
27316 PTSMN2=CKIN(53)**2
27317
27318C...Select transverse momenta according to
27319C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
27320 HMX=PMRS1+PTSMX1
27321 HMN=PMRS1+PTSMN1
27322 IF(HMX.LT.1.0001D0*HMN) THEN
27323 MINT(51)=1
27324 RETURN
27325 ENDIF
27326 HDE=PTSMX1-PTSMN1
27327 RPT=PYR(0)
27328 IF(RPT.LT.HWT1) THEN
27329 PTS1=PTSMN1+PYR(0)*HDE
27330 ELSEIF(RPT.LT.HWT1+HWT2) THEN
27331 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
27332 ELSE
27333 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
27334 ENDIF
27335 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
27336 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
27337 HMX=PMRS2+PTSMX2
27338 HMN=PMRS2+PTSMN2
27339 IF(HMX.LT.1.0001D0*HMN) THEN
27340 MINT(51)=1
27341 RETURN
27342 ENDIF
27343 HDE=PTSMX2-PTSMN2
27344 RPT=PYR(0)
27345 IF(RPT.LT.HWT1) THEN
27346 PTS2=PTSMN2+PYR(0)*HDE
27347 ELSEIF(RPT.LT.HWT1+HWT2) THEN
27348 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
27349 ELSE
27350 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
27351 ENDIF
27352 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
27353 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
27354
27355C...Select azimuthal angles and check pT choice.
27356 PHI1=PARU(2)*PYR(0)
27357 PHI2=PARU(2)*PYR(0)
27358 PHIR=PHI2-PHI1
27359 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
27360 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
27361 & CKIN(56)**2)) THEN
27362 MINT(51)=1
27363 RETURN
27364 ENDIF
27365
27366C...Calculate transverse masses and check phase space not closed.
27367 PMS1=PM1**2+PTS1
27368 PMS2=PM2**2+PTS2
27369 PMS3=PM3**2+PTS3
27370 PMT1=SQRT(PMS1)
27371 PMT2=SQRT(PMS2)
27372 PMT3=SQRT(PMS3)
27373 PM12=(PMT1+PMT2)**2
27374 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
27375 MINT(51)=1
27376 RETURN
27377 ENDIF
27378
27379C...Select rapidity for particle 3 and check phase space not closed.
27380 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
27381 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
27382 IF(Y3MAX.LT.1D-6) THEN
27383 MINT(51)=1
27384 RETURN
27385 ENDIF
27386 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
27387 PZ3=PMT3*SINH(Y3)
27388 PE3=PMT3*COSH(Y3)
27389
27390C...Find momentum transfers in two mirror solutions (in 1-2 frame).
27391 PZ12=-PZ3
27392 PE12=SHPR-PE3
27393 PMS12=PE12**2-PZ12**2
27394 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
27395 IF(SQL12.LT.1D-6*SHP) THEN
27396 MINT(51)=1
27397 RETURN
27398 ENDIF
27399 PMM1=PMS12+PMS1-PMS2
27400 PMM2=PMS12+PMS2-PMS1
27401 TFAC=-SHPR/(2D0*PMS12)
27402 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
27403 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
27404 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
27405 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
27406
27407C...Construct relative mirror weights and make choice.
27408 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
27409 WTPU=1D0
27410 WTNU=1D0
27411 ELSE
27412 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
27413 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
27414 ENDIF
27415 WTP=WTPU/(WTPU+WTNU)
27416 WTN=WTNU/(WTPU+WTNU)
27417 EPS=1D0
27418 IF(WTN.GT.PYR(0)) EPS=-1D0
27419
27420C...Store result of variable choice and associated weights.
27421 VINT(202)=PTS1
27422 VINT(207)=PTS2
27423 VINT(203)=PHI1
27424 VINT(208)=PHI2
27425 VINT(205)=WTPTS1
27426 VINT(210)=WTPTS2
27427 VINT(211)=Y3
27428 VINT(212)=Y3MAX
27429 VINT(213)=EPS
27430 IF(EPS.GT.0D0) THEN
27431 VINT(214)=1D0/WTP
27432 VINT(215)=T1P
27433 VINT(216)=T2P
27434 ELSE
27435 VINT(214)=1D0/WTN
27436 VINT(215)=T1N
27437 VINT(216)=T2N
27438 ENDIF
27439 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
27440 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
27441 VINT(219)=0.5D0*(PMS12-PTS3)
27442 VINT(220)=SQL12
27443 ENDIF
27444
27445 RETURN
27446 END
27447
27448C***********************************************************************
27449
27450C...PYSIGH
27451C...Differential matrix elements for all included subprocesses
27452C...Note that what is coded is (disregarding the COMFAC factor)
27453C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
27454C...when d(sigma-hat) is given in the zero-width limit, the delta
27455C...function in tau is replaced by a (modified) Breit-Wigner:
27456C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
27457C...where H_res = s-hat/m_res*Gamma_res(s-hat);
27458C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
27459C...i.e., dimensionless quantities
27460C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
27461C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
27462C...(2pi)^4 delta^4(P - sum p_i)
27463C...COMFAC contains the factor pi/s (or equivalent) and
27464C...the conversion factor from GeV^-2 to mb
27465
27466 SUBROUTINE PYSIGH(NCHN,SIGS)
27467
27468C...Double precision and integer declarations
27469 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27470 IMPLICIT INTEGER(I-N)
27471 INTEGER PYK,PYCHGE,PYCOMP
27472C...Parameter statement to help give large particle numbers.
27473 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
27474 &KEXCIT=4000000,KDIMEN=5000000)
27475C...Commonblocks
27476 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27477 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27478 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27479 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27480 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27481 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27482 COMMON/PYINT1/MINT(400),VINT(400)
27483 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27484 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
27485 COMMON/PYINT4/MWID(500),WIDS(500,5)
27486 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27487 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
27488 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
27489 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
27490 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
27491 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
27492 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
27493 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
27494 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
27495 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
27496 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27497 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
27498 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
27499C...Local arrays and complex variables
27500 DIMENSION XPQ(-25:25)
27501
27502C...Map of processes onto which routine to call
27503C...in order to evaluate cross section:
27504C...0 = not implemented;
27505C...1 = standard QCD (including photons);
27506C...2 = heavy flavours;
27507C...3 = W/Z;
27508C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
27509C...5 = SUSY;
27510C...6 = Technicolor;
27511C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
27512 DIMENSION MAPPR(500)
27513 DATA (MAPPR(I),I=1,180)/
27514 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
27515 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
27516 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
27517 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
27518 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
27519 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
27520 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
27521 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
27522 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
27523 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
27524 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
27525 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
27526 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
27527 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
27528 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
27529 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
27530 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
27531 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
27532 DATA (MAPPR(I),I=181,500)/
27533 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
27534 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
27535 & 100*5,
27536 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
27537 1 30*0,
27538 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
27539 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
27540 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
27541 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0,
27542 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
27543 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
27544 & 4, 4, 18*0,
27545 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
27546 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
27547 4 20*0,
27548 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
27549 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
27550 8 20*0/
27551
27552C...Reset number of channels and cross-section
27553 NCHN=0
27554 SIGS=0D0
27555
27556C...Read process to consider.
27557 ISUB=MINT(1)
27558 ISUBSV=ISUB
27559 MAP=MAPPR(ISUB)
27560
27561C...Read kinematical variables and limits
27562 ISTSB=ISET(ISUBSV)
27563 TAUMIN=VINT(11)
27564 YSTMIN=VINT(12)
27565 CTNMIN=VINT(13)
27566 CTPMIN=VINT(14)
27567 TAUPMN=VINT(16)
27568 TAU=VINT(21)
27569 YST=VINT(22)
27570 CTH=VINT(23)
27571 XT2=VINT(25)
27572 TAUP=VINT(26)
27573 TAUMAX=VINT(31)
27574 YSTMAX=VINT(32)
27575 CTNMAX=VINT(33)
27576 CTPMAX=VINT(34)
27577 TAUPMX=VINT(36)
27578
27579C...Derive kinematical quantities
27580 TAUE=TAU
27581 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27582 X(1)=SQRT(TAUE)*EXP(YST)
27583 X(2)=SQRT(TAUE)*EXP(-YST)
27584 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
27585 IF(X(1).GT.1D0-1D-7) RETURN
27586 ELSEIF(MINT(45).EQ.3) THEN
27587 X(1)=MIN(1D0-1.1D-10,X(1))
27588 ENDIF
27589 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
27590 IF(X(2).GT.1D0-1D-7) RETURN
27591 ELSEIF(MINT(46).EQ.3) THEN
27592 X(2)=MIN(1D0-1.1D-10,X(2))
27593 ENDIF
27594 SH=MAX(1D0,TAU*VINT(2))
27595 SQM3=VINT(63)
27596 SQM4=VINT(64)
27597 RM3=SQM3/SH
27598 RM4=SQM4/SH
27599 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27600 RPTS=4D0*VINT(71)**2/SH
27601 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27602 RM34=MAX(1D-20,2D0*RM3*RM4)
27603 RSQM=1D0+RM34
27604 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
27605 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
27606 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27607 IF(ISTSB.EQ.0) THEN
27608 TH=VINT(45)
27609 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27610 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
27611 ELSE
27612C...Kinematics with incoming masses tricky: now depends on how
27613C...subprocess has been set up w.r.t. order of incoming partons.
27614 RM1=0D0
27615 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
27616 RM2=0D0
27617 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
27618 IF(ISUB.EQ.35) THEN
27619 RM2=MIN(RM1,RM2)
27620 RM1=0D0
27621 ENDIF
27622 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27623 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
27624 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
27625 & BE12*BE34*CTH)
27626 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
27627 & BE12*BE34*CTH)
27628 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
27629 ENDIF
27630 SHR=SQRT(SH)
27631 SH2=SH**2
27632 TH2=TH**2
27633 UH2=UH**2
27634
27635C...Choice of Q2 scale for hard process (e.g. alpha_s).
27636 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
27637 Q2=SH
27638 ELSEIF(ISTSB.EQ.8) THEN
27639 IF(MINT(107).EQ.4) Q2=VINT(307)
27640 IF(MINT(108).EQ.4) Q2=VINT(308)
27641 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
27642 Q2IN1=0D0
27643 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
27644 Q2IN2=0D0
27645 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
27646 IF(MSTP(32).EQ.1) THEN
27647 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
27648 ELSEIF(MSTP(32).EQ.2) THEN
27649 Q2=SQPTH+0.5D0*(SQM3+SQM4)
27650 ELSEIF(MSTP(32).EQ.3) THEN
27651 Q2=MIN(-TH,-UH)
27652 ELSEIF(MSTP(32).EQ.4) THEN
27653 Q2=SH
27654 ELSEIF(MSTP(32).EQ.5) THEN
27655 Q2=-TH
27656 ELSEIF(MSTP(32).EQ.6) THEN
27657 XSF1=X(1)
27658 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
27659 XSF2=X(2)
27660 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
27661 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
27662 & (SQPTH+0.5D0*(SQM3+SQM4))
27663 ELSEIF(MSTP(32).EQ.7) THEN
27664 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
27665 ELSEIF(MSTP(32).EQ.8) THEN
27666 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
27667 ELSEIF(MSTP(32).EQ.9) THEN
27668 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
27669 ELSEIF(MSTP(32).EQ.10) THEN
27670 Q2=VINT(2)
27671C..Begin JA 040914
27672 ELSEIF(MSTP(32).EQ.11) THEN
27673 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
27674 ELSEIF(MSTP(32).EQ.12) THEN
27675 Q2=PARP(193)
27676C..End JA
27677 ELSEIF(MSTP(32).EQ.13) THEN
27678 Q2=SQPTH
27679 ENDIF
27680 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
27681 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
27682 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
27683 ENDIF
27684
27685C...Choice of Q2 scale for parton densities.
27686 Q2SF=Q2
27687C..Begin JA 040914
27688 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
27689 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
27690 & Q2=PARP(194)
27691C..End JA
27692 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27693 Q2SF=PMAS(23,1)**2
27694 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
27695 & ISUB.EQ.351) Q2SF=PMAS(24,1)**2
27696 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
27697 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
27698 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
27699 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
27700 IF(MSTP(39).EQ.2) Q2SF=
27701 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
27702 IF(MSTP(39).EQ.3) Q2SF=SH
27703 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
27704 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
27705C..Begin JA 040914
27706 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
27707 IF(MSTP(39).EQ.7) Q2SF=
27708 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
27709 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
27710C..End JA
27711 ENDIF
27712 ENDIF
27713 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
27714
27715 Q2PS=Q2SF
27716 Q2SF=Q2SF*PARP(34)
27717 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
27718 IF(MSTP(69).GE.2) Q2SF=VINT(2)
27719
27720C...Identify to which class(es) subprocess belongs
27721 ISMECR=0
27722 ISQCD=0
27723 ISJETS=0
27724 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.102.OR.
27725 & ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144.OR.
27726 & ISUBSV.EQ.152.OR.ISUBSV.EQ.157) ISMECR=1
27727 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
27728 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
27729 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
27730 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
27731 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
27732 IF (ISTSB.EQ.9) ISQCD=1
27733 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
27734 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
27735 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
27736 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
27737 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
27738 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
27739 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
27740 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
27741C...WBF is special case of ISJETS
27742 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
27743 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
27744 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
27745 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
27746 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
27747 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
27748 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
27749 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
27750 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
27751C...Some processes with photons also belong here.
27752 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
27753 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
27754 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
27755 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
27756 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
27757 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
27758
27759C...Choice of Q2 scale for parton-shower activity.
27760 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
27761 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
27762 XBJ=X(2)
27763 IF(MINT(43).EQ.3) XBJ=X(1)
27764 IF(MSTP(22).EQ.1) THEN
27765 Q2PS=-TH
27766 ELSEIF(MSTP(22).EQ.2) THEN
27767 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
27768 ELSEIF(MSTP(22).EQ.3) THEN
27769 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
27770 ELSE
27771 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
27772 ENDIF
27773 ENDIF
27774C...For multiple interactions, start from scale defined above
27775C...For all other QCD or "+jets"-type events, start shower from pThard.
27776 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
27777 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
27778C...Max shower scale = s for ME corrected processes.
27779C...(pT-ordering: max pT2 is s/4)
27780 Q2PS=VINT(2)
27781 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
27782 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
27783C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
27784C...(pT-ordering: max pT2 is s/4)
27785 Q2PS=VINT(2)
27786 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
27787 ENDIF
27788 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
27789
27790C...Elastic and diffractive events not associated with scales so set 0.
27791 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
27792 Q2SF=0D0
27793 Q2PS=0D0
27794 ENDIF
27795
27796C...Store derived kinematical quantities
27797 VINT(41)=X(1)
27798 VINT(42)=X(2)
27799 VINT(44)=SH
27800 VINT(43)=SQRT(SH)
27801 VINT(45)=TH
27802 VINT(46)=UH
27803 IF(ISTSB.NE.8) VINT(48)=SQPTH
27804 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
27805 VINT(50)=TAUP*VINT(2)
27806 VINT(49)=SQRT(MAX(0D0,VINT(50)))
27807 VINT(52)=Q2
27808 VINT(51)=SQRT(Q2)
27809 VINT(54)=Q2SF
27810 VINT(53)=SQRT(Q2SF)
27811 VINT(56)=Q2PS
27812 VINT(55)=SQRT(Q2PS)
27813
27814C...Set starting scale for multiple interactions
27815 IF (ISUBSV.EQ.95) THEN
27816 XT2GMX=0D0
27817 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
27818 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
27819 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
27820 & ISUBSV.NE.96)) THEN
27821C...All accessible phase space allowed.
27822 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
27823 ELSE
27824C...Scale of hard process sets limit.
27825C...2 -> 1. Limit is tau = x1*x2.
27826C...2 -> 2. Limit is XT2 for hard process + FS masses.
27827C...2 -> n > 2. Limit is tau' = tau of outer process.
27828 XT2GMX=VINT(25)
27829 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
27830 IF(ISTSB.EQ.2)
27831 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
27832 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
27833 ENDIF
27834 VINT(62)=0.25D0*XT2GMX*VINT(2)
27835 VINT(61)=SQRT(MAX(0D0,VINT(62)))
27836
27837C...Calculate parton distributions
27838 IF(ISTSB.LE.0) GOTO 160
27839 IF(MINT(47).GE.2) THEN
27840 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
27841 XSF=X(I)
27842 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
27843 IF(ISUB.EQ.99) THEN
27844 IF(MINT(140+I).EQ.0) THEN
27845 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
27846 ELSE
27847 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
27848 ENDIF
27849 VINT(40+I)=XSF
27850 Q2SF=VINT(309-I)
27851 ENDIF
27852 MINT(105)=MINT(102+I)
27853 MINT(109)=MINT(106+I)
27854 VINT(120)=VINT(2+I)
27855 IF(MSTP(57).LE.1) THEN
27856 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
27857 ELSE
27858 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
27859 ENDIF
27860C...Safety margin against heavy flavour very close to threshold,
27861C...e.g. caused by mismatch in c and b masses.
27862 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
27863 XPQ(4)=0D0
27864 XPQ(-4)=0D0
27865 ENDIF
27866 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
27867 XPQ(5)=0D0
27868 XPQ(-5)=0D0
27869 ENDIF
27870 DO 100 KFL=-25,25
27871 XSFX(I,KFL)=XPQ(KFL)
27872 100 CONTINUE
27873 110 CONTINUE
27874 ENDIF
27875
27876C...Calculate alpha_em, alpha_strong and K-factor
27877 XW=PARU(102)
27878 XWV=XW
27879 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
27880 &1D0-(PMAS(24,1)/PMAS(23,1))**2
27881 XW1=1D0-XW
27882 XWC=1D0/(16D0*XW*XW1)
27883 AEM=PYALEM(Q2)
27884 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
27885 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
27886 FACK=1D0
27887 FACA=1D0
27888 IF(MSTP(33).EQ.1) THEN
27889 FACK=PARP(31)
27890 ELSEIF(MSTP(33).EQ.2) THEN
27891 FACK=PARP(31)
27892 FACA=PARP(32)/PARP(31)
27893 ELSEIF(MSTP(33).EQ.3) THEN
27894 Q2AS=PARP(33)*Q2
27895 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
27896 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
27897 AS=PYALPS(Q2AS)
27898 ENDIF
27899 VINT(138)=1D0
27900 VINT(57)=AEM
27901 VINT(58)=AS
27902
27903C...Set flags for allowed reacting partons/leptons
27904 DO 140 I=1,2
27905 DO 120 J=-25,25
27906 KFAC(I,J)=0
27907 120 CONTINUE
27908 IF(MINT(44+I).EQ.1) THEN
27909 KFAC(I,MINT(10+I))=1
27910 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
27911 KFAC(I,MINT(10+I))=1
27912 KFAC(I,22)=1
27913 KFAC(I,24)=1
27914 KFAC(I,-24)=1
27915 ELSE
27916 DO 130 J=-25,25
27917 KFAC(I,J)=KFIN(I,J)
27918 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
27919 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
27920 130 CONTINUE
27921 ENDIF
27922 140 CONTINUE
27923
27924C...Lower and upper limit for fermion flavour loops
27925 MMIN1=0
27926 MMAX1=0
27927 MMIN2=0
27928 MMAX2=0
27929 DO 150 J=-20,20
27930 IF(KFAC(1,-J).EQ.1) MMIN1=-J
27931 IF(KFAC(1,J).EQ.1) MMAX1=J
27932 IF(KFAC(2,-J).EQ.1) MMIN2=-J
27933 IF(KFAC(2,J).EQ.1) MMAX2=J
27934 150 CONTINUE
27935 MMINA=MIN(MMIN1,MMIN2)
27936 MMAXA=MAX(MMAX1,MMAX2)
27937
27938C...Common resonance mass and width combinations
27939 SQMZ=PMAS(23,1)**2
27940 SQMW=PMAS(24,1)**2
27941 GMMZ=PMAS(23,1)*PMAS(23,2)
27942 GMMW=PMAS(24,1)*PMAS(24,2)
27943
27944C...Polarization factors...implemented so far for W+W-(25)
27945 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
27946 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
27947 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
27948 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
27949
27950C...Phase space integral in tau
27951 COMFAC=PARU(1)*PARU(5)/VINT(2)
27952 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
27953 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
27954 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
27955 ATAU1=LOG(TAUMAX/TAUMIN)
27956 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
27957 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
27958 IF(MINT(72).GE.1) THEN
27959 TAUR1=VINT(73)
27960 GAMR1=VINT(74)
27961 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
27962 ATAU3=ATAUD/TAUR1
27963 IF(ATAUD.GT.1D-10) H1=H1+
27964 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
27965 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
27966 ATAU4=ATAUD/GAMR1
27967 IF(ATAUD.GT.1D-10) H1=H1+
27968 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
27969 ENDIF
27970 IF(MINT(72).EQ.2) THEN
27971 TAUR2=VINT(75)
27972 GAMR2=VINT(76)
27973 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
27974 ATAU5=ATAUD/TAUR2
27975 IF(ATAUD.GT.1D-10) H1=H1+
27976 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
27977 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
27978 ATAU6=ATAUD/GAMR2
27979 IF(ATAUD.GT.1D-10) H1=H1+
27980 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
27981 ENDIF
27982 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
27983 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
27984 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
27985 & MAX(2D-10,1D0-TAU)
27986 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
27987 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
27988 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
27989 & MAX(1D-10,1D0-TAU)
27990 ENDIF
27991 COMFAC=COMFAC*ATAU1/(TAU*H1)
27992 ENDIF
27993
27994C...Phase space integral in y*
27995 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
27996 &THEN
27997 AYST0=YSTMAX-YSTMIN
27998 IF(AYST0.LT.1D-10) THEN
27999 COMFAC=0D0
28000 ELSE
28001 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28002 AYST2=AYST1
28003 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28004 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28005 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28006 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28007 IF(MINT(45).EQ.3) THEN
28008 YST0=-0.5D0*LOG(TAUE)
28009 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28010 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28011 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28012 & MAX(1D-10,1D0-EXP(YST-YST0))
28013 ENDIF
28014 IF(MINT(46).EQ.3) THEN
28015 YST0=-0.5D0*LOG(TAUE)
28016 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28017 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28018 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28019 & MAX(1D-10,1D0-EXP(-YST-YST0))
28020 ENDIF
28021 COMFAC=COMFAC*AYST0/H2
28022 ENDIF
28023 ENDIF
28024
28025C...2 -> 1 processes: reduction in angular part of phase space integral
28026C...for case of decaying resonance
28027 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28028 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28029 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28030 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28031 & KFPR(ISUB,1).EQ.39) THEN
28032 COMFAC=COMFAC*0.5D0*ACTH0
28033 ELSE
28034 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28035 & CTPMAX**3-CTPMIN**3)
28036 ENDIF
28037 ENDIF
28038
28039C...2 -> 2 processes: angular part of phase space integral
28040 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28041 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28042 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28043 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28044 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28045 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28046 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28047 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28048 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28049 H3=COEF(ISUBSV,13)+
28050 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28051 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28052 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28053 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28054 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28055
28056C...2 -> 2 processes: take into account final state Breit-Wigners
28057 COMFAC=COMFAC*VINT(80)
28058 ENDIF
28059
28060C...2 -> 3, 4 processes: phace space integral in tau'
28061 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28062 ATAUP1=LOG(TAUPMX/TAUPMN)
28063 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28064 H4=COEF(ISUBSV,18)+
28065 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28066 IF(MINT(47).EQ.5) THEN
28067 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28068 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28069 ELSEIF(MINT(47).GE.6) THEN
28070 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28071 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28072 ENDIF
28073 COMFAC=COMFAC*ATAUP1/H4
28074 ENDIF
28075
28076C...2 -> 3, 4 processes: effective W/Z parton distributions
28077 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28078 IF(1D0-TAU/TAUP.GT.1D-4) THEN
28079 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
28080 ELSE
28081 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
28082 ENDIF
28083 COMFAC=COMFAC*FZW
28084 ENDIF
28085
28086C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
28087 IF(ISTSB.EQ.5) THEN
28088 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
28089 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
28090 ENDIF
28091
28092C...Phase space integral for low-pT and multiple interactions
28093 IF(ISTSB.EQ.9) THEN
28094 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
28095 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
28096 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
28097 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
28098 COMFAC=COMFAC*ATAU1/H1
28099 AYST0=YSTMAX-YSTMIN
28100 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28101 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28102 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28103 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28104 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28105 COMFAC=COMFAC*AYST0/H2
28106 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
28107C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
28108C...introduced to make cross-section finite for xT2 -> 0
28109 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
28110 & (1D0+VINT(149)))
28111 ENDIF
28112
28113C...Real gamma + gamma: include factor 2 when different nature
28114 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
28115 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
28116
28117C...Extra factors to include the effects of
28118C...longitudinal resolved photons (but not direct or DIS ones).
28119 DO 170 ISDE=1,2
28120 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
28121 & MINT(106+ISDE).LE.3) THEN
28122 VINT(314+ISDE)=1D0
28123 XY=PARP(166+ISDE)
28124 IF(MSTP(16).EQ.0) THEN
28125 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
28126 & XY=VINT(304+ISDE)
28127 ELSE
28128 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
28129 & XY=VINT(308+ISDE)
28130 ENDIF
28131 Q2GA=VINT(306+ISDE)
28132 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
28133 & Q2GA.GT.0D0) THEN
28134 REDUCE=0D0
28135 IF(MSTP(17).EQ.1) THEN
28136 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
28137 ELSEIF(MSTP(17).EQ.2) THEN
28138 REDUCE=4D0*Q2GA/(Q2+Q2GA)
28139 ELSEIF(MSTP(17).EQ.3) THEN
28140 PMVIRT=PMAS(PYCOMP(113),1)
28141 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
28142 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
28143 PMVIRT=PMAS(PYCOMP(113),1)
28144 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
28145 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
28146 PMVIRT=PMAS(PYCOMP(113),1)
28147 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
28148 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
28149 PMVSMN=4D0*PARP(15)**2
28150 PMVSMX=4D0*VINT(154)**2
28151 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
28152 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
28153 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
28154 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
28155 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
28156 PMVIRT=PMAS(PYCOMP(113),1)
28157 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
28158 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
28159 PMVIRT=PMAS(PYCOMP(113),1)
28160 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
28161 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
28162 PMVSMN=4D0*PARP(15)**2
28163 PMVSMX=4D0*VINT(154)**2
28164 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
28165 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
28166 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
28167 ENDIF
28168 BEAMAS=PYMASS(11)
28169 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
28170 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
28171 & (1D0-2D0*BEAMAS**2/Q2GA))
28172 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
28173 ENDIF
28174 ELSE
28175 VINT(314+ISDE)=1D0
28176 ENDIF
28177 COMFAC=COMFAC*VINT(314+ISDE)
28178 170 CONTINUE
28179
28180C...Evaluate cross sections - done in separate routines by kind
28181C...of physics, to keep PYSIGH of sensible size.
28182 IF(MAP.EQ.1) THEN
28183C...Standard QCD (including photons).
28184 CALL PYSGQC(NCHN,SIGS)
28185 ELSEIF(MAP.EQ.2) THEN
28186C...Heavy flavours.
28187 CALL PYSGHF(NCHN,SIGS)
28188 ELSEIF(MAP.EQ.3) THEN
28189C...W/Z.
28190 CALL PYSGWZ(NCHN,SIGS)
28191 ELSEIF(MAP.EQ.4) THEN
28192C...Higgs (2 doublets; including longitudinal W/Z scattering).
28193 CALL PYSGHG(NCHN,SIGS)
28194 ELSEIF(MAP.EQ.5) THEN
28195C...SUSY.
28196 CALL PYSGSU(NCHN,SIGS)
28197 ELSEIF(MAP.EQ.6) THEN
28198C...Technicolor.
28199 CALL PYSGTC(NCHN,SIGS)
28200 ELSEIF(MAP.EQ.7) THEN
28201C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28202 CALL PYSGEX(NCHN,SIGS)
28203 ENDIF
28204
28205C...Multiply with parton distributions
28206 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
28207 DO 180 ICHN=1,NCHN
28208 IF(MINT(45).GE.2) THEN
28209 KFL1=ISIG(ICHN,1)
28210 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
28211 ENDIF
28212 IF(MINT(46).GE.2) THEN
28213 KFL2=ISIG(ICHN,2)
28214 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
28215 ENDIF
28216 SIGS=SIGS+SIGH(ICHN)
28217 180 CONTINUE
28218 ENDIF
28219
28220 RETURN
28221 END
28222
28223C*********************************************************************
28224
28225C...PYSGQC
28226C...Subprocess cross sections for QCD processes,
28227C...including photons.
28228C...Auxiliary to PYSIGH.
28229
28230 SUBROUTINE PYSGQC(NCHN,SIGS)
28231
28232C...Double precision and integer declarations
28233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28234 IMPLICIT INTEGER(I-N)
28235 INTEGER PYK,PYCHGE,PYCOMP
28236C...Parameter statement to help give large particle numbers.
28237 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28238 &KEXCIT=4000000,KDIMEN=5000000)
28239C...Commonblocks
28240 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28241 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28242 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28243 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28244 COMMON/PYINT1/MINT(400),VINT(400)
28245 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28246 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28247 COMMON/PYINT4/MWID(500),WIDS(500,5)
28248 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28249 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28250 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28251 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28252 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28253 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
28254 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
28255C...Local arrays
28256 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
28257
28258C...Differential cross section expressions.
28259
28260 IF(ISUB.LE.20) THEN
28261 IF(ISUB.EQ.10) THEN
28262C...f + f' -> f + f' (gamma/Z/W exchange)
28263 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
28264 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
28265 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
28266 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
28267 DO 110 I=MMIN1,MMAX1
28268 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
28269 IA=IABS(I)
28270 DO 100 J=MMIN2,MMAX2
28271 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
28272 JA=IABS(J)
28273C...Electroweak couplings
28274 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
28275 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
28276 VI=AI-4D0*EI*XWV
28277 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
28278 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
28279 VJ=AJ-4D0*EJ*XWV
28280 EPSIJ=ISIGN(1,I*J)
28281C...gamma/Z exchange, only gamma exchange, or only Z exchange
28282 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
28283 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
28284 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
28285 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
28286 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
28287 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
28288 ELSEIF(MSTP(21).EQ.2) THEN
28289 FACNCF=FACGGF*EI**2*EJ**2
28290 ELSE
28291 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
28292 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
28293 ENDIF
28294C...Extrafactor 2 for only one incoming neutrino spin state.
28295 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
28296 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
28297 NCHN=NCHN+1
28298 ISIG(NCHN,1)=I
28299 ISIG(NCHN,2)=J
28300 ISIG(NCHN,3)=1
28301 SIGH(NCHN)=FACNCF
28302 ENDIF
28303C...W exchange
28304 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
28305 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
28306 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
28307 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
28308 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
28309 NCHN=NCHN+1
28310 ISIG(NCHN,1)=I
28311 ISIG(NCHN,2)=J
28312 ISIG(NCHN,3)=2
28313 SIGH(NCHN)=FACCCF
28314 ENDIF
28315 100 CONTINUE
28316 110 CONTINUE
28317
28318 ELSEIF(ISUB.EQ.11) THEN
28319C...f + f' -> f + f' (g exchange)
28320 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
28321 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
28322 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
28323 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
28324 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
28325 DO 130 I=MMIN1,MMAX1
28326 IA=IABS(I)
28327 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
28328 DO 120 J=MMIN2,MMAX2
28329 JA=IABS(J)
28330 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
28331 NCHN=NCHN+1
28332 ISIG(NCHN,1)=I
28333 ISIG(NCHN,2)=J
28334 ISIG(NCHN,3)=1
28335 SIGH(NCHN)=FACQQ1
28336 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
28337 IF(I.EQ.J) THEN
28338 SIGH(NCHN)=0.5D0*SIGH(NCHN)
28339 NCHN=NCHN+1
28340 ISIG(NCHN,1)=I
28341 ISIG(NCHN,2)=J
28342 ISIG(NCHN,3)=2
28343 SIGH(NCHN)=0.5D0*FACQQ2
28344 ENDIF
28345 120 CONTINUE
28346 130 CONTINUE
28347
28348 ELSEIF(ISUB.EQ.12) THEN
28349C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
28350 CALL PYWIDT(21,SH,WDTP,WDTE)
28351 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
28352 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
28353 DO 140 I=MMINA,MMAXA
28354 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
28355 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
28356 NCHN=NCHN+1
28357 ISIG(NCHN,1)=I
28358 ISIG(NCHN,2)=-I
28359 ISIG(NCHN,3)=1
28360 SIGH(NCHN)=FACQQB
28361 140 CONTINUE
28362
28363 ELSEIF(ISUB.EQ.13) THEN
28364C...f + fbar -> g + g (q + qbar -> g + g only)
28365 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28366 & UH2/SH2)
28367 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28368 & TH2/SH2)
28369 DO 150 I=MMINA,MMAXA
28370 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
28371 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
28372 NCHN=NCHN+1
28373 ISIG(NCHN,1)=I
28374 ISIG(NCHN,2)=-I
28375 ISIG(NCHN,3)=1
28376 SIGH(NCHN)=0.5D0*FACGG1
28377 NCHN=NCHN+1
28378 ISIG(NCHN,1)=I
28379 ISIG(NCHN,2)=-I
28380 ISIG(NCHN,3)=2
28381 SIGH(NCHN)=0.5D0*FACGG2
28382 150 CONTINUE
28383
28384 ELSEIF(ISUB.EQ.14) THEN
28385C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
28386 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
28387 DO 160 I=MMINA,MMAXA
28388 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
28389 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
28390 EI=KCHG(IABS(I),1)/3D0
28391 NCHN=NCHN+1
28392 ISIG(NCHN,1)=I
28393 ISIG(NCHN,2)=-I
28394 ISIG(NCHN,3)=1
28395 SIGH(NCHN)=FACGG*EI**2
28396 160 CONTINUE
28397
28398 ELSEIF(ISUB.EQ.18) THEN
28399C...f + fbar -> gamma + gamma
28400 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
28401 DO 170 I=MMINA,MMAXA
28402 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
28403 EI=KCHG(IABS(I),1)/3D0
28404 FCOI=1D0
28405 IF(IABS(I).LE.10) FCOI=FACA/3D0
28406 NCHN=NCHN+1
28407 ISIG(NCHN,1)=I
28408 ISIG(NCHN,2)=-I
28409 ISIG(NCHN,3)=1
28410 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
28411 170 CONTINUE
28412 ENDIF
28413
28414 ELSEIF(ISUB.LE.40) THEN
28415 IF(ISUB.EQ.28) THEN
28416C...f + g -> f + g (q + g -> q + g only)
28417 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
28418 & UH/SH)*FACA
28419 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
28420 & SH/UH)
28421 DO 190 I=MMINA,MMAXA
28422 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
28423 DO 180 ISDE=1,2
28424 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
28425 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
28426 NCHN=NCHN+1
28427 ISIG(NCHN,ISDE)=I
28428 ISIG(NCHN,3-ISDE)=21
28429 ISIG(NCHN,3)=1
28430 SIGH(NCHN)=FACQG1
28431 NCHN=NCHN+1
28432 ISIG(NCHN,ISDE)=I
28433 ISIG(NCHN,3-ISDE)=21
28434 ISIG(NCHN,3)=2
28435 SIGH(NCHN)=FACQG2
28436 180 CONTINUE
28437 190 CONTINUE
28438
28439 ELSEIF(ISUB.EQ.29) THEN
28440C...f + g -> f + gamma (q + g -> q + gamma only)
28441 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
28442 DO 210 I=MMINA,MMAXA
28443 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
28444 EI=KCHG(IABS(I),1)/3D0
28445 FACGQ=FGQ*EI**2
28446 DO 200 ISDE=1,2
28447 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
28448 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
28449 NCHN=NCHN+1
28450 ISIG(NCHN,ISDE)=I
28451 ISIG(NCHN,3-ISDE)=21
28452 ISIG(NCHN,3)=1
28453 SIGH(NCHN)=FACGQ
28454 200 CONTINUE
28455 210 CONTINUE
28456
28457 ELSEIF(ISUB.EQ.33) THEN
28458C...f + gamma -> f + g (q + gamma -> q + g only)
28459 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
28460 DO 230 I=MMINA,MMAXA
28461 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
28462 EI=KCHG(IABS(I),1)/3D0
28463 FACGQ=FGQ*EI**2
28464 DO 220 ISDE=1,2
28465 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
28466 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
28467 NCHN=NCHN+1
28468 ISIG(NCHN,ISDE)=I
28469 ISIG(NCHN,3-ISDE)=22
28470 ISIG(NCHN,3)=1
28471 SIGH(NCHN)=FACGQ
28472 220 CONTINUE
28473 230 CONTINUE
28474
28475 ELSEIF(ISUB.EQ.34) THEN
28476C...f + gamma -> f + gamma
28477 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
28478 DO 250 I=MMINA,MMAXA
28479 IF(I.EQ.0) GOTO 250
28480 EI=KCHG(IABS(I),1)/3D0
28481 FACGQ=FGQ*EI**4
28482 DO 240 ISDE=1,2
28483 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
28484 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
28485 NCHN=NCHN+1
28486 ISIG(NCHN,ISDE)=I
28487 ISIG(NCHN,3-ISDE)=22
28488 ISIG(NCHN,3)=1
28489 SIGH(NCHN)=FACGQ
28490 240 CONTINUE
28491 250 CONTINUE
28492 ENDIF
28493
28494 ELSEIF(ISUB.LE.80) THEN
28495 IF(ISUB.EQ.53) THEN
28496C...g + g -> f + fbar (g + g -> q + qbar only)
28497 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
28498 IDC0=MDCY(21,2)-1
28499C...Begin by d, u, s flavours.
28500 FLAVWT=0D0
28501 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
28502 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
28503 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
28504 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
28505 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
28506 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
28507 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28508 & UH2/SH2)*FLAVWT*FACA
28509 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28510 & TH2/SH2)*FLAVWT*FACA
28511 NCHN=NCHN+1
28512 ISIG(NCHN,1)=21
28513 ISIG(NCHN,2)=21
28514 ISIG(NCHN,3)=1
28515 SIGH(NCHN)=FACQQ1
28516 NCHN=NCHN+1
28517 ISIG(NCHN,1)=21
28518 ISIG(NCHN,2)=21
28519 ISIG(NCHN,3)=2
28520 SIGH(NCHN)=FACQQ2
28521C...Next c and b flavours: modified that and uhat for fixed
28522C...cos(theta-hat).
28523 DO 260 IFL=4,5
28524 SQMAVG=PMAS(IFL,1)**2
28525 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
28526 BE34=SQRT(1D0-4D0*SQMAVG/SH)
28527 THQ=-0.5D0*SH*(1D0-BE34*CTH)
28528 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
28529 THUHQ=THQ*UHQ-SQMAVG*SH
28530 IF(MSTP(34).EQ.0) THEN
28531 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
28532 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
28533 ELSE
28534 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28535 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
28536 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28537 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
28538 ENDIF
28539 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
28540 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
28541 NCHN=NCHN+1
28542 ISIG(NCHN,1)=21
28543 ISIG(NCHN,2)=21
28544 ISIG(NCHN,3)=1+2*(IFL-3)
28545 SIGH(NCHN)=FACQQ1
28546 NCHN=NCHN+1
28547 ISIG(NCHN,1)=21
28548 ISIG(NCHN,2)=21
28549 ISIG(NCHN,3)=2+2*(IFL-3)
28550 SIGH(NCHN)=FACQQ2
28551 ENDIF
28552 260 CONTINUE
28553 270 CONTINUE
28554
28555 ELSEIF(ISUB.EQ.54) THEN
28556C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
28557 CALL PYWIDT(21,SH,WDTP,WDTE)
28558 WDTESU=0D0
28559 DO 280 I=1,MIN(8,MDCY(21,3))
28560 EF=KCHG(I,1)/3D0
28561 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
28562 & WDTE(I,4))
28563 280 CONTINUE
28564 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
28565 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
28566 NCHN=NCHN+1
28567 ISIG(NCHN,1)=21
28568 ISIG(NCHN,2)=22
28569 ISIG(NCHN,3)=1
28570 SIGH(NCHN)=FACQQ
28571 ENDIF
28572 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
28573 NCHN=NCHN+1
28574 ISIG(NCHN,1)=22
28575 ISIG(NCHN,2)=21
28576 ISIG(NCHN,3)=1
28577 SIGH(NCHN)=FACQQ
28578 ENDIF
28579
28580 ELSEIF(ISUB.EQ.58) THEN
28581C...gamma + gamma -> f + fbar
28582 CALL PYWIDT(22,SH,WDTP,WDTE)
28583 WDTESU=0D0
28584 DO 290 I=1,MIN(12,MDCY(22,3))
28585 IF(I.LE.8) EF= KCHG(I,1)/3D0
28586 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
28587 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
28588 & WDTE(I,4))
28589 290 CONTINUE
28590 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
28591 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
28592 NCHN=NCHN+1
28593 ISIG(NCHN,1)=22
28594 ISIG(NCHN,2)=22
28595 ISIG(NCHN,3)=1
28596 SIGH(NCHN)=FACFF
28597 ENDIF
28598
28599 ELSEIF(ISUB.EQ.68) THEN
28600C...g + g -> g + g
28601 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
28602 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
28603 & TH2/SH2)*FACA
28604 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
28605 & SH2/UH2)*FACA
28606 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
28607 & UH2/TH2)
28608 NCHN=NCHN+1
28609 ISIG(NCHN,1)=21
28610 ISIG(NCHN,2)=21
28611 ISIG(NCHN,3)=1
28612 SIGH(NCHN)=0.5D0*FACGG1
28613 NCHN=NCHN+1
28614 ISIG(NCHN,1)=21
28615 ISIG(NCHN,2)=21
28616 ISIG(NCHN,3)=2
28617 SIGH(NCHN)=0.5D0*FACGG2
28618 NCHN=NCHN+1
28619 ISIG(NCHN,1)=21
28620 ISIG(NCHN,2)=21
28621 ISIG(NCHN,3)=3
28622 SIGH(NCHN)=0.5D0*FACGG3
28623 300 CONTINUE
28624
28625 ELSEIF(ISUB.EQ.80) THEN
28626C...q + gamma -> q' + pi+/-
28627 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
28628 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
28629 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
28630 DELSH=UH*SQRT(ASSH*Q2FPSH)
28631 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
28632 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
28633 DELUH=SH*SQRT(ASUH*Q2FPUH)
28634 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
28635 IF(I.EQ.0) GOTO 320
28636 EI=KCHG(IABS(I),1)/3D0
28637 EJ=SIGN(1D0-ABS(EI),EI)
28638 DO 310 ISDE=1,2
28639 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
28640 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
28641 NCHN=NCHN+1
28642 ISIG(NCHN,ISDE)=I
28643 ISIG(NCHN,3-ISDE)=22
28644 ISIG(NCHN,3)=1
28645 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
28646 310 CONTINUE
28647 320 CONTINUE
28648 ENDIF
28649
28650 ELSEIF(ISUB.LE.100) THEN
28651 IF(ISUB.EQ.91) THEN
28652C...Elastic scattering
28653 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
28654
28655 ELSEIF(ISUB.EQ.92) THEN
28656C...Single diffractive scattering (first side, i.e. XB)
28657 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
28658
28659 ELSEIF(ISUB.EQ.93) THEN
28660C...Single diffractive scattering (second side, i.e. AX)
28661 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
28662
28663 ELSEIF(ISUB.EQ.94) THEN
28664C...Double diffractive scattering
28665 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
28666
28667 ELSEIF(ISUB.EQ.95) THEN
28668C...Low-pT scattering
28669 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
28670
28671 ELSEIF(ISUB.EQ.96) THEN
28672C...Multiple interactions: sum of QCD processes
28673 CALL PYWIDT(21,SH,WDTP,WDTE)
28674
28675C...q + q' -> q + q'
28676 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
28677 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
28678 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
28679 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
28680 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
28681 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
28682 DO 340 I=-5,5
28683 IF(I.EQ.0) GOTO 340
28684 DO 330 J=-5,5
28685 IF(J.EQ.0) GOTO 330
28686 NCHN=NCHN+1
28687 ISIG(NCHN,1)=I
28688 ISIG(NCHN,2)=J
28689 ISIG(NCHN,3)=111
28690 SIGH(NCHN)=FACQQ1
28691 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
28692 IF(I.EQ.J) THEN
28693 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
28694 NCHN=NCHN+1
28695 ISIG(NCHN,1)=I
28696 ISIG(NCHN,2)=J
28697 ISIG(NCHN,3)=112
28698 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
28699 ENDIF
28700 330 CONTINUE
28701 340 CONTINUE
28702
28703C...q + qbar -> q' + qbar' or g + g
28704 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
28705 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
28706 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28707 & UH2/SH2)
28708 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28709 & TH2/SH2)
28710 DO 350 I=-5,5
28711 IF(I.EQ.0) GOTO 350
28712 NCHN=NCHN+1
28713 ISIG(NCHN,1)=I
28714 ISIG(NCHN,2)=-I
28715 ISIG(NCHN,3)=121
28716 SIGH(NCHN)=FACQQB
28717 NCHN=NCHN+1
28718 ISIG(NCHN,1)=I
28719 ISIG(NCHN,2)=-I
28720 ISIG(NCHN,3)=131
28721 SIGH(NCHN)=0.5D0*FACGG1
28722 NCHN=NCHN+1
28723 ISIG(NCHN,1)=I
28724 ISIG(NCHN,2)=-I
28725 ISIG(NCHN,3)=132
28726 SIGH(NCHN)=0.5D0*FACGG2
28727 350 CONTINUE
28728
28729C...q + g -> q + g
28730 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
28731 & UH/SH)*FACA
28732 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
28733 & SH/UH)
28734 DO 370 I=-5,5
28735 IF(I.EQ.0) GOTO 370
28736 DO 360 ISDE=1,2
28737 NCHN=NCHN+1
28738 ISIG(NCHN,ISDE)=I
28739 ISIG(NCHN,3-ISDE)=21
28740 ISIG(NCHN,3)=281
28741 SIGH(NCHN)=FACQG1
28742 NCHN=NCHN+1
28743 ISIG(NCHN,ISDE)=I
28744 ISIG(NCHN,3-ISDE)=21
28745 ISIG(NCHN,3)=282
28746 SIGH(NCHN)=FACQG2
28747 360 CONTINUE
28748 370 CONTINUE
28749
28750C...g + g -> q + qbar (only d, u, s)
28751 IDC0=MDCY(21,2)-1
28752 FLAVWT=0D0
28753 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
28754 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
28755 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
28756 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
28757 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
28758 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
28759 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
28760 & UH2/SH2)*FLAVWT*FACA
28761 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
28762 & TH2/SH2)*FLAVWT*FACA
28763 NCHN=NCHN+1
28764 ISIG(NCHN,1)=21
28765 ISIG(NCHN,2)=21
28766 ISIG(NCHN,3)=531
28767 SIGH(NCHN)=FACQQ1
28768 NCHN=NCHN+1
28769 ISIG(NCHN,1)=21
28770 ISIG(NCHN,2)=21
28771 ISIG(NCHN,3)=532
28772 SIGH(NCHN)=FACQQ2
28773
28774C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
28775C...cos(theta-hat)
28776 DO 380 IFL=4,5
28777 SQMAVG=PMAS(IFL,1)**2
28778 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
28779 BE34=SQRT(1D0-4D0*SQMAVG/SH)
28780 THQ=-0.5D0*SH*(1D0-BE34*CTH)
28781 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
28782 THUHQ=THQ*UHQ-SQMAVG*SH
28783 IF(MSTP(34).EQ.0) THEN
28784 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
28785 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
28786 ELSE
28787 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28788 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
28789 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
28790 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
28791 ENDIF
28792 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
28793 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
28794 NCHN=NCHN+1
28795 ISIG(NCHN,1)=21
28796 ISIG(NCHN,2)=21
28797 ISIG(NCHN,3)=531+2*(IFL-3)
28798 SIGH(NCHN)=FACQQ1
28799 NCHN=NCHN+1
28800 ISIG(NCHN,1)=21
28801 ISIG(NCHN,2)=21
28802 ISIG(NCHN,3)=532+2*(IFL-3)
28803 SIGH(NCHN)=FACQQ2
28804 ENDIF
28805 380 CONTINUE
28806
28807C...g + g -> g + g
28808 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
28809 & 2D0*TH/SH+TH2/SH2)*FACA
28810 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
28811 & 2D0*SH/UH+SH2/UH2)*FACA
28812 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
28813 & 2D0*UH/TH+UH2/TH2)
28814 NCHN=NCHN+1
28815 ISIG(NCHN,1)=21
28816 ISIG(NCHN,2)=21
28817 ISIG(NCHN,3)=681
28818 SIGH(NCHN)=0.5D0*FACGG1
28819 NCHN=NCHN+1
28820 ISIG(NCHN,1)=21
28821 ISIG(NCHN,2)=21
28822 ISIG(NCHN,3)=682
28823 SIGH(NCHN)=0.5D0*FACGG2
28824 NCHN=NCHN+1
28825 ISIG(NCHN,1)=21
28826 ISIG(NCHN,2)=21
28827 ISIG(NCHN,3)=683
28828 SIGH(NCHN)=0.5D0*FACGG3
28829
28830 ELSEIF(ISUB.EQ.99) THEN
28831C...f + gamma* -> f.
28832 IF(MINT(107).EQ.4) THEN
28833 Q2GA=VINT(307)
28834 P2GA=VINT(308)
28835 ISDE=2
28836 ELSE
28837 Q2GA=VINT(308)
28838 P2GA=VINT(307)
28839 ISDE=1
28840 ENDIF
28841 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
28842 PM2RHO=PMAS(PYCOMP(113),1)**2
28843 IF(MSTP(19).EQ.0) THEN
28844 COMFAC=COMFAC/Q2GA
28845 ELSEIF(MSTP(19).EQ.1) THEN
28846 COMFAC=COMFAC/(Q2GA+PM2RHO)
28847 ELSEIF(MSTP(19).EQ.2) THEN
28848 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
28849 ELSE
28850 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
28851 W2GA=VINT(2)
28852 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
28853 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
28854 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
28855 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
28856 ELSE
28857 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
28858 & Q2GA**0.57D0)
28859 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
28860 ENDIF
28861 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
28862 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
28863 ENDIF
28864 DO 390 I=MMINA,MMAXA
28865 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
28866 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
28867 EI=KCHG(IABS(I),1)/3D0
28868 NCHN=NCHN+1
28869 ISIG(NCHN,ISDE)=I
28870 ISIG(NCHN,3-ISDE)=22
28871 ISIG(NCHN,3)=1
28872 SIGH(NCHN)=COMFAC*EI**2
28873 390 CONTINUE
28874 ENDIF
28875
28876 ELSE
28877 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
28878C...g + g -> gamma + gamma or g + g -> g + gamma
28879 A0STUR=0D0
28880 A0STUI=0D0
28881 A0TSUR=0D0
28882 A0TSUI=0D0
28883 A0UTSR=0D0
28884 A0UTSI=0D0
28885 A1STUR=0D0
28886 A1STUI=0D0
28887 A2STUR=0D0
28888 A2STUI=0D0
28889 ALST=LOG(-SH/TH)
28890 ALSU=LOG(-SH/UH)
28891 ALTU=LOG(TH/UH)
28892 IMAX=2*MSTP(1)
28893 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
28894 DO 400 I=1,IMAX
28895 EI=KCHG(IABS(I),1)/3D0
28896 EIWT=EI**2
28897 IF(ISUB.EQ.115) EIWT=EI
28898 SQMQ=PMAS(I,1)**2
28899 EPSS=4D0*SQMQ/SH
28900 EPST=4D0*SQMQ/TH
28901 EPSU=4D0*SQMQ/UH
28902 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
28903 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
28904 & PARU(1)**2)
28905 B0STUI=0D0
28906 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
28907 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
28908 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
28909 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
28910 B1STUR=-1D0
28911 B1STUI=0D0
28912 B2STUR=-1D0
28913 B2STUI=0D0
28914 ELSE
28915 CALL PYWAUX(1,EPSS,W1SR,W1SI)
28916 CALL PYWAUX(1,EPST,W1TR,W1TI)
28917 CALL PYWAUX(1,EPSU,W1UR,W1UI)
28918 CALL PYWAUX(2,EPSS,W2SR,W2SI)
28919 CALL PYWAUX(2,EPST,W2TR,W2TI)
28920 CALL PYWAUX(2,EPSU,W2UR,W2UI)
28921 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
28922 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
28923 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
28924 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
28925 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
28926 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
28927 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
28928 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
28929 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
28930 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
28931 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
28932 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
28933 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
28934 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
28935 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
28936 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
28937 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
28938 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
28939 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
28940 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
28941 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
28942 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
28943 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
28944 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
28945 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
28946 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
28947 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
28948 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
28949 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
28950 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
28951 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
28952 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
28953 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
28954 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
28955 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
28956 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
28957 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
28958 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
28959 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
28960 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
28961 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
28962 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
28963 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
28964 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
28965 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
28966 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
28967 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
28968 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
28969 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
28970 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
28971 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
28972 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
28973 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
28974 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
28975 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
28976 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
28977 ENDIF
28978 A0STUR=A0STUR+EIWT*B0STUR
28979 A0STUI=A0STUI+EIWT*B0STUI
28980 A0TSUR=A0TSUR+EIWT*B0TSUR
28981 A0TSUI=A0TSUI+EIWT*B0TSUI
28982 A0UTSR=A0UTSR+EIWT*B0UTSR
28983 A0UTSI=A0UTSI+EIWT*B0UTSI
28984 A1STUR=A1STUR+EIWT*B1STUR
28985 A1STUI=A1STUI+EIWT*B1STUI
28986 A2STUR=A2STUR+EIWT*B2STUR
28987 A2STUI=A2STUI+EIWT*B2STUI
28988 400 CONTINUE
28989 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
28990 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
28991 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
28992 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
28993 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
28994 NCHN=NCHN+1
28995 ISIG(NCHN,1)=21
28996 ISIG(NCHN,2)=21
28997 ISIG(NCHN,3)=1
28998 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
28999 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29000 410 CONTINUE
29001
29002 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29003C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29004 PH=0D0
29005 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29006 & PH=VINT(3)**2
29007 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29008 & PH=VINT(4)**2
29009 IF(ISUB.EQ.131) THEN
29010 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29011 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29012 ELSE
29013 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29014 ENDIF
29015 DO 430 I=MMINA,MMAXA
29016 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29017 EI=KCHG(IABS(I),1)/3D0
29018 FACGQ=FGQ*EI**2
29019 DO 420 ISDE=1,2
29020 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29021 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29022 NCHN=NCHN+1
29023 ISIG(NCHN,ISDE)=I
29024 ISIG(NCHN,3-ISDE)=22
29025 ISIG(NCHN,3)=1
29026 SIGH(NCHN)=FACGQ
29027 420 CONTINUE
29028 430 CONTINUE
29029
29030 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29031C...f + gamma*_(T,L) -> f + gamma
29032 PH=0D0
29033 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29034 & PH=VINT(3)**2
29035 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29036 & PH=VINT(4)**2
29037 IF(ISUB.EQ.133) THEN
29038 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29039 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29040 ELSE
29041 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29042 ENDIF
29043 DO 450 I=MMINA,MMAXA
29044 IF(I.EQ.0) GOTO 450
29045 EI=KCHG(IABS(I),1)/3D0
29046 FACGQ=FGQ*EI**4
29047 DO 440 ISDE=1,2
29048 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29049 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29050 NCHN=NCHN+1
29051 ISIG(NCHN,ISDE)=I
29052 ISIG(NCHN,3-ISDE)=22
29053 ISIG(NCHN,3)=1
29054 SIGH(NCHN)=FACGQ
29055 440 CONTINUE
29056 450 CONTINUE
29057
29058 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29059C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29060 PH=0D0
29061 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29062 & PH=VINT(3)**2
29063 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29064 & PH=VINT(4)**2
29065 CALL PYWIDT(21,SH,WDTP,WDTE)
29066 WDTESU=0D0
29067 DO 460 I=1,MIN(8,MDCY(21,3))
29068 EF=KCHG(I,1)/3D0
29069 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29070 & WDTE(I,4))
29071 460 CONTINUE
29072 IF(ISUB.EQ.135) THEN
29073 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29074 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29075 ELSE
29076 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29077 ENDIF
29078 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29079 NCHN=NCHN+1
29080 ISIG(NCHN,1)=21
29081 ISIG(NCHN,2)=22
29082 ISIG(NCHN,3)=1
29083 SIGH(NCHN)=FACQQ
29084 ENDIF
29085 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29086 NCHN=NCHN+1
29087 ISIG(NCHN,1)=22
29088 ISIG(NCHN,2)=21
29089 ISIG(NCHN,3)=1
29090 SIGH(NCHN)=FACQQ
29091 ENDIF
29092
29093 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
29094C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
29095 PH1=0D0
29096 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
29097 PH2=0D0
29098 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
29099 CALL PYWIDT(22,SH,WDTP,WDTE)
29100 WDTESU=0D0
29101 DO 470 I=1,MIN(12,MDCY(22,3))
29102 IF(I.LE.8) EF= KCHG(I,1)/3D0
29103 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29104 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29105 & WDTE(I,4))
29106 470 CONTINUE
29107 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
29108 IF(ISUB.EQ.137) THEN
29109 FPARAM=-SH*(TH+UH)/DLAMB2
29110 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
29111 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
29112 & 2D0*PH1*PH2*FPARAM**2)
29113 ELSEIF(ISUB.EQ.138) THEN
29114 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
29115 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
29116 & 2D0*PH1**2*(TH-UH)**2)
29117 ELSEIF(ISUB.EQ.139) THEN
29118 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
29119 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
29120 & 2D0*PH2**2*(TH-UH)**2)
29121 ELSE
29122 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
29123 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
29124 ENDIF
29125 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29126 NCHN=NCHN+1
29127 ISIG(NCHN,1)=22
29128 ISIG(NCHN,2)=22
29129 ISIG(NCHN,3)=1
29130 SIGH(NCHN)=FACFF
29131 ENDIF
29132
29133 ENDIF
29134 ENDIF
29135
29136 RETURN
29137 END
29138
29139C*********************************************************************
29140
29141C...PYSGHF
29142C...Subprocess cross sections for heavy flavour production,
29143C...open and closed.
29144C...Auxiliary to PYSIGH.
29145
29146 SUBROUTINE PYSGHF(NCHN,SIGS)
29147
29148C...Double precision and integer declarations
29149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29150 IMPLICIT INTEGER(I-N)
29151 INTEGER PYK,PYCHGE,PYCOMP
29152C...Parameter statement to help give large particle numbers.
29153 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29154 &KEXCIT=4000000,KDIMEN=5000000)
29155C...Commonblocks
29156 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29157 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29158 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29159 COMMON/PYINT1/MINT(400),VINT(400)
29160 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29161 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29162 COMMON/PYINT4/MWID(500),WIDS(500,5)
29163 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29164 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29165 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29166 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29167 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
29168 &/PYINT4/,/PYSGCM/
29169C...Local arrays
29170 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29171
29172C...Determine where are charmonium/bottomonium wave function parameters.
29173 IONIUM=140
29174 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
29175
29176C...Convert bottomonium process into equivalent charmonium ones.
29177 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
29178
29179C...Differential cross section expressions.
29180
29181 IF(ISUB.LE.100) THEN
29182 IF(ISUB.EQ.81) THEN
29183C...q + qbar -> Q + Qbar
29184 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29185 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29186 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29187 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
29188 & 2D0*SQMAVG/SH)
29189 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
29190 WID2=1D0
29191 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
29192 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
29193 FACQQB=FACQQB*WID2
29194 DO 100 I=MMINA,MMAXA
29195 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29196 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
29197 NCHN=NCHN+1
29198 ISIG(NCHN,1)=I
29199 ISIG(NCHN,2)=-I
29200 ISIG(NCHN,3)=1
29201 SIGH(NCHN)=FACQQB
29202 100 CONTINUE
29203
29204 ELSEIF(ISUB.EQ.82) THEN
29205C...g + g -> Q + Qbar
29206 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29207 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29208 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29209 THUHQ=THQ*UHQ-SQMAVG*SH
29210 IF(MSTP(34).EQ.0) THEN
29211 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29212 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29213 ELSE
29214 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29215 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29216 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29217 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29218 ENDIF
29219 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
29220 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
29221 IF(MSTP(35).GE.1) THEN
29222 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
29223 FACQQ1=FACQQ1*FATRE
29224 FACQQ2=FACQQ2*FATRE
29225 ENDIF
29226 WID2=1D0
29227 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
29228 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
29229 FACQQ1=FACQQ1*WID2
29230 FACQQ2=FACQQ2*WID2
29231 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
29232 NCHN=NCHN+1
29233 ISIG(NCHN,1)=21
29234 ISIG(NCHN,2)=21
29235 ISIG(NCHN,3)=1
29236 SIGH(NCHN)=FACQQ1
29237 NCHN=NCHN+1
29238 ISIG(NCHN,1)=21
29239 ISIG(NCHN,2)=21
29240 ISIG(NCHN,3)=2
29241 SIGH(NCHN)=FACQQ2
29242 110 CONTINUE
29243
29244 ELSEIF(ISUB.EQ.83) THEN
29245C...f + q -> f' + Q
29246 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
29247 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
29248 DO 130 I=MMIN1,MMAX1
29249 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
29250 DO 120 J=MMIN2,MMAX2
29251 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
29252 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
29253 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
29254 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
29255 & THEN
29256 NCHN=NCHN+1
29257 ISIG(NCHN,1)=I
29258 ISIG(NCHN,2)=J
29259 ISIG(NCHN,3)=1
29260 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
29261 & (IABS(I)+1)/2)*VINT(180+J)
29262 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
29263 & (MINT(55)+1)/2)*VINT(180+J)
29264 WID2=1D0
29265 IF(I.GT.0) THEN
29266 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
29267 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29268 & WIDS(MINT(55),2)
29269 ELSE
29270 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
29271 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29272 & WIDS(MINT(55),3)
29273 ENDIF
29274 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
29275 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
29276 ENDIF
29277 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
29278 & THEN
29279 NCHN=NCHN+1
29280 ISIG(NCHN,1)=I
29281 ISIG(NCHN,2)=J
29282 ISIG(NCHN,3)=2
29283 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
29284 & (IABS(J)+1)/2)*VINT(180+I)
29285 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
29286 & (MINT(55)+1)/2)*VINT(180+I)
29287 IF(J.GT.0) THEN
29288 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
29289 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29290 & WIDS(MINT(55),2)
29291 ELSE
29292 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
29293 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
29294 & WIDS(MINT(55),3)
29295 ENDIF
29296 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
29297 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
29298 ENDIF
29299 120 CONTINUE
29300 130 CONTINUE
29301
29302 ELSEIF(ISUB.EQ.84) THEN
29303C...g + gamma -> Q + Qbar
29304 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29305 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29306 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29307 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
29308 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
29309 & (THQ*UHQ)
29310 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
29311 WID2=1D0
29312 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
29313 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
29314 FACQQ=FACQQ*WID2
29315 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29316 NCHN=NCHN+1
29317 ISIG(NCHN,1)=21
29318 ISIG(NCHN,2)=22
29319 ISIG(NCHN,3)=1
29320 SIGH(NCHN)=FACQQ
29321 ENDIF
29322 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29323 NCHN=NCHN+1
29324 ISIG(NCHN,1)=22
29325 ISIG(NCHN,2)=21
29326 ISIG(NCHN,3)=1
29327 SIGH(NCHN)=FACQQ
29328 ENDIF
29329
29330 ELSEIF(ISUB.EQ.85) THEN
29331C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
29332 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
29333 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29334 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29335 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
29336 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
29337 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
29338 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
29339 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
29340 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
29341 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
29342 WID2=1D0
29343 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
29344 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
29345 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
29346 FACFF=FACFF*WID2
29347 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29348 NCHN=NCHN+1
29349 ISIG(NCHN,1)=22
29350 ISIG(NCHN,2)=22
29351 ISIG(NCHN,3)=1
29352 SIGH(NCHN)=FACFF
29353 ENDIF
29354
29355 ELSEIF(ISUB.EQ.86) THEN
29356C...g + g -> J/Psi + g
29357 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
29358 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29359 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29360 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29361 NCHN=NCHN+1
29362 ISIG(NCHN,1)=21
29363 ISIG(NCHN,2)=21
29364 ISIG(NCHN,3)=1
29365 SIGH(NCHN)=FACQQG
29366 ENDIF
29367
29368 ELSEIF(ISUB.EQ.87) THEN
29369C...g + g -> chi_0c + g
29370 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
29371 QGTW=(SH*TH*UH)/SH**3
29372 RGTW=SQM3/SH
29373 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
29374 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
29375 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
29376 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
29377 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
29378 & (QGTW*(QGTW-RGTW*PGTW)**4)
29379 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29380 NCHN=NCHN+1
29381 ISIG(NCHN,1)=21
29382 ISIG(NCHN,2)=21
29383 ISIG(NCHN,3)=1
29384 SIGH(NCHN)=FACQQG
29385 ENDIF
29386
29387 ELSEIF(ISUB.EQ.88) THEN
29388C...g + g -> chi_1c + g
29389 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
29390 QGTW=(SH*TH*UH)/SH**3
29391 RGTW=SQM3/SH
29392 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
29393 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
29394 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
29395 & (QGTW-RGTW*PGTW)**4
29396 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29397 NCHN=NCHN+1
29398 ISIG(NCHN,1)=21
29399 ISIG(NCHN,2)=21
29400 ISIG(NCHN,3)=1
29401 SIGH(NCHN)=FACQQG
29402 ENDIF
29403
29404 ELSEIF(ISUB.EQ.89) THEN
29405C...g + g -> chi_2c + g
29406 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
29407 QGTW=(SH*TH*UH)/SH**3
29408 RGTW=SQM3/SH
29409 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
29410 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
29411 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
29412 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
29413 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
29414 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
29415 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29416 NCHN=NCHN+1
29417 ISIG(NCHN,1)=21
29418 ISIG(NCHN,2)=21
29419 ISIG(NCHN,3)=1
29420 SIGH(NCHN)=FACQQG
29421 ENDIF
29422 ENDIF
29423
29424 ELSEIF(ISUB.LE.200) THEN
29425 IF(ISUB.EQ.104) THEN
29426C...g + g -> chi_c0.
29427 KC=PYCOMP(10441)
29428 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
29429 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
29430 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
29431 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29432 NCHN=NCHN+1
29433 ISIG(NCHN,1)=21
29434 ISIG(NCHN,2)=21
29435 ISIG(NCHN,3)=1
29436 SIGH(NCHN)=FACBW
29437 ENDIF
29438
29439 ELSEIF(ISUB.EQ.105) THEN
29440C...g + g -> chi_c2.
29441 KC=PYCOMP(445)
29442 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
29443 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
29444 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
29445 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29446 NCHN=NCHN+1
29447 ISIG(NCHN,1)=21
29448 ISIG(NCHN,2)=21
29449 ISIG(NCHN,3)=1
29450 SIGH(NCHN)=FACBW
29451 ENDIF
29452
29453 ELSEIF(ISUB.EQ.106) THEN
29454C...g + g -> J/Psi + gamma.
29455 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
29456 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
29457 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29458 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29459 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29460 NCHN=NCHN+1
29461 ISIG(NCHN,1)=21
29462 ISIG(NCHN,2)=21
29463 ISIG(NCHN,3)=1
29464 SIGH(NCHN)=FACQQG
29465 ENDIF
29466
29467 ELSEIF(ISUB.EQ.107) THEN
29468C...g + gamma -> J/Psi + g.
29469 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
29470 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
29471 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29472 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29473 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29474 NCHN=NCHN+1
29475 ISIG(NCHN,1)=21
29476 ISIG(NCHN,2)=22
29477 ISIG(NCHN,3)=1
29478 SIGH(NCHN)=FACQQG
29479 ENDIF
29480 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29481 NCHN=NCHN+1
29482 ISIG(NCHN,1)=22
29483 ISIG(NCHN,2)=21
29484 ISIG(NCHN,3)=1
29485 SIGH(NCHN)=FACQQG
29486 ENDIF
29487
29488 ELSEIF(ISUB.EQ.108) THEN
29489C...gamma + gamma -> J/Psi + gamma.
29490 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
29491 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
29492 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
29493 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
29494 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29495 NCHN=NCHN+1
29496 ISIG(NCHN,1)=22
29497 ISIG(NCHN,2)=22
29498 ISIG(NCHN,3)=1
29499 SIGH(NCHN)=FACQQG
29500 ENDIF
29501 ENDIF
29502
29503C...QUARKONIA+++
29504C...Additional code by Stefan Wolf
29505 ELSE
29506
29507C...Common code for quarkonium production.
29508 SHTH=SH+TH
29509 THUH=TH+UH
29510 UHSH=UH+SH
29511 SHTH2=SHTH**2
29512 THUH2=THUH**2
29513 UHSH2=UHSH**2
29514 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
29515 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
29516 SQMQQ=SQM3
29517 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
29518 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
29519 SQMQQ=SQM4
29520 ENDIF
29521 SQMQQR=SQRT(SQMQQ)
29522 IF(MSTP(145).EQ.1) THEN
29523 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
29524 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
29525 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
29526 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
29527 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
29528 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
29529 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
29530 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
29531 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
29532 & ISUB.GE.437) THEN
29533 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
29534 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
29535 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
29536 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
29537 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
29538 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
29539 ENDIF
29540 AQ2=AQ**2
29541 BQ2=BQ**2
29542 SMQQ2=SQMQQ*VINT(2)
29543C...Polarisation frames
29544 IF(MSTP(146).EQ.1) THEN
29545C...Recoil frame
29546 POLH1=SQRT(AQ2-SMQQ2)
29547 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
29548 AZ=-SQMQQR/POLH1
29549 BZ=0D0
29550 AX=AQ*BQ/(POLH1*POLH2)
29551 BX=-POLH1/POLH2
29552 ELSEIF(MSTP(146).EQ.2) THEN
29553C...Gottfried Jackson frame
29554 POLH1=AQ+BQ
29555 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
29556 AZ=SQMQQR/POLH1
29557 BZ=AZ
29558 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
29559 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
29560 ELSEIF(MSTP(146).EQ.3) THEN
29561C...Target frame
29562 POLH1=AQ-BQ
29563 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
29564 AZ=-SQMQQR/POLH1
29565 BZ=-AZ
29566 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
29567 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
29568 ELSEIF(MSTP(146).EQ.4) THEN
29569C...Collins Soper frame
29570 POLH1=AQ2-BQ2
29571 POLH2=SQRT(VINT(2)*POLH1)
29572 AZ=-BQ/POLH2
29573 BZ=AQ/POLH2
29574 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
29575 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
29576 ENDIF
29577C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
29578 EL1K10=AZ*ATILK1+BZ*BTILK1
29579 EL1K20=AZ*ATILK2+BZ*BTILK2
29580 EL2K10=EL1K10
29581 EL2K20=EL1K20
29582 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
29583 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
29584 EL2K11=EL1K11
29585 EL2K21=EL1K21
29586 ENDIF
29587
29588 IF(ISUB.EQ.421) THEN
29589C...g + g -> QQ~[3S11] + g
29590 IF(MSTP(145).EQ.0) THEN
29591* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
29592* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
29593 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
29594 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
29595* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
29596* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
29597 ELSE
29598 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
29599 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
29600 BB=2D0*(SH2+TH2)
29601 CC=2D0*(SH2+UH2)
29602 DD=2D0*SH2
29603 IF(MSTP(147).EQ.0) THEN
29604 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29605 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29606 ELSEIF(MSTP(147).EQ.1) THEN
29607 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29608 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29609 ELSEIF(MSTP(147).EQ.3) THEN
29610 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29611 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29612 ELSEIF(MSTP(147).EQ.4) THEN
29613 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29614 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29615 ELSEIF(MSTP(147).EQ.5) THEN
29616 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29617 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29618 ELSEIF(MSTP(147).EQ.6) THEN
29619 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29620 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29621 ENDIF
29622 FACQQG=COMFAC*FF*FACQQG
29623 ENDIF
29624 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29625 NCHN=NCHN+1
29626 ISIG(NCHN,1)=21
29627 ISIG(NCHN,2)=21
29628 ISIG(NCHN,3)=1
29629 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
29630 ENDIF
29631
29632 ELSEIF(ISUB.EQ.422) THEN
29633C...g + g -> QQ~[3S18] + g
29634 IF(MSTP(145).EQ.0) THEN
29635 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
29636 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
29637 & (SQMQQ*SQMQQR)*
29638 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
29639 ELSE
29640 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
29641 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
29642 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
29643 BB=2D0*(SH2+TH2)
29644 CC=2D0*(SH2+UH2)
29645 DD=2D0*SH2
29646 IF(MSTP(147).EQ.0) THEN
29647 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29648 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29649 ELSEIF(MSTP(147).EQ.1) THEN
29650 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29651 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29652 ELSEIF(MSTP(147).EQ.3) THEN
29653 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29654 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29655 ELSEIF(MSTP(147).EQ.4) THEN
29656 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29657 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29658 ELSEIF(MSTP(147).EQ.5) THEN
29659 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29660 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29661 ELSEIF(MSTP(147).EQ.6) THEN
29662 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29663 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29664 ENDIF
29665 FACQQG=COMFAC*FF*FACQQG
29666 ENDIF
29667C...Split total contribution into different colour flows just like
29668C...in g g -> g g (recalculate kinematics for massless partons).
29669 THP=-0.5D0*SH*(1D0-CTH)
29670 UHP=-0.5D0*SH*(1D0+CTH)
29671 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
29672 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
29673 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
29674 FACGGS=FACGG1+FACGG2+FACGG3
29675 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29676 NCHN=NCHN+1
29677 ISIG(NCHN,1)=21
29678 ISIG(NCHN,2)=21
29679 ISIG(NCHN,3)=1
29680 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
29681 NCHN=NCHN+1
29682 ISIG(NCHN,1)=21
29683 ISIG(NCHN,2)=21
29684 ISIG(NCHN,3)=2
29685 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
29686 NCHN=NCHN+1
29687 ISIG(NCHN,1)=21
29688 ISIG(NCHN,2)=21
29689 ISIG(NCHN,3)=3
29690 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
29691 ENDIF
29692
29693 ELSEIF(ISUB.EQ.423) THEN
29694C...g + g -> QQ~[1S08] + g
29695 IF(MSTP(145).EQ.0) THEN
29696* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
29697* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
29698* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
29699* & (SHTH2*THUH2*UHSH2)
29700 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
29701 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
29702 & TH2/(SHTH2*THUH2))*
29703 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
29704 ELSE
29705 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
29706 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
29707 & TH2/(SHTH2*THUH2))*
29708 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
29709 IF(MSTP(147).EQ.0) THEN
29710 FACQQG=COMFAC*FA
29711 ELSEIF(MSTP(147).EQ.1) THEN
29712 FACQQG=COMFAC*2D0*FA
29713 ELSEIF(MSTP(147).EQ.3) THEN
29714 FACQQG=COMFAC*FA
29715 ELSEIF(MSTP(147).EQ.4) THEN
29716 FACQQG=COMFAC*FA
29717 ELSEIF(MSTP(147).EQ.5) THEN
29718 FACQQG=0D0
29719 ELSEIF(MSTP(147).EQ.6) THEN
29720 FACQQG=0D0
29721 ENDIF
29722 ENDIF
29723C...Split total contribution into different colour flows just like
29724C...in g g -> g g (recalculate kinematics for massless partons).
29725 THP=-0.5D0*SH*(1D0-CTH)
29726 UHP=-0.5D0*SH*(1D0+CTH)
29727 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
29728 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
29729 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
29730 FACGGS=FACGG1+FACGG2+FACGG3
29731 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29732 NCHN=NCHN+1
29733 ISIG(NCHN,1)=21
29734 ISIG(NCHN,2)=21
29735 ISIG(NCHN,3)=1
29736 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
29737 NCHN=NCHN+1
29738 ISIG(NCHN,1)=21
29739 ISIG(NCHN,2)=21
29740 ISIG(NCHN,3)=2
29741 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
29742 NCHN=NCHN+1
29743 ISIG(NCHN,1)=21
29744 ISIG(NCHN,2)=21
29745 ISIG(NCHN,3)=3
29746 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
29747 ENDIF
29748
29749 ELSEIF(ISUB.EQ.424) THEN
29750C...g + g -> QQ~[3PJ8] + g
29751 POLY=SH2+SH*TH+TH2
29752 IF(MSTP(145).EQ.0) THEN
29753 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
29754 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
29755 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
29756 & +7D0*TH**6)
29757 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
29758 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
29759 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
29760 & +35D0*TH**8)
29761 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
29762 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
29763 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
29764 & +84D0*TH**8)
29765 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
29766 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
29767 & +451D0*SH*TH**5+126D0*TH**6)
29768 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
29769 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
29770 & +171D0*SH*TH**5+42D0*TH**6)
29771 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
29772 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
29773 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
29774 & +99D0*SH*TH**3+35D0*TH**4)
29775 & +7D0*SQMQQ**8*SHTH*POLY)/
29776 & (SH*TH*UH*SQMQQR*SQMQQ*
29777 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
29778 ELSE
29779 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
29780 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
29781 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
29782 & -SQMQQ*SHTH2*POLY**2*
29783 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
29784 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
29785 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
29786 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
29787 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
29788 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
29789 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
29790 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
29791 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
29792 & +145D0*SH*TH**5+34D0*TH**6)
29793 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
29794 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
29795 & +44D0*TH**6)
29796 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
29797 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
29798 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
29799 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
29800 & +3D0*SQMQQ**8*SHTH*POLY)
29801 BB=4D0*SHTH2*POLY**3
29802 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
29803 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
29804 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
29805 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
29806 & +84D0*SH*TH**9+20D0*TH**10)
29807 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
29808 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
29809 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
29810 & +40D0*TH**8)
29811 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
29812 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
29813 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
29814 & +40D0*TH**8)
29815 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
29816 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
29817 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
29818 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
29819 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
29820 & +4D0*TH**6)
29821 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
29822 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
29823 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
29824 CC=4D0*TH2*POLY**3
29825 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
29826 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
29827 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
29828 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
29829 & +28D0*TH**9)
29830 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
29831 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
29832 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
29833 & +394D0*SH*TH**9+84D0*TH**10)
29834 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
29835 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
29836 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
29837 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
29838 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
29839 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
29840 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
29841 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
29842 & +266D0*SH*TH**6+84D0*TH**7)
29843 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
29844 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
29845 & +28D0*TH**6)
29846 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
29847 & +7D0*SH*TH**3+4*TH**4)
29848 & +SQMQQ**8*SH*(SH-TH)**2*TH
29849 DD=2D0*TH2*SHTH2*POLY**3
29850 & *(-SH2+2*SH*TH+2*TH2)
29851 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
29852 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
29853 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
29854 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
29855 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
29856 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
29857 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
29858 & -210D0*SH*TH**8-60D0*TH**9)
29859 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
29860 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
29861 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
29862 & -80D0*TH**8)
29863 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
29864 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
29865 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
29866 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
29867 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
29868 & -30D0*SH*TH**6-24D0*TH**7)
29869 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
29870 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
29871 & -4D0*TH**6)
29872 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
29873 IF(MSTP(147).EQ.0) THEN
29874 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29875 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29876 ELSEIF(MSTP(147).EQ.1) THEN
29877 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29878 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29879 ELSEIF(MSTP(147).EQ.3) THEN
29880 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29881 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29882 ELSEIF(MSTP(147).EQ.4) THEN
29883 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29884 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29885 ELSEIF(MSTP(147).EQ.5) THEN
29886 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29887 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29888 ELSEIF(MSTP(147).EQ.6) THEN
29889 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29890 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29891 ENDIF
29892 FACQQG=COMFAC*FF*FACQQG
29893 ENDIF
29894C...Split total contribution into different colour flows just like
29895C...in g g -> g g (recalculate kinematics for massless partons).
29896 THP=-0.5D0*SH*(1D0-CTH)
29897 UHP=-0.5D0*SH*(1D0+CTH)
29898 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
29899 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
29900 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
29901 FACGGS=FACGG1+FACGG2+FACGG3
29902 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
29903 NCHN=NCHN+1
29904 ISIG(NCHN,1)=21
29905 ISIG(NCHN,2)=21
29906 ISIG(NCHN,3)=1
29907 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
29908 NCHN=NCHN+1
29909 ISIG(NCHN,1)=21
29910 ISIG(NCHN,2)=21
29911 ISIG(NCHN,3)=2
29912 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
29913 NCHN=NCHN+1
29914 ISIG(NCHN,1)=21
29915 ISIG(NCHN,2)=21
29916 ISIG(NCHN,3)=3
29917 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
29918 ENDIF
29919
29920 ELSEIF(ISUB.EQ.425) THEN
29921C...q + g -> q + QQ~[3S18]
29922 IF(MSTP(145).EQ.0) THEN
29923 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
29924 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
29925 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
29926 ELSE
29927 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
29928 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
29929 AA=SHTH2+THUH2
29930 BB=4D0
29931 CC=8D0
29932 DD=4D0
29933 IF(MSTP(147).EQ.0) THEN
29934 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29935 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29936 ELSEIF(MSTP(147).EQ.1) THEN
29937 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29938 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
29939 ELSEIF(MSTP(147).EQ.3) THEN
29940 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
29941 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
29942 ELSEIF(MSTP(147).EQ.4) THEN
29943 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29944 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29945 ELSEIF(MSTP(147).EQ.5) THEN
29946 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
29947 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
29948 ELSEIF(MSTP(147).EQ.6) THEN
29949 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
29950 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
29951 ENDIF
29952 FACQQG=COMFAC*FF*FACQQG
29953 ENDIF
29954C...Split total contribution into different colour flows just like
29955C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
29956C...(recalculate kinematics for massless partons).
29957 THP=-0.5D0*SH*(1D0-CTH)
29958 UHP=-0.5D0*SH*(1D0+CTH)
29959 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
29960 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
29961 FACQGS=FACQG1+FACQG2
29962 DO 2442 I=MMINA,MMAXA
29963 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
29964 DO 2441 ISDE=1,2
29965 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
29966 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
29967 NCHN=NCHN+1
29968 ISIG(NCHN,ISDE)=I
29969 ISIG(NCHN,3-ISDE)=21
29970 ISIG(NCHN,3)=1
29971 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
29972 NCHN=NCHN+1
29973 ISIG(NCHN,ISDE)=I
29974 ISIG(NCHN,3-ISDE)=21
29975 ISIG(NCHN,3)=2
29976 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
29977 2441 CONTINUE
29978 2442 CONTINUE
29979
29980 ELSEIF(ISUB.EQ.426) THEN
29981C...q + g -> q + QQ~[1S08]
29982 IF(MSTP(145).EQ.0) THEN
29983 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
29984 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
29985 ELSE
29986 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
29987 IF(MSTP(147).EQ.0) THEN
29988 FACQQG=COMFAC*FA
29989 ELSEIF(MSTP(147).EQ.1) THEN
29990 FACQQG=COMFAC*2D0*FA
29991 ELSEIF(MSTP(147).EQ.3) THEN
29992 FACQQG=COMFAC*FA
29993 ELSEIF(MSTP(147).EQ.4) THEN
29994 FACQQG=COMFAC*FA
29995 ELSEIF(MSTP(147).EQ.5) THEN
29996 FACQQG=0D0
29997 ELSEIF(MSTP(147).EQ.6) THEN
29998 FACQQG=0D0
29999 ENDIF
30000 ENDIF
30001C...Split total contribution into different colour flows just like
30002C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30003C...(recalculate kinematics for massless partons).
30004 THP=-0.5D0*SH*(1D0-CTH)
30005 UHP=-0.5D0*SH*(1D0+CTH)
30006 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30007 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30008 FACQGS=FACQG1+FACQG2
30009 DO 2444 I=MMINA,MMAXA
30010 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30011 DO 2443 ISDE=1,2
30012 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30013 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30014 NCHN=NCHN+1
30015 ISIG(NCHN,ISDE)=I
30016 ISIG(NCHN,3-ISDE)=21
30017 ISIG(NCHN,3)=1
30018 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30019 NCHN=NCHN+1
30020 ISIG(NCHN,ISDE)=I
30021 ISIG(NCHN,3-ISDE)=21
30022 ISIG(NCHN,3)=2
30023 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30024 2443 CONTINUE
30025 2444 CONTINUE
30026
30027 ELSEIF(ISUB.EQ.427) THEN
30028C...q + g -> q + QQ~[3PJ8]
30029 IF(MSTP(145).EQ.0) THEN
30030 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30031 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30032 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30033 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30034 ELSE
30035 FF=10D0*PARU(1)*AS**3/
30036 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30037 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30038 BB=8D0*(SHTH2+TH*UH)
30039 CC=8D0*UHSH*(SHTH+THUH)
30040 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30041 IF(MSTP(147).EQ.0) THEN
30042 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30043 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30044 ELSEIF(MSTP(147).EQ.1) THEN
30045 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30046 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30047 ELSEIF(MSTP(147).EQ.3) THEN
30048 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30049 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30050 ELSEIF(MSTP(147).EQ.4) THEN
30051 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30052 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30053 ELSEIF(MSTP(147).EQ.5) THEN
30054 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30055 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30056 ELSEIF(MSTP(147).EQ.6) THEN
30057 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30058 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30059 ENDIF
30060 FACQQG=COMFAC*FF*FACQQG
30061 ENDIF
30062C...Split total contribution into different colour flows just like
30063C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30064C...(recalculate kinematics for massless partons).
30065 THP=-0.5D0*SH*(1D0-CTH)
30066 UHP=-0.5D0*SH*(1D0+CTH)
30067 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30068 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30069 FACQGS=FACQG1+FACQG2
30070 DO 2446 I=MMINA,MMAXA
30071 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30072 DO 2445 ISDE=1,2
30073 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30074 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30075 NCHN=NCHN+1
30076 ISIG(NCHN,ISDE)=I
30077 ISIG(NCHN,3-ISDE)=21
30078 ISIG(NCHN,3)=1
30079 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
30080 NCHN=NCHN+1
30081 ISIG(NCHN,ISDE)=I
30082 ISIG(NCHN,3-ISDE)=21
30083 ISIG(NCHN,3)=2
30084 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
30085 2445 CONTINUE
30086 2446 CONTINUE
30087
30088 ELSEIF(ISUB.EQ.428) THEN
30089C...q + q~ -> g + QQ~[3S18]
30090 IF(MSTP(145).EQ.0) THEN
30091 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
30092 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
30093 & (SQMQQ*SQMQQR*TH*UH*THUH2)
30094 ELSE
30095 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
30096 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
30097 AA=SHTH2+UHSH2
30098 BB=4D0
30099 CC=4D0
30100 DD=0D0
30101 IF(MSTP(147).EQ.0) THEN
30102 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30103 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30104 ELSEIF(MSTP(147).EQ.1) THEN
30105 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30106 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30107 ELSEIF(MSTP(147).EQ.3) THEN
30108 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30109 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30110 ELSEIF(MSTP(147).EQ.4) THEN
30111 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30112 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30113 ELSEIF(MSTP(147).EQ.5) THEN
30114 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30115 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30116 ELSEIF(MSTP(147).EQ.6) THEN
30117 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30118 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30119 ENDIF
30120 FACQQG=COMFAC*FF*FACQQG
30121 ENDIF
30122C...Split total contribution into different colour flows just like
30123C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
30124C...(recalculate kinematics for massless partons).
30125 THP=-0.5D0*SH*(1D0-CTH)
30126 UHP=-0.5D0*SH*(1D0+CTH)
30127 FACGG1=UH/TH-9D0/4D0*UH2/SH2
30128 FACGG2=TH/UH-9D0/4D0*TH2/SH2
30129 FACGGS=FACGG1+FACGG2
30130 DO 2447 I=MMINA,MMAXA
30131 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30132 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
30133 NCHN=NCHN+1
30134 ISIG(NCHN,1)=I
30135 ISIG(NCHN,2)=-I
30136 ISIG(NCHN,3)=1
30137 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30138 NCHN=NCHN+1
30139 ISIG(NCHN,1)=I
30140 ISIG(NCHN,2)=-I
30141 ISIG(NCHN,3)=2
30142 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30143 2447 CONTINUE
30144
30145 ELSEIF(ISUB.EQ.429) THEN
30146C...q + q~ -> g + QQ~[1S08]
30147 IF(MSTP(145).EQ.0) THEN
30148 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
30149 & (TH2+UH2)/(SQMQQR*SH*THUH2)
30150 ELSE
30151 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
30152 IF(MSTP(147).EQ.0) THEN
30153 FACQQG=COMFAC*FA
30154 ELSEIF(MSTP(147).EQ.1) THEN
30155 FACQQG=COMFAC*2D0*FA
30156 ELSEIF(MSTP(147).EQ.3) THEN
30157 FACQQG=COMFAC*FA
30158 ELSEIF(MSTP(147).EQ.4) THEN
30159 FACQQG=COMFAC*FA
30160 ELSEIF(MSTP(147).EQ.5) THEN
30161 FACQQG=0D0
30162 ELSEIF(MSTP(147).EQ.6) THEN
30163 FACQQG=0D0
30164 ENDIF
30165 ENDIF
30166C...Split total contribution into different colour flows just like
30167C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
30168C...(recalculate kinematics for massless partons).
30169 THP=-0.5D0*SH*(1D0-CTH)
30170 UHP=-0.5D0*SH*(1D0+CTH)
30171 FACGG1=UH/TH-9D0/4D0*UH2/SH2
30172 FACGG2=TH/UH-9D0/4D0*TH2/SH2
30173 FACGGS=FACGG1+FACGG2
30174 DO 2448 I=MMINA,MMAXA
30175 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30176 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
30177 NCHN=NCHN+1
30178 ISIG(NCHN,1)=I
30179 ISIG(NCHN,2)=-I
30180 ISIG(NCHN,3)=1
30181 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30182 NCHN=NCHN+1
30183 ISIG(NCHN,1)=I
30184 ISIG(NCHN,2)=-I
30185 ISIG(NCHN,3)=2
30186 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30187 2448 CONTINUE
30188
30189 ELSEIF(ISUB.EQ.430) THEN
30190C...q + q~ -> g + QQ~[3PJ8]
30191 IF(MSTP(145).EQ.0) THEN
30192 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
30193 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
30194 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
30195 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
30196 ELSE
30197 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
30198 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
30199 BB=8D0*(UHSH2+SH*TH)
30200 CC=8D0*(SHTH2+SH*UH)
30201 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
30202 IF(MSTP(147).EQ.0) THEN
30203 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30204 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30205 ELSEIF(MSTP(147).EQ.1) THEN
30206 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30207 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30208 ELSEIF(MSTP(147).EQ.3) THEN
30209 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30210 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30211 ELSEIF(MSTP(147).EQ.4) THEN
30212 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30213 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30214 ELSEIF(MSTP(147).EQ.5) THEN
30215 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30216 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30217 ELSEIF(MSTP(147).EQ.6) THEN
30218 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30219 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30220 ENDIF
30221 FACQQG=COMFAC*FF*FACQQG
30222 ENDIF
30223C...Split total contribution into different colour flows just like
30224C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
30225C...(recalculate kinematics for massless partons).
30226 THP=-0.5D0*SH*(1D0-CTH)
30227 UHP=-0.5D0*SH*(1D0+CTH)
30228 FACGG1=UH/TH-9D0/4D0*UH2/SH2
30229 FACGG2=TH/UH-9D0/4D0*TH2/SH2
30230 FACGGS=FACGG1+FACGG2
30231 DO 2449 I=MMINA,MMAXA
30232 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30233 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
30234 NCHN=NCHN+1
30235 ISIG(NCHN,1)=I
30236 ISIG(NCHN,2)=-I
30237 ISIG(NCHN,3)=1
30238 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30239 NCHN=NCHN+1
30240 ISIG(NCHN,1)=I
30241 ISIG(NCHN,2)=-I
30242 ISIG(NCHN,3)=2
30243 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30244 2449 CONTINUE
30245
30246 ELSEIF(ISUB.EQ.431) THEN
30247C...g + g -> QQ~[3P01] + g
30248 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30249 QGTW=(SH*TH*UH)/SH**3
30250 RGTW=SQMQQ/SH
30251 IF(MSTP(145).EQ.0) THEN
30252 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
30253 & (9D0*RGTW**2*PGTW**4*
30254 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
30255 & -6D0*RGTW*PGTW**3*QGTW*
30256 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
30257 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
30258 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
30259 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30260 ELSE
30261 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
30262 & (9D0*RGTW**2*PGTW**4*
30263 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
30264 & -6D0*RGTW*PGTW**3*QGTW*
30265 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
30266 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
30267 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
30268 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30269 IF(MSTP(147).EQ.0) THEN
30270 FACQQG=COMFAC*FC1
30271 ELSEIF(MSTP(147).EQ.1) THEN
30272 FACQQG=COMFAC*2D0*FC1
30273 ELSEIF(MSTP(147).EQ.3) THEN
30274 FACQQG=COMFAC*FC1
30275 ELSEIF(MSTP(147).EQ.4) THEN
30276 FACQQG=COMFAC*FC1
30277 ELSEIF(MSTP(147).EQ.5) THEN
30278 FACQQG=0D0
30279 ELSEIF(MSTP(147).EQ.6) THEN
30280 FACQQG=0D0
30281 ENDIF
30282 ENDIF
30283 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30284 NCHN=NCHN+1
30285 ISIG(NCHN,1)=21
30286 ISIG(NCHN,2)=21
30287 ISIG(NCHN,3)=1
30288 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30289 ENDIF
30290
30291 ELSEIF(ISUB.EQ.432) THEN
30292C...g + g -> QQ~[3P11] + g
30293 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30294 QGTW=(SH*TH*UH)/SH**3
30295 RGTW=SQMQQ/SH
30296 IF(MSTP(145).EQ.0) THEN
30297 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
30298 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
30299 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
30300 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
30301 ELSE
30302 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
30303 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
30304 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
30305 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
30306 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
30307 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
30308 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
30309 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
30310 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
30311 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
30312 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
30313 C4=-4D0*THUH*(TH-UH)**2*
30314 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
30315 & -SH2*TH*UH*(TH2+UH2))
30316 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
30317 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
30318 & +SH2*(5D0*THUH2-17D0*TH*UH)))
30319 IF(MSTP(147).EQ.0) THEN
30320 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30321 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30322 ELSEIF(MSTP(147).EQ.1) THEN
30323 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30324 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
30325 ELSEIF(MSTP(147).EQ.3) THEN
30326 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30327 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30328 ELSEIF(MSTP(147).EQ.4) THEN
30329 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30330 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30331 ELSEIF(MSTP(147).EQ.5) THEN
30332 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
30333 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
30334 ELSEIF(MSTP(147).EQ.6) THEN
30335 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30336 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30337 ENDIF
30338 FACQQG=COMFAC*FF*FACQQG
30339 ENDIF
30340 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30341 NCHN=NCHN+1
30342 ISIG(NCHN,1)=21
30343 ISIG(NCHN,2)=21
30344 ISIG(NCHN,3)=1
30345 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30346 ENDIF
30347
30348 ELSEIF(ISUB.EQ.433) THEN
30349C...g + g -> QQ~[3P21] + g
30350 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30351 QGTW=(SH*TH*UH)/SH**3
30352 RGTW=SQMQQ/SH
30353 IF(MSTP(145).EQ.0) THEN
30354 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
30355 & (12D0*RGTW**2*PGTW**4*
30356 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
30357 & -3D0*RGTW*PGTW**3*QGTW*
30358 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
30359 & +2D0*PGTW**2*QGTW**2*
30360 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
30361 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
30362 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30363 ELSE
30364 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
30365 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
30366 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
30367 & *SH*SH2**7
30368 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
30369 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
30370 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
30371 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
30372 & +10D0*(SH2**2+TH2**2))
30373 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
30374 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
30375 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
30376 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
30377 & +4D0*SH*TH*UH2**4*SHTH2)
30378 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
30379 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
30380 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
30381 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
30382 & +10D0*(SH2**2+UH2**2))
30383 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
30384 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
30385 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
30386 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
30387 & +4D0*SH*UH*TH2**4*UHSH2)
30388 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
30389 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
30390 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
30391 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
30392 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
30393 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
30394 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
30395 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
30396 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
30397 & +3D0*(TH2**3+UH2**3)))
30398 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
30399 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
30400 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
30401 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
30402 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
30403 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
30404 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
30405 & 82D0*TH**3)
30406 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
30407 & +45D0*TH**3)
30408 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
30409 & 8D0*TH**3)
30410 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
30411 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
30412 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
30413 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
30414 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
30415 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
30416 & 82D0*UH**3)
30417 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
30418 & +45D0*UH**3)
30419 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
30420 & 8D0*UH**3)
30421 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
30422 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
30423 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
30424 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
30425 & +4D0*SH*TH2**2*UH2**2*THUH2
30426 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
30427 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
30428 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
30429 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
30430 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
30431 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
30432 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
30433 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
30434 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
30435 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
30436 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
30437 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
30438 & +2D0*(TH2**3+UH2**3))
30439 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
30440 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
30441 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
30442 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
30443 IF(MSTP(147).EQ.0) THEN
30444 FACQQG=1D0/3D0*(C1*3D0
30445 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
30446 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
30447 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
30448 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
30449 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
30450 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30451 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30452 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
30453 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30454 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30455 & *(EL1K20*EL2K20-EL1K21*EL2K21)
30456 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
30457 ELSEIF(MSTP(147).EQ.1) THEN
30458 FACQQG=C1*2D0
30459 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
30460 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
30461 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
30462 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
30463 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
30464 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
30465 & +EL1K10*EL2K20*EL1K11*EL2K11)
30466 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
30467 & +EL1K10*EL2K20*EL1K21*EL2K21)
30468 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
30469 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
30470 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
30471 & +EL1K20*EL2K20*EL1K11*EL2K11)
30472 ELSEIF(MSTP(147).EQ.2) THEN
30473 FACQQG=2D0*(C1
30474 & -C2*EL1K11*EL2K11
30475 & -C3*EL1K21*EL2K21
30476 & -C4*EL1K11*EL2K21
30477 & +C5*(EL1K11*EL2K11)**2
30478 & +C6*(EL1K21*EL2K21)**2
30479 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
30480 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
30481 & +(C9+C0)*(EL1K11*EL2K21)**2)
30482 ENDIF
30483 FACQQG=COMFAC*FF*FACQQG
30484 ENDIF
30485 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30486 NCHN=NCHN+1
30487 ISIG(NCHN,1)=21
30488 ISIG(NCHN,2)=21
30489 ISIG(NCHN,3)=1
30490 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30491 ENDIF
30492
30493 ELSEIF(ISUB.EQ.434) THEN
30494C...q + g -> q + QQ~[3P01]
30495 IF(MSTP(145).EQ.0) THEN
30496 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
30497 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
30498 ELSE
30499 FA=-PARU(1)*AS**3*(16D0/243D0)*
30500 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
30501 IF(MSTP(147).EQ.0) THEN
30502 FACQQG=COMFAC*FA
30503 ELSEIF(MSTP(147).EQ.1) THEN
30504 FACQQG=COMFAC*2D0*FA
30505 ELSEIF(MSTP(147).EQ.3) THEN
30506 FACQQG=COMFAC*FA
30507 ELSEIF(MSTP(147).EQ.4) THEN
30508 FACQQG=COMFAC*FA
30509 ELSEIF(MSTP(147).EQ.5) THEN
30510 FACQQG=0D0
30511 ELSEIF(MSTP(147).EQ.6) THEN
30512 FACQQG=0D0
30513 ENDIF
30514 ENDIF
30515 DO 2452 I=MMINA,MMAXA
30516 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
30517 DO 2451 ISDE=1,2
30518 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
30519 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
30520 NCHN=NCHN+1
30521 ISIG(NCHN,ISDE)=I
30522 ISIG(NCHN,3-ISDE)=21
30523 ISIG(NCHN,3)=1
30524 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30525 2451 CONTINUE
30526 2452 CONTINUE
30527
30528 ELSEIF(ISUB.EQ.435) THEN
30529C...q + g -> q + QQ~[3P11]
30530 IF(MSTP(145).EQ.0) THEN
30531 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
30532 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
30533 ELSE
30534 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
30535 C1=SH*UH
30536 C2=2D0*SH
30537 C3=0D0
30538 C4=2D0*(SH-UH)
30539 IF(MSTP(147).EQ.0) THEN
30540 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30541 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30542 ELSEIF(MSTP(147).EQ.1) THEN
30543 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30544 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
30545 ELSEIF(MSTP(147).EQ.3) THEN
30546 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30547 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30548 ELSEIF(MSTP(147).EQ.4) THEN
30549 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30550 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30551 ELSEIF(MSTP(147).EQ.5) THEN
30552 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
30553 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
30554 ELSEIF(MSTP(147).EQ.6) THEN
30555 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30556 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30557 ENDIF
30558 FACQQG=COMFAC*FF*FACQQG
30559 ENDIF
30560 DO 2454 I=MMINA,MMAXA
30561 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
30562 DO 2453 ISDE=1,2
30563 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
30564 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
30565 NCHN=NCHN+1
30566 ISIG(NCHN,ISDE)=I
30567 ISIG(NCHN,3-ISDE)=21
30568 ISIG(NCHN,3)=1
30569 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30570 2453 CONTINUE
30571 2454 CONTINUE
30572
30573 ELSEIF(ISUB.EQ.436) THEN
30574C...q + g -> q + QQ~[3P21]
30575 IF(MSTP(145).EQ.0) THEN
30576 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
30577 & ((6D0*SQMQQ**2+TH2)*UHSH2
30578 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
30579 & (SQMQQR*TH*UHSH2**2)
30580 ELSE
30581 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
30582 C1=TH*UHSH2
30583 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
30584 C3=4D0*UHSH2
30585 C4=8D0*SH*UHSH
30586 C5=8D0*TH
30587 C6=0D0
30588 C7=16D0*TH
30589 C8=0D0
30590 C9=-16D0*UHSH
30591 C0=16D0*SQMQQ
30592 IF(MSTP(147).EQ.0) THEN
30593 FACQQG=1D0/3D0*(C1*3D0
30594 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
30595 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
30596 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
30597 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
30598 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
30599 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30600 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30601 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
30602 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30603 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30604 & *(EL1K20*EL2K20-EL1K21*EL2K21)
30605 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
30606 ELSEIF(MSTP(147).EQ.1) THEN
30607 FACQQG=C1*2D0
30608 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
30609 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
30610 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
30611 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
30612 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
30613 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
30614 & +EL1K10*EL2K20*EL1K11*EL2K11)
30615 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
30616 & +EL1K10*EL2K20*EL1K21*EL2K21)
30617 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
30618 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
30619 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
30620 & +EL1K20*EL2K20*EL1K11*EL2K11)
30621 ELSEIF(MSTP(147).EQ.2) THEN
30622 FACQQG=2D0*(C1
30623 & -C2*EL1K11*EL2K11
30624 & -C3*EL1K21*EL2K21
30625 & -C4*EL1K11*EL2K21
30626 & +C5*(EL1K11*EL2K11)**2
30627 & +C6*(EL1K21*EL2K21)**2
30628 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
30629 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
30630 & +(C9+C0)*(EL1K11*EL2K21)**2)
30631 ENDIF
30632 FACQQG=COMFAC*FF*FACQQG
30633 ENDIF
30634 DO 2456 I=MMINA,MMAXA
30635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
30636 DO 2455 ISDE=1,2
30637 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
30638 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
30639 NCHN=NCHN+1
30640 ISIG(NCHN,ISDE)=I
30641 ISIG(NCHN,3-ISDE)=21
30642 ISIG(NCHN,3)=1
30643 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30644 2455 CONTINUE
30645 2456 CONTINUE
30646
30647 ELSEIF(ISUB.EQ.437) THEN
30648C...q + q~ -> g + QQ~[3P01]
30649 IF(MSTP(145).EQ.0) THEN
30650 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
30651 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
30652 ELSE
30653 FA=PARU(1)*AS**3*(128D0/729D0)*
30654 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
30655 IF(MSTP(147).EQ.0) THEN
30656 FACQQG=COMFAC*FA
30657 ELSEIF(MSTP(147).EQ.1) THEN
30658 FACQQG=COMFAC*2D0*FA
30659 ELSEIF(MSTP(147).EQ.3) THEN
30660 FACQQG=COMFAC*FA
30661 ELSEIF(MSTP(147).EQ.4) THEN
30662 FACQQG=COMFAC*FA
30663 ELSEIF(MSTP(147).EQ.5) THEN
30664 FACQQG=0D0
30665 ELSEIF(MSTP(147).EQ.6) THEN
30666 FACQQG=0D0
30667 ENDIF
30668 ENDIF
30669 DO 2457 I=MMINA,MMAXA
30670 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30671 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
30672 NCHN=NCHN+1
30673 ISIG(NCHN,1)=I
30674 ISIG(NCHN,2)=-I
30675 ISIG(NCHN,3)=1
30676 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30677 2457 CONTINUE
30678
30679 ELSEIF(ISUB.EQ.438) THEN
30680C...q + q~ -> g + QQ~[3P11]
30681 IF(MSTP(145).EQ.0) THEN
30682 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
30683 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
30684 ELSE
30685 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
30686 C1=TH*UH
30687 C2=2D0*UH
30688 C3=2D0*TH
30689 C4=2D0*THUH
30690 IF(MSTP(147).EQ.0) THEN
30691 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30692 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30693 ELSEIF(MSTP(147).EQ.1) THEN
30694 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30695 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
30696 ELSEIF(MSTP(147).EQ.3) THEN
30697 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
30698 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
30699 ELSEIF(MSTP(147).EQ.4) THEN
30700 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30701 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30702 ELSEIF(MSTP(147).EQ.5) THEN
30703 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
30704 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
30705 ELSEIF(MSTP(147).EQ.6) THEN
30706 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
30707 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
30708 ENDIF
30709 FACQQG=COMFAC*FF*FACQQG
30710 ENDIF
30711 DO 2458 I=MMINA,MMAXA
30712 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30713 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
30714 NCHN=NCHN+1
30715 ISIG(NCHN,1)=I
30716 ISIG(NCHN,2)=-I
30717 ISIG(NCHN,3)=1
30718 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30719 2458 CONTINUE
30720
30721 ELSEIF(ISUB.EQ.439) THEN
30722C...q + q~ -> g + QQ~[3P21]
30723 IF(MSTP(145).EQ.0) THEN
30724 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
30725 & ((6D0*SQMQQ**2+SH2)*THUH2
30726 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
30727 & (SQMQQR*SH*THUH2**2)
30728 ELSE
30729 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
30730 C1=SH*THUH2
30731 C2=4D0*(SH2+UH2+2D0*SH*THUH)
30732 C3=4D0*(SH2+TH2+2D0*SH*THUH)
30733 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
30734 C5=8D0*SH
30735 C6=C5
30736 C7=16D0*SH
30737 C8=C7
30738 C9=-16D0*THUH
30739 C0=16D0*SQMQQ
30740 IF(MSTP(147).EQ.0) THEN
30741 FACQQG=1D0/3D0*(C1*3D0
30742 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
30743 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
30744 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
30745 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
30746 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
30747 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30748 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30749 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
30750 & *(EL1K10*EL2K20-EL1K11*EL2K21)
30751 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
30752 & *(EL1K20*EL2K20-EL1K21*EL2K21)
30753 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
30754 ELSEIF(MSTP(147).EQ.1) THEN
30755 FACQQG=C1*2D0
30756 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
30757 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
30758 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
30759 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
30760 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
30761 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
30762 & +EL1K10*EL2K20*EL1K11*EL2K11)
30763 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
30764 & +EL1K10*EL2K20*EL1K21*EL2K21)
30765 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
30766 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
30767 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
30768 & +EL1K20*EL2K20*EL1K11*EL2K11)
30769 ELSEIF(MSTP(147).EQ.2) THEN
30770 FACQQG=2D0*(C1
30771 & -C2*EL1K11*EL2K11
30772 & -C3*EL1K21*EL2K21
30773 & -C4*EL1K11*EL2K21
30774 & +C5*(EL1K11*EL2K11)**2
30775 & +C6*(EL1K21*EL2K21)**2
30776 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
30777 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
30778 & +(C9+C0)*(EL1K11*EL2K21)**2)
30779 ENDIF
30780 FACQQG=COMFAC*FF*FACQQG
30781 ENDIF
30782 DO 2459 I=MMINA,MMAXA
30783 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30784 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
30785 NCHN=NCHN+1
30786 ISIG(NCHN,1)=I
30787 ISIG(NCHN,2)=-I
30788 ISIG(NCHN,3)=1
30789 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
30790 2459 CONTINUE
30791 ENDIF
30792C...QUARKONIA---
30793
30794 ENDIF
30795
30796 RETURN
30797 END
30798
30799C*********************************************************************
30800
30801C...PYSGWZ
30802C...Subprocess cross sections for W/Z processes,
30803C...except that longitudinal WW scattering is in Higgs sector.
30804C...Auxiliary to PYSIGH.
30805
30806 SUBROUTINE PYSGWZ(NCHN,SIGS)
30807
30808C...Double precision and integer declarations
30809 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30810 IMPLICIT INTEGER(I-N)
30811 INTEGER PYK,PYCHGE,PYCOMP
30812C...Parameter statement to help give large particle numbers.
30813 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30814 &KEXCIT=4000000,KDIMEN=5000000)
30815C...Commonblocks
30816 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30817 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30818 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30819 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
30820 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30821 COMMON/PYINT1/MINT(400),VINT(400)
30822 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30823 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30824 COMMON/PYINT4/MWID(500),WIDS(500,5)
30825 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
30826 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30827 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30828 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30829 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30830 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
30831 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
30832C...Local arrays and complex numbers
30833 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
30834 &HL4(3),HR4(3)
30835 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
30836
30837C...Differential cross section expressions.
30838
30839 IF(ISUB.LE.20) THEN
30840 IF(ISUB.EQ.1) THEN
30841C...f + fbar -> gamma*/Z0
30842 MINT(61)=2
30843 CALL PYWIDT(23,SH,WDTP,WDTE)
30844 HS=SHR*WDTP(0)
30845 FACZ=4D0*COMFAC*3D0
30846 HP0=AEM/3D0*SH
30847 HP1=AEM/3D0*XWC*SH
30848 DO 100 I=MMINA,MMAXA
30849 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30850 EI=KCHG(IABS(I),1)/3D0
30851 AI=SIGN(1D0,EI)
30852 VI=AI-4D0*EI*XWV
30853 HI0=HP0
30854 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
30855 HI1=HP1
30856 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
30857 NCHN=NCHN+1
30858 ISIG(NCHN,1)=I
30859 ISIG(NCHN,2)=-I
30860 ISIG(NCHN,3)=1
30861 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
30862 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
30863 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
30864 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
30865 100 CONTINUE
30866
30867 ELSEIF(ISUB.EQ.2) THEN
30868C...f + fbar' -> W+/-
30869 CALL PYWIDT(24,SH,WDTP,WDTE)
30870 HS=SHR*WDTP(0)
30871 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
30872 HP=AEM/(24D0*XW)*SH
30873 DO 120 I=MMIN1,MMAX1
30874 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
30875 IA=IABS(I)
30876 DO 110 J=MMIN2,MMAX2
30877 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
30878 JA=IABS(J)
30879 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
30880 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
30881 & GOTO 110
30882 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
30883 HI=HP*2D0
30884 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
30885 NCHN=NCHN+1
30886 ISIG(NCHN,1)=I
30887 ISIG(NCHN,2)=J
30888 ISIG(NCHN,3)=1
30889 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
30890 SIGH(NCHN)=HI*FACBW*HF
30891 110 CONTINUE
30892 120 CONTINUE
30893
30894 ELSEIF(ISUB.EQ.15) THEN
30895C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
30896 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
30897C...gamma, gamma/Z interference and Z couplings to final fermion pairs
30898 HFGG=0D0
30899 HFGZ=0D0
30900 HFZZ=0D0
30901 RADC4=1D0+PYALPS(SQM4)/PARU(1)
30902 DO 130 I=1,MIN(16,MDCY(23,3))
30903 IDC=I+MDCY(23,2)-1
30904 IF(MDME(IDC,1).LT.0) GOTO 130
30905 IMDM=0
30906 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
30907 & IMDM=1
30908 IF(I.LE.8) THEN
30909 EF=KCHG(I,1)/3D0
30910 AF=SIGN(1D0,EF+0.1D0)
30911 VF=AF-4D0*EF*XWV
30912 ELSEIF(I.LE.16) THEN
30913 EF=KCHG(I+2,1)/3D0
30914 AF=SIGN(1D0,EF+0.1D0)
30915 VF=AF-4D0*EF*XWV
30916 ENDIF
30917 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
30918 IF(4D0*RM1.LT.1D0) THEN
30919 FCOF=1D0
30920 IF(I.LE.8) FCOF=3D0*RADC4
30921 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
30922 IF(IMDM.EQ.1) THEN
30923 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
30924 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
30925 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
30926 & AF**2*(1D0-4D0*RM1))*BE34
30927 ENDIF
30928 ENDIF
30929 130 CONTINUE
30930C...Propagators: as simulated in PYOFSH and as desired
30931 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
30932 MINT15=MINT(15)
30933 MINT(15)=1
30934 MINT(61)=1
30935 CALL PYWIDT(23,SQM4,WDTP,WDTE)
30936 MINT(15)=MINT15
30937 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
30938 HFGG=HFGG*HFAEM*VINT(111)/SQM4
30939 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
30940 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
30941C...Loop over flavours; consider full gamma/Z structure
30942 DO 140 I=MMINA,MMAXA
30943 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30944 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30945 EI=KCHG(IABS(I),1)/3D0
30946 AI=SIGN(1D0,EI)
30947 VI=AI-4D0*EI*XWV
30948 NCHN=NCHN+1
30949 ISIG(NCHN,1)=I
30950 ISIG(NCHN,2)=-I
30951 ISIG(NCHN,3)=1
30952 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
30953 & (VI**2+AI**2)*HFZZ)/HBW4
30954 140 CONTINUE
30955
30956 ELSEIF(ISUB.EQ.16) THEN
30957C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
30958 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
30959C...Propagators: as simulated in PYOFSH and as desired
30960 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
30961 CALL PYWIDT(24,SQM4,WDTP,WDTE)
30962 GMMWC=SQRT(SQM4)*WDTP(0)
30963 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
30964 FACWG=FACWG*HBW4C/HBW4
30965 DO 160 I=MMIN1,MMAX1
30966 IA=IABS(I)
30967 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
30968 DO 150 J=MMIN2,MMAX2
30969 JA=IABS(J)
30970 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
30971 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
30972 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
30973 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
30974 FCKM=VCKM((IA+1)/2,(JA+1)/2)
30975 NCHN=NCHN+1
30976 ISIG(NCHN,1)=I
30977 ISIG(NCHN,2)=J
30978 ISIG(NCHN,3)=1
30979 SIGH(NCHN)=FACWG*FCKM*WIDSC
30980 150 CONTINUE
30981 160 CONTINUE
30982
30983 ELSEIF(ISUB.EQ.19) THEN
30984C...f + fbar -> gamma + (gamma*/Z0)
30985 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
30986C...gamma, gamma/Z interference and Z couplings to final fermion pairs
30987 HFGG=0D0
30988 HFGZ=0D0
30989 HFZZ=0D0
30990 RADC4=1D0+PYALPS(SQM4)/PARU(1)
30991 DO 170 I=1,MIN(16,MDCY(23,3))
30992 IDC=I+MDCY(23,2)-1
30993 IF(MDME(IDC,1).LT.0) GOTO 170
30994 IMDM=0
30995 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
30996 & IMDM=1
30997 IF(I.LE.8) THEN
30998 EF=KCHG(I,1)/3D0
30999 AF=SIGN(1D0,EF+0.1D0)
31000 VF=AF-4D0*EF*XWV
31001 ELSEIF(I.LE.16) THEN
31002 EF=KCHG(I+2,1)/3D0
31003 AF=SIGN(1D0,EF+0.1D0)
31004 VF=AF-4D0*EF*XWV
31005 ENDIF
31006 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31007 IF(4D0*RM1.LT.1D0) THEN
31008 FCOF=1D0
31009 IF(I.LE.8) FCOF=3D0*RADC4
31010 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31011 IF(IMDM.EQ.1) THEN
31012 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31013 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31014 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31015 & AF**2*(1D0-4D0*RM1))*BE34
31016 ENDIF
31017 ENDIF
31018 170 CONTINUE
31019C...Propagators: as simulated in PYOFSH and as desired
31020 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31021 MINT15=MINT(15)
31022 MINT(15)=1
31023 MINT(61)=1
31024 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31025 MINT(15)=MINT15
31026 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31027 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31028 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31029 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31030C...Loop over flavours; consider full gamma/Z structure
31031 DO 180 I=MMINA,MMAXA
31032 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31033 EI=KCHG(IABS(I),1)/3D0
31034 AI=SIGN(1D0,EI)
31035 VI=AI-4D0*EI*XWV
31036 FCOI=1D0
31037 IF(IABS(I).LE.10) FCOI=FACA/3D0
31038 NCHN=NCHN+1
31039 ISIG(NCHN,1)=I
31040 ISIG(NCHN,2)=-I
31041 ISIG(NCHN,3)=1
31042 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31043 & (VI**2+AI**2)*HFZZ)/HBW4
31044 180 CONTINUE
31045
31046 ELSEIF(ISUB.EQ.20) THEN
31047C...f + fbar' -> gamma + W+/-
31048 FACGW=COMFAC*0.5D0*AEM**2/XW
31049C...Propagators: as simulated in PYOFSH and as desired
31050 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31051 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31052 GMMWC=SQRT(SQM4)*WDTP(0)
31053 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31054 FACGW=FACGW*HBW4C/HBW4
31055C...Anomalous couplings
31056 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31057 TERM2=0D0
31058 TERM3=0D0
31059 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31060 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31061 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31062 & (4D0*SQMW))/(TH+UH)**2
31063 ENDIF
31064 DO 200 I=MMIN1,MMAX1
31065 IA=IABS(I)
31066 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31067 DO 190 J=MMIN2,MMAX2
31068 JA=IABS(J)
31069 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31070 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31071 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31072 & GOTO 190
31073 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31074 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31075 IF(IA.LE.10) THEN
31076 FACWR=UH/(TH+UH)-1D0/3D0
31077 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31078 FCOI=FACA/3D0
31079 ELSE
31080 FACWR=-TH/(TH+UH)
31081 FCKM=1D0
31082 FCOI=1D0
31083 ENDIF
31084 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
31085 NCHN=NCHN+1
31086 ISIG(NCHN,1)=I
31087 ISIG(NCHN,2)=J
31088 ISIG(NCHN,3)=1
31089 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
31090 190 CONTINUE
31091 200 CONTINUE
31092 ENDIF
31093
31094 ELSEIF(ISUB.LE.40) THEN
31095 IF(ISUB.EQ.22) THEN
31096C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
31097C...Kinematics dependence
31098 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
31099 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
31100C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31101 DO 220 I=1,6
31102 DO 210 J=1,3
31103 HGZ(I,J)=0D0
31104 210 CONTINUE
31105 220 CONTINUE
31106 RADC3=1D0+PYALPS(SQM3)/PARU(1)
31107 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31108 DO 230 I=1,MIN(16,MDCY(23,3))
31109 IDC=I+MDCY(23,2)-1
31110 IF(MDME(IDC,1).LT.0) GOTO 230
31111 IMDM=0
31112 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
31113 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
31114 IF(I.LE.8) THEN
31115 EF=KCHG(I,1)/3D0
31116 AF=SIGN(1D0,EF+0.1D0)
31117 VF=AF-4D0*EF*XWV
31118 ELSEIF(I.LE.16) THEN
31119 EF=KCHG(I+2,1)/3D0
31120 AF=SIGN(1D0,EF+0.1D0)
31121 VF=AF-4D0*EF*XWV
31122 ENDIF
31123 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
31124 IF(4D0*RM1.LT.1D0) THEN
31125 FCOF=1D0
31126 IF(I.LE.8) FCOF=3D0*RADC3
31127 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31128 IF(IMDM.GE.1) THEN
31129 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31130 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31131 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
31132 & AF**2*(1D0-4D0*RM1))*BE34
31133 ENDIF
31134 ENDIF
31135 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31136 IF(4D0*RM1.LT.1D0) THEN
31137 FCOF=1D0
31138 IF(I.LE.8) FCOF=3D0*RADC4
31139 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31140 IF(IMDM.GE.1) THEN
31141 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31142 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31143 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
31144 & AF**2*(1D0-4D0*RM1))*BE34
31145 ENDIF
31146 ENDIF
31147 230 CONTINUE
31148C...Propagators: as simulated in PYOFSH and as desired
31149 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
31150 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31151 MINT15=MINT(15)
31152 MINT(15)=1
31153 MINT(61)=1
31154 CALL PYWIDT(23,SQM3,WDTP,WDTE)
31155 MINT(15)=MINT15
31156 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31157 DO 240 J=1,3
31158 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
31159 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
31160 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
31161 240 CONTINUE
31162 MINT15=MINT(15)
31163 MINT(15)=1
31164 MINT(61)=1
31165 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31166 MINT(15)=MINT15
31167 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31168 DO 250 J=1,3
31169 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
31170 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
31171 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
31172 250 CONTINUE
31173C...Loop over flavours; separate left- and right-handed couplings
31174 DO 270 I=MMINA,MMAXA
31175 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
31176 EI=KCHG(IABS(I),1)/3D0
31177 AI=SIGN(1D0,EI)
31178 VI=AI-4D0*EI*XWV
31179 VALI=VI-AI
31180 VARI=VI+AI
31181 FCOI=1D0
31182 IF(IABS(I).LE.10) FCOI=FACA/3D0
31183 DO 260 J=1,3
31184 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
31185 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
31186 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
31187 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
31188 260 CONTINUE
31189 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
31190 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
31191 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
31192 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
31193 NCHN=NCHN+1
31194 ISIG(NCHN,1)=I
31195 ISIG(NCHN,2)=-I
31196 ISIG(NCHN,3)=1
31197 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
31198 270 CONTINUE
31199
31200 ELSEIF(ISUB.EQ.23) THEN
31201C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
31202 FACZW=COMFAC*0.5D0*(AEM/XW)**2
31203 FACZW=FACZW*WIDS(23,2)
31204 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31205 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
31206 DO 290 I=MMIN1,MMAX1
31207 IA=IABS(I)
31208 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
31209 DO 280 J=MMIN2,MMAX2
31210 JA=IABS(J)
31211 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
31212 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
31213 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31214 & GOTO 280
31215 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31216 EI=KCHG(IA,1)/3D0
31217 AI=SIGN(1D0,EI+0.1D0)
31218 VI=AI-4D0*EI*XWV
31219 EJ=KCHG(JA,1)/3D0
31220 AJ=SIGN(1D0,EJ+0.1D0)
31221 VJ=AJ-4D0*EJ*XWV
31222 IF(VI+AI.GT.0) THEN
31223 VISAV=VI
31224 AISAV=AI
31225 VI=VJ
31226 AI=AJ
31227 VJ=VISAV
31228 AJ=AISAV
31229 ENDIF
31230 FCKM=1D0
31231 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
31232 FCOI=1D0
31233 IF(IA.LE.10) FCOI=FACA/3D0
31234 NCHN=NCHN+1
31235 ISIG(NCHN,1)=I
31236 ISIG(NCHN,2)=J
31237 ISIG(NCHN,3)=1
31238 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
31239 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
31240 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
31241 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
31242 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
31243 & WIDS(24,(5-KCHW)/2)
31244C***Protect against slightly negative cross sections. (Reason yet to be
31245C***sorted out. One possibility: addition of width to the W propagator.)
31246 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
31247 280 CONTINUE
31248 290 CONTINUE
31249
31250 ELSEIF(ISUB.EQ.25) THEN
31251C...f + fbar -> W+ + W-
31252C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
31253 GMMZC=GMMZ
31254 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
31255 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
31256 CALL PYWIDT(24,SQM3,WDTP,WDTE)
31257 GMMW3=SQRT(SQM3)*WDTP(0)
31258 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
31259 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31260 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31261 GMMW4=SQRT(SQM4)*WDTP(0)
31262 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
31263C...Kinematical functions
31264 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31265 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
31266 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
31267 GT=THUH34+4D0*THUH/TH2
31268 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
31269 GU=THUH34+4D0*THUH/UH2
31270 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
31271C...Common factors and couplings
31272 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
31273 FACWW=FACWW*WIDS(24,1)
31274 CGG=AEM**2/2D0
31275 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
31276 CZZ=AEM**2/(32D0*XW**2)*HBWZC
31277 CNG=AEM**2/(4D0*XW)
31278 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
31279 CNN=AEM**2/(16D0*XW**2)
31280C...Coulomb factor for W+W- pair
31281 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
31282 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
31283 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
31284 IF(COULE.LT.100D0*PMAS(24,2)) THEN
31285 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
31286 & PMAS(24,2)**2)-COULE))
31287 ELSE
31288 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
31289 ENDIF
31290 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
31291 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
31292 & PMAS(24,2)**2)+COULE))
31293 ELSE
31294 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
31295 & ABS(COULE)))
31296 ENDIF
31297 IF(MSTP(40).EQ.1) THEN
31298 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
31299 & MAX(1D-10,2D0*COULP*COULP1))
31300 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
31301 ELSEIF(MSTP(40).EQ.2) THEN
31302 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
31303 COULCP=DCMPLX(0D0,DBLE(COULP))
31304 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
31305 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
31306 & (4D0*COULCP)*LOG(COULCD)
31307 COULCS=DCMPLX(0D0,0D0)
31308 NSTP=100
31309 DO 300 ISTP=1,NSTP
31310 COULXX=(ISTP-0.5)/NSTP
31311 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
31312 & (1D0+COULXX/COULCD))
31313 300 CONTINUE
31314 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
31315 & (COULCS/NSTP)
31316 FACCOU=ABS(COULCR)**2
31317 ELSEIF(MSTP(40).EQ.3) THEN
31318 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
31319 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
31320 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
31321 ENDIF
31322 ELSEIF(MSTP(40).EQ.4) THEN
31323 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
31324 ELSE
31325 FACCOU=1D0
31326 ENDIF
31327 VINT(95)=FACCOU
31328 FACWW=FACWW*FACCOU
31329C...Loop over allowed flavours
31330 DO 310 I=MMINA,MMAXA
31331 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
31332 EI=KCHG(IABS(I),1)/3D0
31333 AI=SIGN(1D0,EI+0.1D0)
31334 VI=AI-4D0*EI*XWV
31335 FCOI=1D0
31336 IF(IABS(I).LE.10) FCOI=FACA/3D0
31337 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
31338 IF(AI.LT.0D0) THEN
31339 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
31340 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
31341 ELSE
31342 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
31343 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
31344 ENDIF
31345 ELSE
31346 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31347 BET=SQRT(1D0-4D0*XMW02/SH)
31348 GAT=1D0/SQRT(1D0-BET**2)
31349 STHE2=1D0-CTH**2
31350 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
31351 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
31352 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
31353 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
31354 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
31355 & (1D0-2D0*BET*CTH+BET**2))
31356 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
31357 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
31358 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
31359 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
31360 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
31361 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
31362 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
31363 DSIGWW=ATOT
31364 ENDIF
31365 NCHN=NCHN+1
31366 ISIG(NCHN,1)=I
31367 ISIG(NCHN,2)=-I
31368 ISIG(NCHN,3)=1
31369 SIGH(NCHN)=FACWW*FCOI*DSIGWW
31370 310 CONTINUE
31371
31372 ELSEIF(ISUB.EQ.30) THEN
31373C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
31374 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
31375 & (-SH*UH)
31376C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31377 HFGG=0D0
31378 HFGZ=0D0
31379 HFZZ=0D0
31380 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31381 DO 320 I=1,MIN(16,MDCY(23,3))
31382 IDC=I+MDCY(23,2)-1
31383 IF(MDME(IDC,1).LT.0) GOTO 320
31384 IMDM=0
31385 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31386 & IMDM=1
31387 IF(I.LE.8) THEN
31388 EF=KCHG(I,1)/3D0
31389 AF=SIGN(1D0,EF+0.1D0)
31390 VF=AF-4D0*EF*XWV
31391 ELSEIF(I.LE.16) THEN
31392 EF=KCHG(I+2,1)/3D0
31393 AF=SIGN(1D0,EF+0.1D0)
31394 VF=AF-4D0*EF*XWV
31395 ENDIF
31396 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31397 IF(4D0*RM1.LT.1D0) THEN
31398 FCOF=1D0
31399 IF(I.LE.8) FCOF=3D0*RADC4
31400 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31401 IF(IMDM.EQ.1) THEN
31402 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31403 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31404 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31405 & AF**2*(1D0-4D0*RM1))*BE34
31406 ENDIF
31407 ENDIF
31408 320 CONTINUE
31409C...Propagators: as simulated in PYOFSH and as desired
31410 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31411 MINT15=MINT(15)
31412 MINT(15)=1
31413 MINT(61)=1
31414 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31415 MINT(15)=MINT15
31416 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31417 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31418 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31419 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31420C...Loop over flavours; consider full gamma/Z structure
31421 DO 340 I=MMINA,MMAXA
31422 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
31423 EI=KCHG(IABS(I),1)/3D0
31424 AI=SIGN(1D0,EI)
31425 VI=AI-4D0*EI*XWV
31426 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
31427 & (VI**2+AI**2)*HFZZ)/HBW4
31428 DO 330 ISDE=1,2
31429 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
31430 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
31431 NCHN=NCHN+1
31432 ISIG(NCHN,ISDE)=I
31433 ISIG(NCHN,3-ISDE)=21
31434 ISIG(NCHN,3)=1
31435 SIGH(NCHN)=FACZQ
31436 330 CONTINUE
31437 340 CONTINUE
31438
31439 ELSEIF(ISUB.EQ.31) THEN
31440C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
31441 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
31442 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
31443C...Propagators: as simulated in PYOFSH and as desired
31444 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31445 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31446 GMMWC=SQRT(SQM4)*WDTP(0)
31447 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31448 FACWQ=FACWQ*HBW4C/HBW4
31449 DO 360 I=MMINA,MMAXA
31450 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
31451 IA=IABS(I)
31452 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
31453 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31454 DO 350 ISDE=1,2
31455 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
31456 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
31457 NCHN=NCHN+1
31458 ISIG(NCHN,ISDE)=I
31459 ISIG(NCHN,3-ISDE)=21
31460 ISIG(NCHN,3)=1
31461 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
31462 350 CONTINUE
31463 360 CONTINUE
31464
31465 ELSEIF(ISUB.EQ.35) THEN
31466C...f + gamma -> f + (gamma*/Z0)
31467 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
31468 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
31469 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
31470 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
31471 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
31472 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
31473 ELSE
31474 FZQN=SH2+UH2+2D0*SQM4*TH
31475 FZQDTM=-SH*UH
31476 ENDIF
31477 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
31478C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31479 HFGG=0D0
31480 HFGZ=0D0
31481 HFZZ=0D0
31482 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31483 DO 370 I=1,MIN(16,MDCY(23,3))
31484 IDC=I+MDCY(23,2)-1
31485 IF(MDME(IDC,1).LT.0) GOTO 370
31486 IMDM=0
31487 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31488 & IMDM=1
31489 IF(I.LE.8) THEN
31490 EF=KCHG(I,1)/3D0
31491 AF=SIGN(1D0,EF+0.1D0)
31492 VF=AF-4D0*EF*XWV
31493 ELSEIF(I.LE.16) THEN
31494 EF=KCHG(I+2,1)/3D0
31495 AF=SIGN(1D0,EF+0.1D0)
31496 VF=AF-4D0*EF*XWV
31497 ENDIF
31498 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31499 IF(4D0*RM1.LT.1D0) THEN
31500 FCOF=1D0
31501 IF(I.LE.8) FCOF=3D0*RADC4
31502 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31503 IF(IMDM.EQ.1) THEN
31504 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31505 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31506 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31507 & AF**2*(1D0-4D0*RM1))*BE34
31508 ENDIF
31509 ENDIF
31510 370 CONTINUE
31511C...Propagators: as simulated in PYOFSH and as desired
31512 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31513 MINT15=MINT(15)
31514 MINT(15)=1
31515 MINT(61)=1
31516 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31517 MINT(15)=MINT15
31518 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31519 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31520 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31521 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31522C...Loop over flavours; consider full gamma/Z structure
31523 DO 390 I=MMINA,MMAXA
31524 IF(I.EQ.0) GOTO 390
31525 EI=KCHG(IABS(I),1)/3D0
31526 AI=SIGN(1D0,EI)
31527 VI=AI-4D0*EI*XWV
31528 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31529 & (VI**2+AI**2)*HFZZ)/HBW4
31530 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
31531 DO 380 ISDE=1,2
31532 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
31533 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
31534 NCHN=NCHN+1
31535 ISIG(NCHN,ISDE)=I
31536 ISIG(NCHN,3-ISDE)=22
31537 ISIG(NCHN,3)=1
31538 SIGH(NCHN)=FACZQ*FZQN/FZQD
31539 380 CONTINUE
31540 390 CONTINUE
31541
31542 ELSEIF(ISUB.EQ.36) THEN
31543C...f + gamma -> f' + W+/-
31544 FWQ=COMFAC*AEM**2/(2D0*XW)*
31545 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
31546C...Propagators: as simulated in PYOFSH and as desired
31547 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31548 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31549 GMMWC=SQRT(SQM4)*WDTP(0)
31550 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31551 FWQ=FWQ*HBW4C/HBW4
31552 DO 410 I=MMINA,MMAXA
31553 IF(I.EQ.0) GOTO 410
31554 IA=IABS(I)
31555 EIA=ABS(KCHG(IABS(I),1)/3D0)
31556 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
31557 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
31558 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31559 DO 400 ISDE=1,2
31560 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
31561 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
31562 NCHN=NCHN+1
31563 ISIG(NCHN,ISDE)=I
31564 ISIG(NCHN,3-ISDE)=22
31565 ISIG(NCHN,3)=1
31566 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
31567 400 CONTINUE
31568 410 CONTINUE
31569 ENDIF
31570
31571 ELSEIF(ISUB.LE.100) THEN
31572 IF(ISUB.EQ.69) THEN
31573C...gamma + gamma -> W+ + W-
31574 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
31575 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
31576 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
31577 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
31578 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
31579 NCHN=NCHN+1
31580 ISIG(NCHN,1)=22
31581 ISIG(NCHN,2)=22
31582 ISIG(NCHN,3)=1
31583 SIGH(NCHN)=FACWW
31584 420 CONTINUE
31585
31586 ELSEIF(ISUB.EQ.70) THEN
31587C...gamma + W+/- -> Z0 + W+/-
31588 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
31589 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
31590 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
31591 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
31592 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
31593 DO 440 KCHW=1,-1,-2
31594 DO 430 ISDE=1,2
31595 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
31596 NCHN=NCHN+1
31597 ISIG(NCHN,ISDE)=22
31598 ISIG(NCHN,3-ISDE)=24*KCHW
31599 ISIG(NCHN,3)=1
31600 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
31601 430 CONTINUE
31602 440 CONTINUE
31603 ENDIF
31604 ENDIF
31605
31606 RETURN
31607 END
31608
31609C*********************************************************************
31610
31611C...PYSGHG
31612C...Subprocess cross sections for Higgs processes,
31613C...except Higgs pairs in PYSGSU, but including WW scattering.
31614C...Auxiliary to PYSIGH.
31615
31616 SUBROUTINE PYSGHG(NCHN,SIGS)
31617
31618C...Double precision and integer declarations
31619 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31620 IMPLICIT INTEGER(I-N)
31621 INTEGER PYK,PYCHGE,PYCOMP
31622C...Parameter statement to help give large particle numbers.
31623 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31624 &KEXCIT=4000000,KDIMEN=5000000)
31625C...Commonblocks
31626 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31627 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31628 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31629 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31630 COMMON/PYINT1/MINT(400),VINT(400)
31631 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31632 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31633 COMMON/PYINT4/MWID(500),WIDS(500,5)
31634 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31635 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
31636 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31637 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31638 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31639 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31640 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
31641 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
31642C...Local arrays and complex variables
31643 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
31644 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
31645 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
31646
31647C...Convert H or A process into equivalent h one
31648 IHIGG=1
31649 KFHIGG=25
31650 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
31651 KFHIGG=KFPR(ISUB,1)
31652 END IF
31653 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
31654 &ISUB.LE.190)) THEN
31655 IHIGG=2
31656 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
31657 KFHIGG=33+IHIGG
31658 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
31659 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
31660 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
31661 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
31662 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
31663 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
31664 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
31665 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
31666 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
31667 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
31668 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
31669 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
31670 ENDIF
31671 SQMH=PMAS(KFHIGG,1)**2
31672 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
31673
31674C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
31675 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
31676 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
31677C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
31678 IF(MSTP(46).LE.4) THEN
31679 HDTLH=LOG(PMAS(25,1)/PARP(44))
31680 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
31681 HDTNR=-1D0/18D0+HDTLH/6D0
31682 ELSE
31683 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
31684 HDTLQ=LOG(PARP(45)/PARP(44))
31685 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
31686 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
31687 ENDIF
31688
31689C...Calculate lowest and next-to-lowest order partial wave amplitudes
31690 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
31691 A00L=DBLE(HDTV*SH)
31692 A20L=-0.5D0*A00L
31693 A11L=A00L/6D0
31694 HDTLS=LOG(SH/PARP(44)**2)
31695 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
31696 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
31697 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
31698 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
31699 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
31700 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
31701 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
31702 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
31703
31704C...Unitarize partial wave amplitudes with Pade or K-matrix method
31705 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
31706 A00U=A00L/(1D0-A004/A00L)
31707 A20U=A20L/(1D0-A204/A20L)
31708 A11U=A11L/(1D0-A114/A11L)
31709 ELSE
31710 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
31711 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
31712 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
31713 ENDIF
31714 ENDIF
31715
31716C...Differential cross section expressions.
31717
31718 IF(ISUB.LE.60) THEN
31719 IF(ISUB.EQ.3) THEN
31720C...f + fbar -> h0 (or H0, or A0)
31721 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
31722 HS=SHR*WDTP(0)
31723 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
31724 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
31725 & FACBW=0D0
31726 HP=AEM/(8D0*XW)*SH/SQMW*SH
31727 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
31728 DO 100 I=MMINA,MMAXA
31729 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31730 IA=IABS(I)
31731 RMQ=PYMRUN(IA,SH)**2/SH
31732 HI=HP*RMQ
31733 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
31734 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
31735 IKFI=1
31736 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
31737 IF(IA.GT.10) IKFI=3
31738 HI=HI*PARU(150+10*IHIGG+IKFI)**2
31739 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
31740 HI=HI/(1D0+RMSS(41))**2
31741 IF(IHIGG.NE.3) THEN
31742 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
31743 & PARU(151+10*IHIGG))**2
31744 ENDIF
31745 ENDIF
31746 ENDIF
31747 NCHN=NCHN+1
31748 ISIG(NCHN,1)=I
31749 ISIG(NCHN,2)=-I
31750 ISIG(NCHN,3)=1
31751 SIGH(NCHN)=HI*FACBW*HF
31752 100 CONTINUE
31753
31754 ELSEIF(ISUB.EQ.5) THEN
31755C...Z0 + Z0 -> h0
31756 CALL PYWIDT(25,SH,WDTP,WDTE)
31757 HS=SHR*WDTP(0)
31758 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
31759 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
31760 HP=AEM/(8D0*XW)*SH/SQMW*SH
31761 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
31762 HI=HP/4D0
31763 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
31764 DO 120 I=MMIN1,MMAX1
31765 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31766 DO 110 J=MMIN2,MMAX2
31767 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31768 EI=KCHG(IABS(I),1)/3D0
31769 AI=SIGN(1D0,EI)
31770 VI=AI-4D0*EI*XWV
31771 EJ=KCHG(IABS(J),1)/3D0
31772 AJ=SIGN(1D0,EJ)
31773 VJ=AJ-4D0*EJ*XWV
31774 NCHN=NCHN+1
31775 ISIG(NCHN,1)=I
31776 ISIG(NCHN,2)=J
31777 ISIG(NCHN,3)=1
31778 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
31779 110 CONTINUE
31780 120 CONTINUE
31781
31782 ELSEIF(ISUB.EQ.8) THEN
31783C...W+ + W- -> h0
31784 CALL PYWIDT(25,SH,WDTP,WDTE)
31785 HS=SHR*WDTP(0)
31786 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
31787 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
31788 HP=AEM/(8D0*XW)*SH/SQMW*SH
31789 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
31790 HI=HP/2D0
31791 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
31792 DO 140 I=MMIN1,MMAX1
31793 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
31794 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
31795 DO 130 J=MMIN2,MMAX2
31796 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
31797 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
31798 IF(EI*EJ.GT.0D0) GOTO 130
31799 NCHN=NCHN+1
31800 ISIG(NCHN,1)=I
31801 ISIG(NCHN,2)=J
31802 ISIG(NCHN,3)=1
31803 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
31804 130 CONTINUE
31805 140 CONTINUE
31806
31807 ELSEIF(ISUB.EQ.24) THEN
31808C...f + fbar -> Z0 + h0 (or H0, or A0)
31809C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
31810 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
31811 CALL PYWIDT(23,SQM3,WDTP,WDTE)
31812 GMMZ3=SQRT(SQM3)*WDTP(0)
31813 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
31814 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
31815 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
31816 GMMH4=SQRT(SQM4)*WDTP(0)
31817 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
31818 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31819 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
31820 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
31821 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
31822 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
31823 & PARU(154+10*IHIGG)**2
31824 DO 150 I=MMINA,MMAXA
31825 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
31826 EI=KCHG(IABS(I),1)/3D0
31827 AI=SIGN(1D0,EI)
31828 VI=AI-4D0*EI*XWV
31829 FCOI=1D0
31830 IF(IABS(I).LE.10) FCOI=FACA/3D0
31831 NCHN=NCHN+1
31832 ISIG(NCHN,1)=I
31833 ISIG(NCHN,2)=-I
31834 ISIG(NCHN,3)=1
31835 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
31836 150 CONTINUE
31837
31838 ELSEIF(ISUB.EQ.26) THEN
31839C...f + fbar' -> W+/- + h0 (or H0, or A0)
31840C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
31841 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
31842 CALL PYWIDT(24,SQM3,WDTP,WDTE)
31843 GMMW3=SQRT(SQM3)*WDTP(0)
31844 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
31845 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
31846 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
31847 GMMH4=SQRT(SQM4)*WDTP(0)
31848 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
31849 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
31850 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
31851 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
31852 FACHW=FACHW*WIDS(KFHIGG,2)
31853 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
31854 & PARU(155+10*IHIGG)**2
31855 DO 170 I=MMIN1,MMAX1
31856 IA=IABS(I)
31857 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
31858 DO 160 J=MMIN2,MMAX2
31859 JA=IABS(J)
31860 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
31861 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
31862 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31863 & GOTO 160
31864 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31865 FCKM=1D0
31866 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
31867 FCOI=1D0
31868 IF(IA.LE.10) FCOI=FACA/3D0
31869 NCHN=NCHN+1
31870 ISIG(NCHN,1)=I
31871 ISIG(NCHN,2)=J
31872 ISIG(NCHN,3)=1
31873 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
31874 160 CONTINUE
31875 170 CONTINUE
31876
31877 ELSEIF(ISUB.EQ.32) THEN
31878C...f + g -> f + h0 (q + g -> q + h0 only)
31879 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
31880C...H propagator: as simulated in PYOFSH and as desired
31881 SQMHC=PMAS(25,1)**2
31882 GMMHC=PMAS(25,1)*PMAS(25,2)
31883 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
31884 CALL PYWIDT(25,SQM4,WDTP,WDTE)
31885 GMMHCC=SQRT(SQM4)*WDTP(0)
31886 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
31887 FHCQ=FHCQ*HBW4C/HBW4
31888 DO 190 I=MMINA,MMAXA
31889 IA=IABS(I)
31890 IF(IA.NE.5) GOTO 190
31891 SQML=PYMRUN(IA,SH)**2
31892 SQMQ=PMAS(IA,1)**2
31893 FACHCQ=FHCQ*SQML/SQMW*
31894 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
31895 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
31896 & (SQM4-SQMQ-SH)/SH)
31897 DO 180 ISDE=1,2
31898 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
31899 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
31900 NCHN=NCHN+1
31901 ISIG(NCHN,ISDE)=I
31902 ISIG(NCHN,3-ISDE)=21
31903 ISIG(NCHN,3)=1
31904 SIGH(NCHN)=FACHCQ*WIDS(25,2)
31905 180 CONTINUE
31906 190 CONTINUE
31907 ENDIF
31908
31909 ELSEIF(ISUB.LE.80) THEN
31910 IF(ISUB.EQ.71) THEN
31911C...Z0 + Z0 -> Z0 + Z0
31912 IF(SH.LE.4.01D0*SQMZ) GOTO 220
31913
31914 IF(MSTP(46).LE.2) THEN
31915C...Exact scattering ME:s for on-mass-shell gauge bosons
31916 BE2=1D0-4D0*SQMZ/SH
31917 TH=-0.5D0*SH*BE2*(1D0-CTH)
31918 UH=-0.5D0*SH*BE2*(1D0+CTH)
31919 IF(MAX(TH,UH).GT.-1D0) GOTO 220
31920 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
31921 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
31922 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
31923 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
31924 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
31925 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
31926 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
31927 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
31928 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
31929 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
31930 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
31931 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
31932 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
31933 & (ASHIM+ATHIM+AUHIM)**2)
31934 IF(MSTP(46).EQ.2) FACZZ=0D0
31935
31936 ELSE
31937C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
31938 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
31939 & ABS(A00U+2D0*A20U)**2
31940 ENDIF
31941 FACZZ=FACZZ*WIDS(23,1)
31942
31943 DO 210 I=MMIN1,MMAX1
31944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
31945 EI=KCHG(IABS(I),1)/3D0
31946 AI=SIGN(1D0,EI)
31947 VI=AI-4D0*EI*XWV
31948 AVI=AI**2+VI**2
31949 DO 200 J=MMIN2,MMAX2
31950 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
31951 EJ=KCHG(IABS(J),1)/3D0
31952 AJ=SIGN(1D0,EJ)
31953 VJ=AJ-4D0*EJ*XWV
31954 AVJ=AJ**2+VJ**2
31955 NCHN=NCHN+1
31956 ISIG(NCHN,1)=I
31957 ISIG(NCHN,2)=J
31958 ISIG(NCHN,3)=1
31959 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
31960 200 CONTINUE
31961 210 CONTINUE
31962 220 CONTINUE
31963
31964 ELSEIF(ISUB.EQ.72) THEN
31965C...Z0 + Z0 -> W+ + W-
31966 IF(SH.LE.4.01D0*SQMZ) GOTO 250
31967
31968 IF(MSTP(46).LE.2) THEN
31969C...Exact scattering ME:s for on-mass-shell gauge bosons
31970 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
31971 CTH2=CTH**2
31972 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
31973 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
31974 IF(MAX(TH,UH).GT.-1D0) GOTO 250
31975 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
31976 & (1D0-2D0*SQMZ/SH)
31977 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
31978 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
31979 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
31980 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
31981 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
31982 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
31983 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
31984 ATWIM=0D0
31985 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
31986 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
31987 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
31988 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
31989 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
31990 AUWIM=0D0
31991 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
31992 A4IM=0D0
31993 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
31994 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
31995 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
31996 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
31997 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
31998 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
31999 & (ATWIM+AUWIM+A4IM)**2)
32000
32001 ELSE
32002C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32003 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32004 & ABS(A00U-A20U)**2
32005 ENDIF
32006 FACWW=FACWW*WIDS(24,1)
32007
32008 DO 240 I=MMIN1,MMAX1
32009 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32010 EI=KCHG(IABS(I),1)/3D0
32011 AI=SIGN(1D0,EI)
32012 VI=AI-4D0*EI*XWV
32013 AVI=AI**2+VI**2
32014 DO 230 J=MMIN2,MMAX2
32015 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32016 EJ=KCHG(IABS(J),1)/3D0
32017 AJ=SIGN(1D0,EJ)
32018 VJ=AJ-4D0*EJ*XWV
32019 AVJ=AJ**2+VJ**2
32020 NCHN=NCHN+1
32021 ISIG(NCHN,1)=I
32022 ISIG(NCHN,2)=J
32023 ISIG(NCHN,3)=1
32024 SIGH(NCHN)=FACWW*AVI*AVJ
32025 230 CONTINUE
32026 240 CONTINUE
32027 250 CONTINUE
32028
32029 ELSEIF(ISUB.EQ.73) THEN
32030C...Z0 + W+/- -> Z0 + W+/-
32031 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32032
32033 IF(MSTP(46).LE.2) THEN
32034C...Exact scattering ME:s for on-mass-shell gauge bosons
32035 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32036 EP1=1D0-(SQMZ-SQMW)/SH
32037 EP2=1D0+(SQMZ-SQMW)/SH
32038 TH=-0.5D0*SH*BE2*(1D0-CTH)
32039 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32040 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32041 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32042 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32043 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32044 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32045 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32046 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32047 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32048 ASWIM=0D0
32049 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32050 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32051 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32052 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32053 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32054 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32055 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32056 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32057 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32058 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32059 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32060 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32061 AUWIM=0D0
32062 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32063 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32064 A4IM=0D0
32065 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32066 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32067 IF(MSTP(46).LE.0) FACZW=0D0
32068 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32069 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32070 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32071 & (ASWIM+AUWIM+A4IM)**2)
32072
32073 ELSE
32074C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32075 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32076 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32077 ENDIF
32078 FACZW=FACZW*WIDS(23,2)
32079
32080 DO 270 I=MMIN1,MMAX1
32081 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
32082 EI=KCHG(IABS(I),1)/3D0
32083 AI=SIGN(1D0,EI)
32084 VI=AI-4D0*EI*XWV
32085 AVI=AI**2+VI**2
32086 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
32087 DO 260 J=MMIN2,MMAX2
32088 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
32089 EJ=KCHG(IABS(J),1)/3D0
32090 AJ=SIGN(1D0,EJ)
32091 VJ=AI-4D0*EJ*XWV
32092 AVJ=AJ**2+VJ**2
32093 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
32094 NCHN=NCHN+1
32095 ISIG(NCHN,1)=I
32096 ISIG(NCHN,2)=J
32097 ISIG(NCHN,3)=1
32098 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
32099 NCHN=NCHN+1
32100 ISIG(NCHN,1)=I
32101 ISIG(NCHN,2)=J
32102 ISIG(NCHN,3)=2
32103 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
32104 260 CONTINUE
32105 270 CONTINUE
32106 280 CONTINUE
32107
32108 ELSEIF(ISUB.EQ.75) THEN
32109C...W+ + W- -> gamma + gamma
32110
32111 ELSEIF(ISUB.EQ.76) THEN
32112C...W+ + W- -> Z0 + Z0
32113 IF(SH.LE.4.01D0*SQMZ) GOTO 310
32114
32115 IF(MSTP(46).LE.2) THEN
32116C...Exact scattering ME:s for on-mass-shell gauge bosons
32117 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32118 CTH2=CTH**2
32119 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32120 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32121 IF(MAX(TH,UH).GT.-1D0) GOTO 310
32122 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32123 & (1D0-2D0*SQMZ/SH)
32124 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32125 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32126 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32127 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32128 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32129 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32130 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32131 ATWIM=0D0
32132 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32133 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32134 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32135 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32136 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32137 AUWIM=0D0
32138 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32139 A4IM=0D0
32140 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
32141 & (SH/SQMW)**2*SH2
32142 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32143 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32144 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32145 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
32146 & (ATWIM+AUWIM+A4IM)**2)
32147
32148 ELSE
32149C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32150 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
32151 & ABS(A00U-A20U)**2
32152 ENDIF
32153 FACZZ=FACZZ*WIDS(23,1)
32154
32155 DO 300 I=MMIN1,MMAX1
32156 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
32157 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32158 DO 290 J=MMIN2,MMAX2
32159 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
32160 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32161 IF(EI*EJ.GT.0D0) GOTO 290
32162 NCHN=NCHN+1
32163 ISIG(NCHN,1)=I
32164 ISIG(NCHN,2)=J
32165 ISIG(NCHN,3)=1
32166 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
32167 290 CONTINUE
32168 300 CONTINUE
32169 310 CONTINUE
32170
32171 ELSEIF(ISUB.EQ.77) THEN
32172C...W+/- + W+/- -> W+/- + W+/-
32173 IF(SH.LE.4.01D0*SQMW) GOTO 340
32174
32175 IF(MSTP(46).LE.2) THEN
32176C...Exact scattering ME:s for on-mass-shell gauge bosons
32177 BE2=1D0-4D0*SQMW/SH
32178 BE4=BE2**2
32179 CTH2=CTH**2
32180 CTH3=CTH**3
32181 TH=-0.5D0*SH*BE2*(1D0-CTH)
32182 UH=-0.5D0*SH*BE2*(1D0+CTH)
32183 IF(MAX(TH,UH).GT.-1D0) GOTO 340
32184 SHANG=(1D0+BE2)**2
32185 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32186 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32187 THANG=(BE2-CTH)**2
32188 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32189 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32190 UHANG=(BE2+CTH)**2
32191 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32192 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32193 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
32194 ASGRE=XW*SGZANG
32195 ASGIM=0D0
32196 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
32197 ASZIM=0D0
32198 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
32199 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
32200 ATGRE=0.5D0*XW*SH/TH*TGZANG
32201 ATGIM=0D0
32202 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
32203 ATZIM=0D0
32204 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
32205 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
32206 AUGRE=0.5D0*XW*SH/UH*UGZANG
32207 AUGIM=0D0
32208 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
32209 AUZIM=0D0
32210 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
32211 A4AIM=0D0
32212 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
32213 A4SIM=0D0
32214 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
32215 & (SH/SQMW)**2*SH2
32216 IF(MSTP(46).LE.0) THEN
32217 AWWARE=ASHRE
32218 AWWAIM=ASHIM
32219 AWWSRE=0D0
32220 AWWSIM=0D0
32221 ELSEIF(MSTP(46).EQ.1) THEN
32222 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
32223 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
32224 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
32225 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
32226 ELSE
32227 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
32228 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
32229 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
32230 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
32231 ENDIF
32232 AWWA2=AWWARE**2+AWWAIM**2
32233 AWWS2=AWWSRE**2+AWWSIM**2
32234
32235 ELSE
32236C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32237 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
32238 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
32239 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
32240 ENDIF
32241
32242 DO 330 I=MMIN1,MMAX1
32243 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
32244 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32245 DO 320 J=MMIN2,MMAX2
32246 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
32247 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32248 IF(EI*EJ.LT.0D0) THEN
32249C...W+W-
32250 IF(MSTP(45).EQ.1) GOTO 320
32251 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
32252 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
32253 ELSE
32254C...W+W+/W-W-
32255 IF(MSTP(45).EQ.2) GOTO 320
32256 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
32257 IF(MSTP(46).GE.3) FACWW=FWWS
32258 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
32259 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
32260 ENDIF
32261 NCHN=NCHN+1
32262 ISIG(NCHN,1)=I
32263 ISIG(NCHN,2)=J
32264 ISIG(NCHN,3)=1
32265 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
32266 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
32267 320 CONTINUE
32268 330 CONTINUE
32269 340 CONTINUE
32270 ENDIF
32271
32272 ELSEIF(ISUB.LE.120) THEN
32273 IF(ISUB.EQ.102) THEN
32274C...g + g -> h0 (or H0, or A0)
32275 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32276 WDTP13=0D0
32277 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32278 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32279 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32280 345 CONTINUE
32281 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32282 & '(PYSGHG:) did not find Higgs -> g g channel')
32283 HS=SHR*WDTP(0)
32284 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32285 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32286 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32287 & FACBW=0D0
32288 HI=SHR*WDTP13/32D0
32289 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
32290 NCHN=NCHN+1
32291 ISIG(NCHN,1)=21
32292 ISIG(NCHN,2)=21
32293 ISIG(NCHN,3)=1
32294 SIGH(NCHN)=HI*FACBW*HF
32295 350 CONTINUE
32296
32297 ELSEIF(ISUB.EQ.103) THEN
32298C...gamma + gamma -> h0 (or H0, or A0)
32299 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32300 WDTP14=0D0
32301 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32302 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
32303 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
32304 355 CONTINUE
32305 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
32306 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
32307 HS=SHR*WDTP(0)
32308 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32309 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32310 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32311 & FACBW=0D0
32312 HI=SHR*WDTP14*2D0
32313 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
32314 NCHN=NCHN+1
32315 ISIG(NCHN,1)=22
32316 ISIG(NCHN,2)=22
32317 ISIG(NCHN,3)=1
32318 SIGH(NCHN)=HI*FACBW*HF
32319 360 CONTINUE
32320
32321 ELSEIF(ISUB.EQ.110) THEN
32322C...f + fbar -> gamma + h0
32323 THUH=MAX(TH*UH,SH*CKIN(3)**2)
32324 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
32325 FACHG=FACHG*WIDS(KFHIGG,2)
32326C...Calculate loop contributions for intermediate gamma* and Z0
32327 CIGTOT=DCMPLX(0D0,0D0)
32328 CIZTOT=DCMPLX(0D0,0D0)
32329 JMAX=3*MSTP(1)+1
32330 DO 370 J=1,JMAX
32331 IF(J.LE.2*MSTP(1)) THEN
32332 FNC=1D0
32333 EJ=KCHG(J,1)/3D0
32334 AJ=SIGN(1D0,EJ+0.1D0)
32335 VJ=AJ-4D0*EJ*XWV
32336 BALP=SQM4/(2D0*PMAS(J,1))**2
32337 BBET=SH/(2D0*PMAS(J,1))**2
32338 ELSEIF(J.LE.3*MSTP(1)) THEN
32339 FNC=3D0
32340 JL=2*(J-2*MSTP(1))-1
32341 EJ=KCHG(10+JL,1)/3D0
32342 AJ=SIGN(1D0,EJ+0.1D0)
32343 VJ=AJ-4D0*EJ*XWV
32344 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
32345 BBET=SH/(2D0*PMAS(10+JL,1))**2
32346 ELSE
32347 BALP=SQM4/(2D0*PMAS(24,1))**2
32348 BBET=SH/(2D0*PMAS(24,1))**2
32349 ENDIF
32350 BABI=1D0/(BALP-BBET)
32351 IF(BALP.LT.1D0) THEN
32352 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
32353 F1ALP=F0ALP**2
32354 ELSE
32355 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
32356 & -DBLE(0.5D0*PARU(1)))
32357 F1ALP=-F0ALP**2
32358 ENDIF
32359 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
32360 IF(BBET.LT.1D0) THEN
32361 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
32362 F1BET=F0BET**2
32363 ELSE
32364 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
32365 & -DBLE(0.5D0*PARU(1)))
32366 F1BET=-F0BET**2
32367 ENDIF
32368 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
32369 IF(J.LE.3*MSTP(1)) THEN
32370 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
32371 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
32372 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
32373 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
32374 ELSE
32375 TXW=XW/XW1
32376 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
32377 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
32378 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
32379 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
32380 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
32381 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
32382 & (F1BET-F1ALP))
32383 ENDIF
32384 370 CONTINUE
32385 CIGTOT=CIGTOT/DBLE(SH)
32386 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
32387C...Loop over initial flavours
32388 DO 380 I=MMINA,MMAXA
32389 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
32390 EI=KCHG(IABS(I),1)/3D0
32391 AI=SIGN(1D0,EI)
32392 VI=AI-4D0*EI*XWV
32393 FCOI=1D0
32394 IF(IABS(I).LE.10) FCOI=FACA/3D0
32395 NCHN=NCHN+1
32396 ISIG(NCHN,1)=I
32397 ISIG(NCHN,2)=-I
32398 ISIG(NCHN,3)=1
32399 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
32400 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
32401 380 CONTINUE
32402
32403 ELSEIF(ISUB.EQ.111) THEN
32404C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
32405 IF(MSTP(38).NE.0) THEN
32406C...Simple case: only do gg <-> h exactly.
32407 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32408 WDTP13=0D0
32409 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32410 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32411 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32412 385 CONTINUE
32413 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32414 & '(PYSGHG:) did not find Higgs -> g g channel')
32415 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
32416 & (TH**2+UH**2)/(SH*SQM4)
32417C...Propagators: as simulated in PYOFSH and as desired
32418 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32419 GMMHC=SQRT(SQM4)*WDTP(0)
32420 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
32421 & ((SQM4-SQMH)**2+GMMHC**2)
32422 FACGH=FACGH*HBW4C/HBW4
32423 ELSE
32424C...Messy case: do full loop integrals
32425 A5STUR=0D0
32426 A5STUI=0D0
32427 DO 390 I=1,2*MSTP(1)
32428 SQMQ=PMAS(I,1)**2
32429 EPSS=4D0*SQMQ/SH
32430 EPSH=4D0*SQMQ/SQMH
32431 CALL PYWAUX(1,EPSS,W1SR,W1SI)
32432 CALL PYWAUX(1,EPSH,W1HR,W1HI)
32433 CALL PYWAUX(2,EPSS,W2SR,W2SI)
32434 CALL PYWAUX(2,EPSH,W2HR,W2HI)
32435 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
32436 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
32437 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
32438 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
32439 390 CONTINUE
32440 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
32441 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
32442 FACGH=FACGH*WIDS(25,2)
32443 ENDIF
32444 DO 400 I=MMINA,MMAXA
32445 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32446 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
32447 NCHN=NCHN+1
32448 ISIG(NCHN,1)=I
32449 ISIG(NCHN,2)=-I
32450 ISIG(NCHN,3)=1
32451 SIGH(NCHN)=FACGH
32452 400 CONTINUE
32453
32454 ELSEIF(ISUB.EQ.112) THEN
32455C...f + g -> f + h0 (q + g -> q + h0 only)
32456 IF(MSTP(38).NE.0) THEN
32457C...Simple case: only do gg <-> h exactly.
32458 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32459 WDTP13=0D0
32460 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32461 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32462 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32463 405 CONTINUE
32464 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32465 & '(PYSGHG:) did not find Higgs -> g g channel')
32466 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
32467 & (SH**2+UH**2)/(-TH*SQM4)
32468C...Propagators: as simulated in PYOFSH and as desired
32469 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32470 GMMHC=SQRT(SQM4)*WDTP(0)
32471 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
32472 & ((SQM4-SQMH)**2+GMMHC**2)
32473 FACQH=FACQH*HBW4C/HBW4
32474 ELSE
32475C...Messy case: do full loop integrals
32476 A5TSUR=0D0
32477 A5TSUI=0D0
32478 DO 410 I=1,2*MSTP(1)
32479 SQMQ=PMAS(I,1)**2
32480 EPST=4D0*SQMQ/TH
32481 EPSH=4D0*SQMQ/SQMH
32482 CALL PYWAUX(1,EPST,W1TR,W1TI)
32483 CALL PYWAUX(1,EPSH,W1HR,W1HI)
32484 CALL PYWAUX(2,EPST,W2TR,W2TI)
32485 CALL PYWAUX(2,EPSH,W2HR,W2HI)
32486 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
32487 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
32488 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
32489 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
32490 410 CONTINUE
32491 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
32492 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
32493 FACQH=FACQH*WIDS(25,2)
32494 ENDIF
32495 DO 430 I=MMINA,MMAXA
32496 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
32497 DO 420 ISDE=1,2
32498 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
32499 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
32500 NCHN=NCHN+1
32501 ISIG(NCHN,ISDE)=I
32502 ISIG(NCHN,3-ISDE)=21
32503 ISIG(NCHN,3)=1
32504 SIGH(NCHN)=FACQH
32505 420 CONTINUE
32506 430 CONTINUE
32507
32508 ELSEIF(ISUB.EQ.113) THEN
32509C...g + g -> g + h0
32510 IF(MSTP(38).NE.0) THEN
32511C...Simple case: only do gg <-> h exactly.
32512 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32513 WDTP13=0D0
32514 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
32515 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
32516 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
32517 435 CONTINUE
32518 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
32519 & '(PYSGHG:) did not find Higgs -> g g channel')
32520 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
32521 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
32522C...Propagators: as simulated in PYOFSH and as desired
32523 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32524 GMMHC=SQRT(SQM4)*WDTP(0)
32525 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
32526 & ((SQM4-SQMH)**2+GMMHC**2)
32527 FACGH=FACGH*HBW4C/HBW4
32528 ELSE
32529C...Messy case: do full loop integrals
32530 A2STUR=0D0
32531 A2STUI=0D0
32532 A2USTR=0D0
32533 A2USTI=0D0
32534 A2TUSR=0D0
32535 A2TUSI=0D0
32536 A4STUR=0D0
32537 A4STUI=0D0
32538 DO 440 I=1,2*MSTP(1)
32539 SQMQ=PMAS(I,1)**2
32540 EPSS=4D0*SQMQ/SH
32541 EPST=4D0*SQMQ/TH
32542 EPSU=4D0*SQMQ/UH
32543 EPSH=4D0*SQMQ/SQMH
32544 IF(EPSH.LT.1D-6) GOTO 440
32545 CALL PYWAUX(1,EPSS,W1SR,W1SI)
32546 CALL PYWAUX(1,EPST,W1TR,W1TI)
32547 CALL PYWAUX(1,EPSU,W1UR,W1UI)
32548 CALL PYWAUX(1,EPSH,W1HR,W1HI)
32549 CALL PYWAUX(2,EPSS,W2SR,W2SI)
32550 CALL PYWAUX(2,EPST,W2TR,W2TI)
32551 CALL PYWAUX(2,EPSU,W2UR,W2UI)
32552 CALL PYWAUX(2,EPSH,W2HR,W2HI)
32553 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
32554 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
32555 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
32556 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
32557 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
32558 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
32559 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
32560 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
32561 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
32562 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
32563 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
32564 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
32565 W3STUR=YHSTUR-Y3STUR-Y3UTSR
32566 W3STUI=YHSTUI-Y3STUI-Y3UTSI
32567 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
32568 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
32569 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
32570 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
32571 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
32572 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
32573 W3USTR=YHUSTR-Y3USTR-Y3TSUR
32574 W3USTI=YHUSTI-Y3USTI-Y3TSUI
32575 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
32576 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
32577 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
32578 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
32579 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
32580 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
32581 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
32582 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
32583 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
32584 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
32585 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
32586 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
32587 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
32588 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
32589 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
32590 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
32591 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
32592 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
32593 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
32594 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
32595 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
32596 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
32597 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
32598 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
32599 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
32600 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
32601 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
32602 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
32603 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
32604 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
32605 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
32606 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
32607 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
32608 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
32609 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
32610 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
32611 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
32612 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
32613 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
32614 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
32615 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
32616 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
32617 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
32618 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
32619 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
32620 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
32621 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
32622 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
32623 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
32624 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
32625 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
32626 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
32627 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
32628 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
32629 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
32630 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
32631 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
32632 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
32633 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
32634 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
32635 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
32636 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
32637 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
32638 & (W2SR-W2HR+W3STUR))
32639 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
32640 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
32641 & (W2TR-W2HR+W3TUSR))
32642 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
32643 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
32644 & (W2UR-W2HR+W3USTR))
32645 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
32646 A2STUR=A2STUR+B2STUR+B2SUTR
32647 A2STUI=A2STUI+B2STUI+B2SUTI
32648 A2USTR=A2USTR+B2USTR+B2UTSR
32649 A2USTI=A2USTI+B2USTI+B2UTSI
32650 A2TUSR=A2TUSR+B2TUSR+B2TSUR
32651 A2TUSI=A2TUSI+B2TUSI+B2TSUI
32652 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
32653 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
32654 440 CONTINUE
32655 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
32656 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
32657 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
32658 FACGH=FACGH*WIDS(25,2)
32659 ENDIF
32660 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
32661 NCHN=NCHN+1
32662 ISIG(NCHN,1)=21
32663 ISIG(NCHN,2)=21
32664 ISIG(NCHN,3)=1
32665 SIGH(NCHN)=FACGH
32666 450 CONTINUE
32667 ENDIF
32668
32669 ELSEIF(ISUB.LE.170) THEN
32670 IF(ISUB.EQ.121) THEN
32671C...g + g -> Q + Qbar + h0
32672 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
32673 IA=KFPR(ISUBSV,2)
32674 PMF=PYMRUN(IA,SH)
32675 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
32676 & (0.5D0*PMF/PMAS(24,1))**2
32677 WID2=1D0
32678 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
32679 FACQQH=FACQQH*WID2
32680 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32681 IKFI=1
32682 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32683 IF(IA.GT.10) IKFI=3
32684 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
32685 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32686 FACQQH=FACQQH/(1D0+RMSS(41))**2
32687 IF(IHIGG.NE.3) THEN
32688 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32689 & PARU(151+10*IHIGG))**2
32690 ENDIF
32691 ENDIF
32692 ENDIF
32693 CALL PYQQBH(WTQQBH)
32694 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32695 HS=SHR*WDTP(0)
32696 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32697 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32698 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32699 & FACBW=0D0
32700 NCHN=NCHN+1
32701 ISIG(NCHN,1)=21
32702 ISIG(NCHN,2)=21
32703 ISIG(NCHN,3)=1
32704 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
32705 460 CONTINUE
32706
32707 ELSEIF(ISUB.EQ.122) THEN
32708C...q + qbar -> Q + Qbar + h0
32709 IA=KFPR(ISUBSV,2)
32710 PMF=PYMRUN(IA,SH)
32711 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
32712 & (0.5D0*PMF/PMAS(24,1))**2
32713 WID2=1D0
32714 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
32715 FACQQH=FACQQH*WID2
32716 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32717 IKFI=1
32718 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32719 IF(IA.GT.10) IKFI=3
32720 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
32721 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32722 FACQQH=FACQQH/(1D0+RMSS(41))**2
32723 IF(IHIGG.NE.3) THEN
32724 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32725 & PARU(151+10*IHIGG))**2
32726 ENDIF
32727 ENDIF
32728 ENDIF
32729 CALL PYQQBH(WTQQBH)
32730 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32731 HS=SHR*WDTP(0)
32732 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32733 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32734 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32735 & FACBW=0D0
32736 DO 470 I=MMINA,MMAXA
32737 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32738 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
32739 NCHN=NCHN+1
32740 ISIG(NCHN,1)=I
32741 ISIG(NCHN,2)=-I
32742 ISIG(NCHN,3)=1
32743 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
32744 470 CONTINUE
32745
32746 ELSEIF(ISUB.EQ.123) THEN
32747C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
32748C...inner process)
32749 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
32750 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
32751 & PARU(154+10*IHIGG)**2
32752 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
32753 & (VINT(216)-VINT(209)**2))**2
32754 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
32755 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
32756 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32757 HS=SHR*WDTP(0)
32758 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32759 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32760 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32761 & FACBW=0D0
32762 DO 490 I=MMIN1,MMAX1
32763 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
32764 IA=IABS(I)
32765 DO 480 J=MMIN2,MMAX2
32766 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
32767 JA=IABS(J)
32768 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
32769 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
32770 VI=AI-4D0*EI*XWV
32771 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
32772 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
32773 VJ=AJ-4D0*EJ*XWV
32774 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
32775 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
32776 NCHN=NCHN+1
32777 ISIG(NCHN,1)=I
32778 ISIG(NCHN,2)=J
32779 ISIG(NCHN,3)=1
32780 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
32781 480 CONTINUE
32782 490 CONTINUE
32783
32784 ELSEIF(ISUB.EQ.124) THEN
32785C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
32786C...inner process)
32787 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
32788 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
32789 & PARU(155+10*IHIGG)**2
32790 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
32791 & (VINT(216)-VINT(209)**2))**2
32792 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
32793 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32794 HS=SHR*WDTP(0)
32795 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32796 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
32797 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32798 & FACBW=0D0
32799 DO 510 I=MMIN1,MMAX1
32800 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
32801 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32802 DO 500 J=MMIN2,MMAX2
32803 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
32804 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32805 IF(EI*EJ.GT.0D0) GOTO 500
32806 FACLR=VINT(180+I)*VINT(180+J)
32807 NCHN=NCHN+1
32808 ISIG(NCHN,1)=I
32809 ISIG(NCHN,2)=J
32810 ISIG(NCHN,3)=1
32811 SIGH(NCHN)=FACLR*FACWW*FACBW
32812 500 CONTINUE
32813 510 CONTINUE
32814
32815 ELSEIF(ISUB.EQ.143) THEN
32816C...f + fbar' -> H+/-
32817 SQMHC=PMAS(37,1)**2
32818 CALL PYWIDT(37,SH,WDTP,WDTE)
32819 HS=SHR*WDTP(0)
32820 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
32821 HP=AEM/(8D0*XW)*SH/SQMW*SH
32822 DO 530 I=MMIN1,MMAX1
32823 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
32824 IA=IABS(I)
32825 IM=(MOD(IA,10)+1)/2
32826 DO 520 J=MMIN2,MMAX2
32827 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
32828 JA=IABS(J)
32829 JM=(MOD(JA,10)+1)/2
32830 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
32831 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32832 & GOTO 520
32833 IF(MOD(IA,2).EQ.0) THEN
32834 IU=IA
32835 IL=JA
32836 ELSE
32837 IU=JA
32838 IL=IA
32839 ENDIF
32840 RML=PYMRUN(IL,SH)**2/SH
32841 RMU=PYMRUN(IU,SH)**2/SH
32842 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
32843 IF(IA.LE.10) HI=HI*FACA/3D0
32844 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32845 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
32846 NCHN=NCHN+1
32847 ISIG(NCHN,1)=I
32848 ISIG(NCHN,2)=J
32849 ISIG(NCHN,3)=1
32850 SIGH(NCHN)=HI*FACBW*HF
32851 520 CONTINUE
32852 530 CONTINUE
32853
32854 ELSEIF(ISUB.EQ.161) THEN
32855C...f + g -> f' + H+/- (b + g -> t + H+/- only)
32856C...(choice of only b and t to avoid kinematics problems)
32857 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
32858C...H propagator: as simulated in PYOFSH and as desired
32859 SQMHC=PMAS(37,1)**2
32860 GMMHC=PMAS(37,1)*PMAS(37,2)
32861 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32862 CALL PYWIDT(37,SQM4,WDTP,WDTE)
32863 GMMHCC=SQRT(SQM4)*WDTP(0)
32864 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32865 FHCQ=FHCQ*HBW4C/HBW4
32866 Q2RM=SH
32867 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
32868 DO 550 I=MMINA,MMAXA
32869 IA=IABS(I)
32870 IF(IA.NE.5) GOTO 550
32871 SQML=PYMRUN(IA,Q2RM)**2
32872 IUA=IA+MOD(IA,2)
32873 SQMQ=PYMRUN(IUA,Q2RM)**2
32874 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
32875 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32876 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
32877 & (SQMHC-SQMQ-SH)/SH)
32878 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32879 DO 540 ISDE=1,2
32880 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
32881 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
32882 NCHN=NCHN+1
32883 ISIG(NCHN,ISDE)=I
32884 ISIG(NCHN,3-ISDE)=21
32885 ISIG(NCHN,3)=1
32886 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
32887 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
32888 540 CONTINUE
32889 550 CONTINUE
32890 ENDIF
32891
32892 ELSEIF(ISUB.LE.402) THEN
32893 IF(ISUB.EQ.401) THEN
32894C... g + g -> t + bbar + H-
32895 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
32896 IA=KFPR(ISUBSV,2)
32897 CALL PYSTBH(WTTBH)
32898 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32899 HS=SHR*WDTP(0)
32900 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
32901 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32902 & FACBW=0D0
32903 NCHN=NCHN+1
32904 ISIG(NCHN,1)=21
32905 ISIG(NCHN,2)=21
32906 ISIG(NCHN,3)=1
32907 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
32908c Since we don't know yet if H+ or H-, assume H+
32909c when calculating suppression due to closed channels.
32910 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
32911 IF(ABS(WIDS(37,2)-WIDS(37,3))
32912 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
32913 & ABS(WIDS(6,2)-WIDS(6,3))
32914 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
32915 WRITE(*,*)'Error: Process 401 cannot handle different'
32916 WRITE(*,*)'decays for H+ and H- or t and tbar.'
32917 WRITE(*,*)'Execution stopped.'
32918 STOP
32919 END IF
32920 560 CONTINUE
32921
32922 ELSEIF(ISUB.EQ.402) THEN
32923C... q + qbar -> t + bbar + H-
32924 IA=KFPR(ISUBSV,2)
32925 CALL PYSTBH(WTTBH)
32926 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32927 HS=SHR*WDTP(0)
32928 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
32929 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32930 & FACBW=0D0
32931 DO 570 I=MMINA,MMAXA
32932 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32933 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
32934 NCHN=NCHN+1
32935 ISIG(NCHN,1)=I
32936 ISIG(NCHN,2)=-I
32937 ISIG(NCHN,3)=1
32938 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
32939c Since we don't know yet if H+ or H-, assume H+
32940c when calculating suppression due to closed channels.
32941 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
32942 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
32943 & .GE.1D-6.OR.
32944 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
32945 & .GE.1D-6) THEN
32946 WRITE(*,*)'Error: Process 402 cannot handle different'
32947 WRITE(*,*)'decays for H+ and H- or t and tbar.'
32948 WRITE(*,*)'Execution stopped.'
32949 STOP
32950 END IF
32951 570 CONTINUE
32952 ENDIF
32953 ENDIF
32954
32955 RETURN
32956 END
32957
32958C*********************************************************************
32959
32960C...PYSGSU
32961C...Subprocess cross sections for SUSY processes,
32962C...including Higgs pair production.
32963C...Auxiliary to PYSIGH.
32964
32965 SUBROUTINE PYSGSU(NCHN,SIGS)
32966
32967C...Double precision and integer declarations
32968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32969 IMPLICIT INTEGER(I-N)
32970 INTEGER PYK,PYCHGE,PYCOMP
32971C...Parameter statement to help give large particle numbers.
32972 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32973 &KEXCIT=4000000,KDIMEN=5000000)
32974C...Commonblocks
32975 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32976 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32977 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32978 COMMON/PYINT1/MINT(400),VINT(400)
32979 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32980 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32981 COMMON/PYINT4/MWID(500),WIDS(500,5)
32982 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32983 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
32984 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
32985 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32986 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32987 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32988 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32989 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
32990 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
32991C...Local arrays and complex variables
32992 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32993 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
32994 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
32995 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
32996
32997CMRENNA++
32998C...Z and W width, combinations of weak mixing angle
32999 ZWID=PMAS(23,2)
33000 WWID=PMAS(24,2)
33001 TANW=SQRT(XW/XW1)
33002 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33003
33004C...Convert almost equivalent SUSY processes into each other
33005C...Extract differences in flavours and couplings
33006
33007C...Sleptons and sneutrinos
33008 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33009 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33010 ISUB=201
33011 ILR=0
33012 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33013 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33014 ISUB=201
33015 ILR=1
33016 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33017 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33018 ISUB=203
33019 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33020 IF(ISUB.EQ.210) THEN
33021 RKF=2.0D0
33022 ELSEIF(ISUB.EQ.211) THEN
33023 RKF=SFMIX(15,1)**2
33024 ELSEIF(ISUB.EQ.212) THEN
33025 RKF=SFMIX(15,2)**2
33026 ENDIF
33027 ISUB=210
33028 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33029 IF(ISUB.EQ.213) THEN
33030 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33031 RKF=2.0D0
33032 ELSEIF(ISUB.EQ.214) THEN
33033 KFID=16
33034 RKF=1.0D0
33035 ENDIF
33036 ISUB=213
33037
33038C...Neutralinos
33039 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33040 IF(ISUB.EQ.216) THEN
33041 IZID1=1
33042 IZID2=1
33043 ELSEIF(ISUB.EQ.217) THEN
33044 IZID1=2
33045 IZID2=2
33046 ELSEIF(ISUB.EQ.218) THEN
33047 IZID1=3
33048 IZID2=3
33049 ELSEIF(ISUB.EQ.219) THEN
33050 IZID1=4
33051 IZID2=4
33052 ELSEIF(ISUB.EQ.220) THEN
33053 IZID1=1
33054 IZID2=2
33055 ELSEIF(ISUB.EQ.221) THEN
33056 IZID1=1
33057 IZID2=3
33058 ELSEIF(ISUB.EQ.222) THEN
33059 IZID1=1
33060 IZID2=4
33061 ELSEIF(ISUB.EQ.223) THEN
33062 IZID1=2
33063 IZID2=3
33064 ELSEIF(ISUB.EQ.224) THEN
33065 IZID1=2
33066 IZID2=4
33067 ELSEIF(ISUB.EQ.225) THEN
33068 IZID1=3
33069 IZID2=4
33070 ENDIF
33071 ISUB=216
33072
33073C...Charginos
33074 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33075 IF(ISUB.EQ.226) THEN
33076 IZID1=1
33077 IZID2=1
33078 ELSEIF(ISUB.EQ.227) THEN
33079 IZID1=2
33080 IZID2=2
33081 ELSEIF(ISUB.EQ.228) THEN
33082 IZID1=1
33083 IZID2=2
33084 ENDIF
33085 ISUB=226
33086
33087C...Neutralino + chargino
33088 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
33089 IF(ISUB.EQ.229) THEN
33090 IZID1=1
33091 IZID2=1
33092 ELSEIF(ISUB.EQ.230) THEN
33093 IZID1=1
33094 IZID2=2
33095 ELSEIF(ISUB.EQ.231) THEN
33096 IZID1=1
33097 IZID2=3
33098 ELSEIF(ISUB.EQ.232) THEN
33099 IZID1=1
33100 IZID2=4
33101 ELSEIF(ISUB.EQ.233) THEN
33102 IZID1=2
33103 IZID2=1
33104 ELSEIF(ISUB.EQ.234) THEN
33105 IZID1=2
33106 IZID2=2
33107 ELSEIF(ISUB.EQ.235) THEN
33108 IZID1=2
33109 IZID2=3
33110 ELSEIF(ISUB.EQ.236) THEN
33111 IZID1=2
33112 IZID2=4
33113 ENDIF
33114 ISUB=229
33115
33116C...Gluino + neutralino
33117 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
33118 IF(ISUB.EQ.237) THEN
33119 IZID=1
33120 ELSEIF(ISUB.EQ.238) THEN
33121 IZID=2
33122 ELSEIF(ISUB.EQ.239) THEN
33123 IZID=3
33124 ELSEIF(ISUB.EQ.240) THEN
33125 IZID=4
33126 ENDIF
33127 ISUB=237
33128
33129C...Gluino + chargino
33130 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
33131 IF(ISUB.EQ.241) THEN
33132 IZID=1
33133 ELSEIF(ISUB.EQ.242) THEN
33134 IZID=2
33135 ENDIF
33136 ISUB=241
33137
33138C...Squark + neutralino
33139 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
33140 ILR=0
33141 IF(MOD(ISUB,2).NE.0) ILR=1
33142 IF(ISUB.LE.247) THEN
33143 IZID=1
33144 ELSEIF(ISUB.LE.249) THEN
33145 IZID=2
33146 ELSEIF(ISUB.LE.251) THEN
33147 IZID=3
33148 ELSEIF(ISUB.LE.253) THEN
33149 IZID=4
33150 ENDIF
33151 ISUB=246
33152 RKF=5D0
33153
33154C...Squark + chargino
33155 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
33156 IF(ISUB.LE.255) THEN
33157 IZID=1
33158 ELSEIF(ISUB.LE.257) THEN
33159 IZID=2
33160 ENDIF
33161 IF(MOD(ISUB,2).EQ.0) THEN
33162 ILR=0
33163 ELSE
33164 ILR=1
33165 ENDIF
33166 ISUB=254
33167 RKF=5D0
33168
33169C...Squark + gluino
33170 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
33171 ISUB=258
33172 RKF=4D0
33173
33174C...Stops
33175 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
33176 ILR=0
33177 IF(ISUB.EQ.262) ILR=1
33178 ISUB=261
33179 ELSEIF(ISUB.EQ.265) THEN
33180 ISUB=264
33181
33182C...Squarks
33183 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
33184 ILR=0
33185 IF(ISUB.LE.273) THEN
33186 IF(ISUB.EQ.273) ILR=1
33187 ISUB=271
33188 RKF=16D0
33189 ELSEIF(ISUB.LE.276) THEN
33190 IF(ISUB.EQ.276) ILR=1
33191 ISUB=274
33192 RKF=16D0
33193 ELSEIF(ISUB.LE.278) THEN
33194 IF(ISUB.EQ.278) ILR=1
33195 ISUB=277
33196 RKF=4D0
33197 ELSE
33198 IF(ISUB.EQ.280) ILR=1
33199 ISUB=279
33200 RKF=4D0
33201 ENDIF
33202C...Sbottoms
33203 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
33204 ILR=0
33205 IF(ISUB.LE.283) THEN
33206 IF(ISUB.EQ.283) ILR=1
33207 ISUB=271
33208 RKF=4D0
33209 ELSEIF(ISUB.LE.286) THEN
33210 IF(ISUB.EQ.286) ILR=1
33211 ISUB=274
33212 RKF=4D0
33213 ELSEIF(ISUB.LE.288) THEN
33214 IF(ISUB.EQ.288) ILR=1
33215 ISUB=277
33216 RKF=1D0
33217 ELSEIF(ISUB.LE.290) THEN
33218 IF(ISUB.EQ.290) ILR=1
33219 ISUB=279
33220 RKF=1D0
33221 ELSEIF(ISUB.LE.293) THEN
33222 IF(ISUB.EQ.293) ILR=1
33223 ISUB=271
33224 RKF=1D0
33225 ELSEIF(ISUB.EQ.296) THEN
33226 ILR=1
33227 ISUB=274
33228 RKF=1D0
33229C...Squark + gluino
33230 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
33231 ISUB=258
33232 RKF=1D0
33233 ENDIF
33234C...H+/- + H0
33235 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
33236 IF(ISUB.EQ.297) THEN
33237 RKF=.5D0*PARU(195)**2
33238 ELSEIF(ISUB.EQ.298) THEN
33239 RKF=.5D0*(1D0-PARU(195)**2)
33240 ENDIF
33241 ISUB=210
33242C...A0 + H0
33243 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
33244 IF(ISUB.EQ.299) THEN
33245 RKF=PARU(186)**2
33246 KFID=25
33247 ELSEIF(ISUB.EQ.300) THEN
33248 RKF=PARU(187)**2
33249 KFID=35
33250 ENDIF
33251 ISUB=213
33252C...H+ + H-
33253 ELSEIF(ISUB.EQ.301) THEN
33254 KFID=37
33255 RKF=1D0
33256 ISUB=201
33257 ENDIF
33258
33259C...Supersymmetric processes - all of type 2 -> 2 :
33260C...correct final-state Breit-Wigners from fixed to running width.
33261 IF(MSTP(42).GT.0) THEN
33262 DO 100 I=1,2
33263 KFLW=KFPR(ISUBSV,I)
33264 KCW=PYCOMP(KFLW)
33265 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
33266 IF(I.EQ.1) SQMI=SQM3
33267 IF(I.EQ.2) SQMI=SQM4
33268 SQMS=PMAS(KCW,1)**2
33269 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
33270 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
33271 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
33272 GMMI=SQRT(SQMI)*WDTP(0)
33273 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
33274 COMFAC=COMFAC*(HBWI/HBWS)
33275 100 CONTINUE
33276 ENDIF
33277
33278C...Differential cross section expressions.
33279
33280 IF(ISUB.LE.210) THEN
33281 IF(ISUB.EQ.201) THEN
33282C...f + fbar -> e_L + e_Lbar
33283 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33284 DO 130 I=MMIN1,MMAX1
33285 IA=IABS(I)
33286 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
33287 EI=KCHG(IA,1)/3D0
33288 TT3I=SIGN(1D0,EI+1D-6)/2D0
33289 EJ=-1D0
33290 TT3J=-1D0/2D0
33291 FCOL=1D0
33292C...Color factor for e+ e-
33293 IF(IA.GE.11) FCOL=3D0
33294 IF(ISUBSV.EQ.301) THEN
33295 A1=1D0
33296 A2=0D0
33297 ELSEIF(ILR.EQ.1) THEN
33298 A1=SFMIX(KFID,3)**2
33299 A2=SFMIX(KFID,4)**2
33300 ELSEIF(ILR.EQ.0) THEN
33301 A1=SFMIX(KFID,1)**2
33302 A2=SFMIX(KFID,2)**2
33303 ENDIF
33304 XLQ=(TT3J-EJ*XW)*A1
33305 XRQ=(-EJ*XW)*A2
33306 XLF=(TT3I-EI*XW)
33307 XRF=(-EI*XW)
33308 TAA=(EI*EJ)**2*(POLL+POLR)
33309 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
33310 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
33311 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
33312 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
33313 TNN=0.0D0
33314 TAN=0.0D0
33315 TZN=0.0D0
33316 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
33317 FAC2=SQRT(2D0)
33318 TNN1=0D0
33319 TNN2=0D0
33320 TNN3=0D0
33321 DO 120 II=1,4
33322 DK=1D0/(TH-SMZ(II)**2)
33323 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
33324 & ZMIX(II,1))
33325 FREK=FAC2*TANW*EI*ZMIX(II,1)
33326 TNN1=TNN1+FLEK**2*DK
33327 TNN2=TNN2+FREK**2*DK
33328 DO 110 JJ=1,4
33329 DL=1D0/(TH-SMZ(JJ)**2)
33330 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
33331 & ZMIX(JJ,1))
33332 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
33333 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
33334 110 CONTINUE
33335 120 CONTINUE
33336 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
33337 & A2**2*TNN2**2*POLR)
33338 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
33339 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
33340 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
33341 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
33342 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
33343 & (1D0-SQMZ/SH)/SH
33344 TZN=TZN/XW**2/XW1
33345 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
33346 & A2*TNN2*POLR)/XW
33347 ENDIF
33348 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
33349 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
33350 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
33351 NCHN=NCHN+1
33352 ISIG(NCHN,1)=I
33353 ISIG(NCHN,2)=-I
33354 ISIG(NCHN,3)=1
33355 SIGH(NCHN)=FACQQ1+FACQQ2
33356 130 CONTINUE
33357
33358 ELSEIF(ISUB.EQ.203) THEN
33359C...f + fbar -> e_L + e_Rbar
33360 DO 160 I=MMIN1,MMAX1
33361 IA=IABS(I)
33362 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
33363 EI=KCHG(IABS(I),1)/3D0
33364 TT3I=SIGN(1D0,EI)/2D0
33365 EJ=-1
33366 TT3J=-1D0/2D0
33367 FCOL=1D0
33368C...Color factor for e+ e-
33369 IF(IA.GE.11) FCOL=3D0
33370 A1=SFMIX(KFID,1)**2
33371 A2=SFMIX(KFID,2)**2
33372 XLQ=(TT3J-EJ*XW)
33373 XRQ=(-EJ*XW)
33374 XLF=(TT3I-EI*XW)
33375 XRF=(-EI*XW)
33376 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
33377 & /XW**2/XW1**2*A1*A2
33378 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
33379 TNN=0.0D0
33380 TZN=0.0D0
33381 TNNA=0D0
33382 TNNB=0D0
33383 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
33384 FAC2=SQRT(2D0)
33385 TNN1=0D0
33386 TNN2=0D0
33387 TNN3=0D0
33388 DO 150 II=1,4
33389 DK=1D0/(TH-SMZ(II)**2)
33390 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
33391 & ZMIX(II,1))
33392 FREK=FAC2*TANW*EI*ZMIX(II,1)
33393 TNN1=TNN1+FLEK**2*DK
33394 TNN2=TNN2+FREK**2*DK
33395 DO 140 JJ=1,4
33396 DL=1D0/(TH-SMZ(JJ)**2)
33397 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
33398 & ZMIX(JJ,1))
33399 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
33400 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
33401 140 CONTINUE
33402 150 CONTINUE
33403 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
33404 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
33405 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
33406 TZN=(UH*TH-SQM3*SQM4)*A1*A2
33407 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
33408 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
33409 & (1D0-SQMZ/SH)/SH
33410 ENDIF
33411 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
33412 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
33413 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
33414C%%%%%%%%%%%
33415 NCHN=NCHN+1
33416 ISIG(NCHN,1)=I
33417 ISIG(NCHN,2)=-I
33418 ISIG(NCHN,3)=1
33419 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33420 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
33421 NCHN=NCHN+1
33422 ISIG(NCHN,1)=I
33423 ISIG(NCHN,2)=-I
33424 ISIG(NCHN,3)=2
33425 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
33426 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33427 160 CONTINUE
33428
33429 ELSEIF(ISUB.EQ.210) THEN
33430C...q + qbar' -> W*- > ~l_L + ~nu_L
33431 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
33432 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
33433 DO 180 I=MMIN1,MMAX1
33434 IA=IABS(I)
33435 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
33436 DO 170 J=MMIN2,MMAX2
33437 JA=IABS(J)
33438 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
33439 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
33440 FCKM=3D0
33441 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33442 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
33443 KCHW=2
33444 IF(KCHSUM.LT.0) KCHW=3
33445 NCHN=NCHN+1
33446 ISIG(NCHN,1)=I
33447 ISIG(NCHN,2)=J
33448 ISIG(NCHN,3)=1
33449 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
33450 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
33451 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33452 ELSE
33453 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
33454 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
33455 ENDIF
33456 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
33457 170 CONTINUE
33458 180 CONTINUE
33459 ENDIF
33460
33461 ELSEIF(ISUB.LE.220) THEN
33462 IF(ISUB.EQ.213) THEN
33463C...f + fbar -> ~nu_L + ~nu_Lbar
33464 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
33465 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33466 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33467 ELSE
33468 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33469 ENDIF
33470 COMFAC=COMFAC*FACR
33471 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
33472 XLL=0.5D0
33473 XLR=0.0D0
33474 DO 190 I=MMIN1,MMAX1
33475 IA=IABS(I)
33476 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
33477 EI=KCHG(IA,1)/3D0
33478 FCOL=1D0
33479C...Color factor for e+ e-
33480 IF(IA.GE.11) FCOL=3D0
33481 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
33482 XRQ=-EI*XW
33483 TZC=0.0D0
33484 TCC=0.0D0
33485 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
33486 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
33487 & (TH-SMW(2)**2)
33488 TCC=TZC**2
33489 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
33490 ENDIF
33491 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
33492 FACQQ2=TZC+TCC/4D0
33493 NCHN=NCHN+1
33494 ISIG(NCHN,1)=I
33495 ISIG(NCHN,2)=-I
33496 ISIG(NCHN,3)=1
33497 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
33498 & *AEM**2*FCOL/3D0/XW**2
33499 190 CONTINUE
33500
33501 ELSEIF(ISUB.EQ.216) THEN
33502C...q + qbar -> ~chi0_1 + ~chi0_1
33503 IF(IZID1.EQ.IZID2) THEN
33504 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33505 ELSE
33506 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33507 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33508 ENDIF
33509 FACXX=COMFAC*AEM**2/3D0/XW**2
33510 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
33511 ZM12=SQM3
33512 ZM22=SQM4
33513 WU2 = (UH-ZM12)*(UH-ZM22)
33514 WT2 = (TH-ZM12)*(TH-ZM22)
33515 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
33516 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
33517 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
33518 DO 200 I=1,4
33519 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
33520 IF(IZID2.NE.IZID1) THEN
33521 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
33522 ENDIF
33523 200 CONTINUE
33524 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
33525 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
33526 ORPP=DCONJG(OLPP)
33527 DO 210 I=MMINA,MMAXA
33528 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
33529 EI=KCHG(IABS(I),1)/3D0
33530 T3I=SIGN(1D0,EI+1D-6)/2D0
33531 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
33532 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
33533 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
33534 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
33535 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
33536 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
33537 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
33538 & /DCMPLX(TH-XML2)
33539 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
33540 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
33541 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
33542 FCOL=1D0
33543 IF(IABS(I).GE.11) FCOL=3D0
33544 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
33545 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
33546 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
33547 & QRL*DCONJG(QRR)*POLR)*WS2
33548 NCHN=NCHN+1
33549 ISIG(NCHN,1)=I
33550 ISIG(NCHN,2)=-I
33551 ISIG(NCHN,3)=1
33552 SIGH(NCHN)=FACXX*FACGG1*FCOL
33553 210 CONTINUE
33554 ENDIF
33555
33556 ELSEIF(ISUB.LE.230) THEN
33557 IF(ISUB.EQ.226) THEN
33558C...f + fbar -> ~chi+_1 + ~chi-_1
33559 FACXX=COMFAC*AEM**2/3D0
33560 ZM12=SQM3
33561 ZM22=SQM4
33562 WU2 = (UH-ZM12)*(UH-ZM22)
33563 WT2 = (TH-ZM12)*(TH-ZM22)
33564 WS2 = SMW(IZID1)*SMW(IZID2)*SH
33565 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
33566 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
33567 DIFF=0D0
33568 IF(IZID1.EQ.IZID2) DIFF=1D0
33569 DO 220 I=1,2
33570 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
33571 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
33572 IF(IZID2.NE.IZID1) THEN
33573 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
33574 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
33575 ENDIF
33576 220 CONTINUE
33577 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
33578 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
33579 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
33580 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
33581 DO 230 I=MMINA,MMAXA
33582 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
33583 EI=KCHG(IABS(I),1)/3D0
33584 T3I=SIGN(1D0,EI+1D-6)/2D0
33585 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
33586 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
33587 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
33588 IF(MOD(I,2).EQ.0) THEN
33589 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
33590 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
33591 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
33592 & DCMPLX(T3I/XW/(TH-XML2))
33593 ELSE
33594 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
33595 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
33596 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
33597 & DCMPLX(T3I/XW/(TH-XML2))
33598 ENDIF
33599 FCOL=1D0
33600 IF(IABS(I).GE.11) FCOL=3D0
33601 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
33602 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
33603 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
33604 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
33605 NCHN=NCHN+1
33606 ISIG(NCHN,1)=I
33607 ISIG(NCHN,2)=-I
33608 ISIG(NCHN,3)=1
33609 IF(IZID1.EQ.IZID2) THEN
33610 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33611 ELSE
33612 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
33613 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33614 NCHN=NCHN+1
33615 ISIG(NCHN,1)=I
33616 ISIG(NCHN,2)=-I
33617 ISIG(NCHN,3)=2
33618 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33619 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
33620 ENDIF
33621 230 CONTINUE
33622
33623 ELSEIF(ISUB.EQ.229) THEN
33624C...q + qbar' -> ~chi0_1 + ~chi+-_1
33625 FACXX=COMFAC*AEM**2/6D0/XW**2
33626 ZM12=SQM3
33627 ZM22=SQM4
33628 WU2 = (UH-ZM12)*(UH-ZM22)
33629 WT2 = (TH-ZM12)*(TH-ZM22)
33630 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
33631 RT2I = 1D0/SQRT(2D0)
33632 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
33633 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
33634 DO 240 I=1,2
33635 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
33636 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
33637 240 CONTINUE
33638 DO 250 I=1,4
33639 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
33640 250 CONTINUE
33641 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
33642 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
33643 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
33644 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
33645
33646 DO 270 I=MMIN1,MMAX1
33647 IA=IABS(I)
33648 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
33649 EI=KCHG(IA,1)/3D0
33650 T3I=SIGN(1D0,EI+1D-6)/2D0
33651 DO 260 J=MMIN2,MMAX2
33652 JA=IABS(J)
33653 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
33654 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
33655 EJ=KCHG(JA,1)/3D0
33656 T3J=SIGN(1D0,EJ+1D-6)/2D0
33657 FCKM=3D0
33658 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33659 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
33660 KCHW=2
33661 IF(KCHSUM.LT.0) KCHW=3
33662 IF(MOD(IA,2).EQ.0) THEN
33663 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
33664 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
33665 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
33666 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
33667 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
33668 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
33669 & /DCMPLX(TH-ZMJ2)
33670 ELSE
33671 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
33672 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
33673 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
33674 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
33675 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
33676 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
33677 & /DCMPLX(TH-ZMI2)
33678 ENDIF
33679 ZINTR=DBLE(QLR*DCONJG(QLL))
33680 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
33681 & 2D0*ZINTR*WS2)
33682 NCHN=NCHN+1
33683 ISIG(NCHN,1)=I
33684 ISIG(NCHN,2)=J
33685 ISIG(NCHN,3)=1
33686 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33687 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
33688 260 CONTINUE
33689 270 CONTINUE
33690 ENDIF
33691
33692 ELSEIF(ISUB.LE.240) THEN
33693 IF(ISUB.EQ.237) THEN
33694C...q + qbar -> gluino + ~chi0_1
33695 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33696 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33697 ASYUK=RMSS(42)*AS
33698 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
33699 GM2=SQM3
33700 ZM2=SQM4
33701 DO 280 I=MMINA,MMAXA
33702 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
33703 EI=KCHG(IABS(I),1)/3D0
33704 IA=IABS(I)
33705 XLQC = -TANW*EI*ZMIX(IZID,1)
33706 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
33707 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
33708 XLQ2=XLQC**2
33709 XRQ2=XRQC**2
33710 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
33711 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
33712 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
33713 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
33714 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
33715 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
33716 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
33717 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
33718 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
33719 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
33720 NCHN=NCHN+1
33721 ISIG(NCHN,1)=I
33722 ISIG(NCHN,2)=-I
33723 ISIG(NCHN,3)=1
33724 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
33725 280 CONTINUE
33726 ENDIF
33727
33728 ELSEIF(ISUB.LE.250) THEN
33729 IF(ISUB.EQ.241) THEN
33730C...q + qbar' -> ~chi+-_1 + gluino
33731 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
33732 GM2=SQM3
33733 ZM2=SQM4
33734 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
33735 FAC0=UMIX(IZID,1)**2
33736 FAC1=VMIX(IZID,1)**2
33737 DO 300 I=MMIN1,MMAX1
33738 IA=IABS(I)
33739 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
33740 DO 290 J=MMIN2,MMAX2
33741 JA=IABS(J)
33742 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
33743 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
33744 FCKM=1D0
33745 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33746 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
33747 KCHW=2
33748 IF(KCHSUM.LT.0) KCHW=3
33749 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
33750 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
33751 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
33752 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
33753 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
33754 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
33755 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
33756 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
33757 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
33758 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
33759 & SH/(TH-XMU2)/(UH-XMD2))/2D0
33760 NCHN=NCHN+1
33761 ISIG(NCHN,1)=I
33762 ISIG(NCHN,2)=J
33763 ISIG(NCHN,3)=1
33764 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
33765 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
33766 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
33767 290 CONTINUE
33768 300 CONTINUE
33769
33770 ELSEIF(ISUB.EQ.243) THEN
33771C...q + qbar -> gluino + gluino
33772 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33773 XMT=SQM3-TH
33774 XMU=SQM3-UH
33775 DO 310 I=MMINA,MMAXA
33776 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33777 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33778 NCHN=NCHN+1
33779 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
33780 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
33781 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
33782 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
33783 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
33784 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
33785 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
33786 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
33787 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
33788 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
33789 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
33790 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
33791 ISIG(NCHN,1)=I
33792 ISIG(NCHN,2)=-I
33793 ISIG(NCHN,3)=1
33794C...1/2 for identical particles
33795 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
33796 310 CONTINUE
33797
33798 ELSEIF(ISUB.EQ.244) THEN
33799C...g + g -> gluino + gluino
33800 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33801 XMT=SQM3-TH
33802 XMU=SQM3-UH
33803 FACQQ1=COMFAC*AS**2*9D0/4D0*(
33804 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
33805 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
33806 FACQQ2=COMFAC*AS**2*9D0/4D0*(
33807 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
33808 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
33809 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
33810 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
33811 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
33812 NCHN=NCHN+1
33813 ISIG(NCHN,1)=21
33814 ISIG(NCHN,2)=21
33815 ISIG(NCHN,3)=1
33816 SIGH(NCHN)=FACQQ1/2D0
33817 NCHN=NCHN+1
33818 ISIG(NCHN,1)=21
33819 ISIG(NCHN,2)=21
33820 ISIG(NCHN,3)=2
33821 SIGH(NCHN)=FACQQ2/2D0
33822 NCHN=NCHN+1
33823 ISIG(NCHN,1)=21
33824 ISIG(NCHN,2)=21
33825 ISIG(NCHN,3)=3
33826 SIGH(NCHN)=FACQQ3/2D0
33827 320 CONTINUE
33828
33829 ELSEIF(ISUB.EQ.246) THEN
33830C...g + q_j -> ~chi0_1 + ~q_j
33831 FAC0=COMFAC*AS*AEM/6D0/XW
33832 ZM2=SQM4
33833 QM2=SQM3
33834 FACZQ0=FAC0*( (ZM2-TH)/SH +
33835 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
33836 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
33837 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
33838 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
33839 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
33840 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33841 EI=KCHG(IABS(I),1)/3D0
33842 IA=IABS(I)
33843 XRQZ = -TANW*EI*ZMIX(IZID,1)
33844 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
33845 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
33846 IF(ILR.EQ.0) THEN
33847 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
33848 ELSE
33849 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
33850 ENDIF
33851 FACZQ=FACZQ0*BS
33852 KCHQ=2
33853 IF(I.LT.0) KCHQ=3
33854 DO 330 ISDE=1,2
33855 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33856 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33857 NCHN=NCHN+1
33858 ISIG(NCHN,ISDE)=I
33859 ISIG(NCHN,3-ISDE)=21
33860 ISIG(NCHN,3)=1
33861 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
33862 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33863 330 CONTINUE
33864 340 CONTINUE
33865 ENDIF
33866
33867 ELSEIF(ISUB.LE.260) THEN
33868 IF(ISUB.EQ.254) THEN
33869C...g + q_j -> ~chi1_1 + ~q_i
33870 FAC0=COMFAC*AS*AEM/12D0/XW
33871 ZM2=SQM4
33872 QM2=SQM3
33873 AU=UMIX(IZID,1)**2
33874 AD=VMIX(IZID,1)**2
33875 FACZQ0=FAC0*( (ZM2-TH)/SH +
33876 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
33877 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
33878 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
33879 IF(MOD(KFNSQ1,2).EQ.0) THEN
33880 KFNSQ=KFNSQ1-1
33881 KCHW=2
33882 ELSE
33883 KFNSQ=KFNSQ1+1
33884 KCHW=3
33885 ENDIF
33886 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
33887 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
33888 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33889 IA=IABS(I)
33890 IF(MOD(IA,2).EQ.0) THEN
33891 FACZQ=FACZQ0*AU
33892 ELSE
33893 FACZQ=FACZQ0*AD
33894 ENDIF
33895 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
33896 KCHQ=2
33897 IF(I.LT.0) KCHQ=3
33898 KCHWQ=KCHW
33899 IF(I.LT.0) KCHWQ=5-KCHW
33900 DO 350 ISDE=1,2
33901 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33902 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33903 NCHN=NCHN+1
33904 ISIG(NCHN,ISDE)=I
33905 ISIG(NCHN,3-ISDE)=21
33906 ISIG(NCHN,3)=1
33907 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
33908 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
33909 350 CONTINUE
33910 360 CONTINUE
33911
33912 ELSEIF(ISUB.EQ.258) THEN
33913C...g + q_j -> gluino + ~q_i
33914 XG2=SQM4
33915 XQ2=SQM3
33916 XMT=XG2-TH
33917 XMU=XG2-UH
33918 XST=XQ2-TH
33919 XSU=XQ2-UH
33920 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
33921 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
33922 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
33923 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
33924 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
33925 & (SH*(UH+XG2)
33926 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
33927 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
33928 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
33929 ASYUK=RMSS(42)*AS
33930 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
33931 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
33932 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
33933 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
33934 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
33935 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
33936 KCHQ=2
33937 IF(I.LT.0) KCHQ=3
33938 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
33939 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
33940 DO 370 ISDE=1,2
33941 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
33942 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
33943 NCHN=NCHN+1
33944 ISIG(NCHN,ISDE)=I
33945 ISIG(NCHN,3-ISDE)=21
33946 ISIG(NCHN,3)=1
33947 SIGH(NCHN)=FACQG1*FACSEL
33948 NCHN=NCHN+1
33949 ISIG(NCHN,ISDE)=I
33950 ISIG(NCHN,3-ISDE)=21
33951 ISIG(NCHN,3)=2
33952 SIGH(NCHN)=FACQG2*FACSEL
33953 370 CONTINUE
33954 380 CONTINUE
33955 ENDIF
33956
33957 ELSEIF(ISUB.LE.270) THEN
33958 IF(ISUB.EQ.261) THEN
33959C...q_i + q_ibar -> ~t_1 + ~t_1bar
33960 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
33961 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
33962 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
33963 FAC0=AS**2*4D0/9D0
33964 DO 390 I=MMIN1,MMAX1
33965 IA=IABS(I)
33966 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
33967 IF(IA.GE.11.AND.IA.LE.18) THEN
33968 EI=KCHG(IA,1)/3D0
33969 EJ=KCHG(KFNSQ,1)/3D0
33970 T3I=SIGN(1D0,EI)/2D0
33971 T3J=SIGN(1D0,EJ)/2D0
33972 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
33973 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
33974 XLF=2D0*(T3I-EI*XW)
33975 XRF=2D0*(-EI*XW)
33976 TAA=0.5D0*(EI*EJ)**2
33977 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
33978 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
33979 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
33980 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
33981 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
33982 ENDIF
33983 NCHN=NCHN+1
33984 ISIG(NCHN,1)=I
33985 ISIG(NCHN,2)=-I
33986 ISIG(NCHN,3)=1
33987 SIGH(NCHN)=FACQQ1*FAC0
33988 390 CONTINUE
33989
33990 ELSEIF(ISUB.EQ.263) THEN
33991C...f + fbar -> ~t1 + ~t2bar
33992 DO 400 I=MMIN1,MMAX1
33993 IA=IABS(I)
33994 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33995 EI=KCHG(IABS(I),1)/3D0
33996 TT3I=SIGN(1D0,EI)/2D0
33997 EJ=2D0/3D0
33998 TT3J=1D0/2D0
33999 FCOL=1D0
34000C...Color factor for e+ e-
34001 IF(IA.GE.11) FCOL=3D0
34002 XLQ=2D0*(TT3J-EJ*XW)
34003 XRQ=2D0*(-EJ*XW)
34004 XLF=2D0*(TT3I-EI*XW)
34005 XRF=2D0*(-EI*XW)
34006 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34007 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34008 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34009C...Factor of 2 for t1 t2bar + t2 t1bar
34010 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34011 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34012 NCHN=NCHN+1
34013 ISIG(NCHN,1)=I
34014 ISIG(NCHN,2)=-I
34015 ISIG(NCHN,3)=1
34016 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34017 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34018 NCHN=NCHN+1
34019 ISIG(NCHN,1)=I
34020 ISIG(NCHN,2)=-I
34021 ISIG(NCHN,3)=2
34022 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34023 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34024 400 CONTINUE
34025
34026 ELSEIF(ISUB.EQ.264) THEN
34027C...g + g -> ~t_1 + ~t_1bar
34028 XSU=SQM3-UH
34029 XST=SQM3-TH
34030 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34031 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34032 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34033 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34034 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34035 NCHN=NCHN+1
34036 ISIG(NCHN,1)=21
34037 ISIG(NCHN,2)=21
34038 ISIG(NCHN,3)=1
34039 SIGH(NCHN)=FACQQ1
34040 NCHN=NCHN+1
34041 ISIG(NCHN,1)=21
34042 ISIG(NCHN,2)=21
34043 ISIG(NCHN,3)=2
34044 SIGH(NCHN)=FACQQ2
34045 410 CONTINUE
34046 ENDIF
34047
34048 ELSEIF(ISUB.LE.280) THEN
34049 IF(ISUB.EQ.271) THEN
34050C...q + q' -> ~q + ~q' (~g exchange)
34051 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34052 XMT=XMG2-TH
34053 XMU=XMG2-UH
34054 XSU1=SQM3-UH
34055 XSU2=SQM4-UH
34056 XST1=SQM3-TH
34057 XST2=SQM4-TH
34058 ASYUK=RMSS(42)*AS
34059 IF(ILR.EQ.1) THEN
34060 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34061 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34062 FACQQB=0.0D0
34063 ELSE
34064 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34065 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34066 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34067 & XMT/XMU )
34068 ENDIF
34069 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34070 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34071 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34072 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34073 IA=IABS(I)
34074 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34075 KCHQ=2
34076 IF(I.LT.0) KCHQ=3
34077 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34078 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
34079 JA=IABS(J)
34080 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
34081 IF(I*J.LT.0) GOTO 420
34082 NCHN=NCHN+1
34083 ISIG(NCHN,1)=I
34084 ISIG(NCHN,2)=J
34085 ISIG(NCHN,3)=1
34086 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34087 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34088 IF(I.EQ.J) THEN
34089 IF(ILR.EQ.0) THEN
34090 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
34091 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34092 ELSE
34093 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
34094 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34095 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34096 ENDIF
34097 NCHN=NCHN+1
34098 ISIG(NCHN,1)=I
34099 ISIG(NCHN,2)=J
34100 ISIG(NCHN,3)=2
34101 IF(ILR.EQ.0) THEN
34102 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
34103 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34104 ELSE
34105 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
34106 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34107 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34108 ENDIF
34109 ENDIF
34110 420 CONTINUE
34111 430 CONTINUE
34112
34113 ELSEIF(ISUB.EQ.274) THEN
34114C...q + qbar' -> ~q + ~qbar'
34115 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34116 XMT=XMG2-TH
34117 XMU=XMG2-UH
34118 IF(ILR.EQ.0) THEN
34119C...Mrenna...Normalization.and.1/XMT
34120 FACQQ1=COMFAC*AS**2*2D0/9D0*(
34121 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
34122 FACQQB=COMFAC*AS**2*4D0/9D0*(
34123 & (UH*TH-SQM3*SQM4)/SH2 )
34124 FACQQI=-COMFAC*AS**2*4D0/27D0*(
34125 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
34126 FACQQB=FACQQB+FACQQ1+FACQQI
34127 ELSE
34128 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
34129 FACQQB=FACQQ1
34130 ENDIF
34131 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34132 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34133 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
34134 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
34135 IA=IABS(I)
34136 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
34137 KCHQ=2
34138 IF(I.LT.0) KCHQ=3
34139 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34140 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
34141 JA=IABS(J)
34142 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
34143 IF(I*J.GT.0) GOTO 440
34144 NCHN=NCHN+1
34145 ISIG(NCHN,1)=I
34146 ISIG(NCHN,2)=J
34147 ISIG(NCHN,3)=1
34148 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34149 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
34150 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
34151 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34152 440 CONTINUE
34153 450 CONTINUE
34154
34155 ELSEIF(ISUB.EQ.277) THEN
34156C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
34157C...if i .eq. j covered in 274
34158 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
34159 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34160 FAC0=0D0
34161 DO 460 I=MMIN1,MMAX1
34162 IA=IABS(I)
34163 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
34164 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
34165 IF(IA.EQ.KFNSQ) GOTO 460
34166 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
34167 EI=KCHG(IA,1)/3D0
34168 EJ=KCHG(KFNSQ,1)/3D0
34169 T3J=SIGN(0.5D0,EJ)
34170 T3I=SIGN(1D0,EI)/2D0
34171 IF(ILR.EQ.0) THEN
34172 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
34173 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
34174 ELSE
34175 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
34176 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
34177 ENDIF
34178 XLF=2D0*(T3I-EI*XW)
34179 XRF=2D0*(-EI*XW)
34180 IF(ILR.EQ.0) THEN
34181 XRQ=0D0
34182 ELSE
34183 XLQ=0D0
34184 ENDIF
34185 TAA=0.5D0*(EI*EJ)**2
34186 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34187 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34188 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34189 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34190 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34191 ELSEIF(IA.LE.6) THEN
34192 FAC0=AS**2*8D0/9D0/2D0
34193 ENDIF
34194 NCHN=NCHN+1
34195 ISIG(NCHN,1)=I
34196 ISIG(NCHN,2)=-I
34197 ISIG(NCHN,3)=1
34198 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34199 460 CONTINUE
34200
34201 ELSEIF(ISUB.EQ.279) THEN
34202C...g + g -> ~q_j + ~q_jbar
34203 XSU=SQM3-UH
34204 XST=SQM3-TH
34205C...5=RKF because ~t ~tbar treated separately
34206 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
34207 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34208 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34209 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
34210 NCHN=NCHN+1
34211 ISIG(NCHN,1)=21
34212 ISIG(NCHN,2)=21
34213 ISIG(NCHN,3)=1
34214 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34215 NCHN=NCHN+1
34216 ISIG(NCHN,1)=21
34217 ISIG(NCHN,2)=21
34218 ISIG(NCHN,3)=2
34219 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34220 470 CONTINUE
34221
34222 ENDIF
34223 ENDIF
34224CMRENNA--
34225
34226 RETURN
34227 END
34228
34229C*********************************************************************
34230
34231C...PYSGTC
34232C...Subprocess cross sections for Technicolor processes.
34233C...Auxiliary to PYSIGH.
34234
34235 SUBROUTINE PYSGTC(NCHN,SIGS)
34236
34237C...Double precision and integer declarations
34238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34239 IMPLICIT INTEGER(I-N)
34240 INTEGER PYK,PYCHGE,PYCOMP
34241C...Parameter statement to help give large particle numbers.
34242 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34243 &KEXCIT=4000000,KDIMEN=5000000)
34244C...Commonblocks
34245 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34246 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34247 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34248 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34249 COMMON/PYINT1/MINT(400),VINT(400)
34250 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34251 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34252 COMMON/PYINT4/MWID(500),WIDS(500,5)
34253 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
34254 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34255 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34256 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34257 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34258 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
34259 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
34260C...Local arrays and complex variables
34261 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34262 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
34263 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
34264 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
34265 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
34266 COMPLEX*16 DVVS,DVVT,DVVU
34267 INTEGER INDX(6)
34268
34269C...Combinations of weak mixing angle.
34270 TANW=SQRT(XW/XW1)
34271 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34272
34273C...Convert almost equivalent technicolor processes into
34274C...a few basic processes, and set distinguishing parameters.
34275 IF(ISUB.GE.361.AND.ISUB.LE.379) THEN
34276 SQTV=RTCM(12)**2
34277 SQTA=RTCM(13)**2
34278 SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
34279 CS2W=1D0-2D0*PARU(102)
34280 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
34281 CT2W=CS2W/SN2W
34282 CSXI=COS(ASIN(RTCM(3)))
34283 CSXIP=COS(ASIN(RTCM(4)))
34284 QUPD=2D0*RTCM(2)-1D0
34285 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
34286C... rho_tc0 -> W_L W_L
34287 IF(ISUB.EQ.361) THEN
34288 KFA=24
34289 KFB=24
34290 CAB2=RTCM(3)**4
34291C... rho_tc0 -> W_L pi_tc-
34292 ELSEIF(ISUB.EQ.362) THEN
34293 KFA=24
34294 KFB=KTECHN+211
34295 ISUB=361
34296 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
34297C... pi_tc pi_tc
34298 ELSEIF(ISUB.EQ.363) THEN
34299 KFA=KTECHN+211
34300 KFB=KTECHN+211
34301 ISUB=361
34302 CAB2=(1D0-RTCM(3)**2)**2
34303C... rho_tc0/omega_tc -> gamma pi_tc
34304 ELSEIF(ISUB.EQ.364) THEN
34305 KFA=22
34306 KFB=KTECHN+111
34307 VOGP=CSXI/RTCM(12)
34308C..........!!!
34309 VRGP=VOGP*QUPD
34310 AOGP=0D0
34311 ARGP=0D0
34312 VAGP=2D0*QUPD*CSXI
34313 VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
34314C... gamma pi_tc'
34315 ELSEIF(ISUB.EQ.365) THEN
34316 KFA=22
34317 KFB=KTECHN+221
34318 ISUB=364
34319 VRGP=CSXIP/RTCM(12)
34320C..........!!!!
34321 VOGP=VRGP*QUPD
34322 AOGP=0D0
34323 ARGP=0D0
34324 VAGP=2D0*Q2UD*CSXIP
34325 VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
34326C... Z pi_tc
34327 ELSEIF(ISUB.EQ.366) THEN
34328 KFA=23
34329 KFB=KTECHN+111
34330 ISUB=364
34331 VOGP=CSXI*CT2W/RTCM(12)
34332 VRGP=-QUPD*CSXI*TANW/RTCM(12)
34333 AOGP=0D0
34334 ARGP=0D0
34335 VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
34336 VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
34337C... Z pi_tc'
34338 ELSEIF(ISUB.EQ.367) THEN
34339 KFA=23
34340 KFB=KTECHN+221
34341 ISUB=364
34342 VRGP=CSXIP*CT2W/RTCM(12)
34343 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
34344 AOGP=0D0
34345 ARGP=0D0
34346 VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
34347 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
34348C... W_T pi_tc
34349 ELSEIF(ISUB.EQ.368) THEN
34350 KFA=24
34351 KFB=KTECHN+211
34352 ISUB=364
34353 VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
34354 VRGP=0D0
34355 AOGP=0D0
34356C..........!!!!
34357 ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
34358 VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
34359 VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
34360C... rho_tc+ -> W_L Z_L
34361 ELSEIF(ISUB.EQ.370) THEN
34362 KFA=24
34363 KFB=23
34364 CAB2=RTCM(3)**4
34365C... W_L pi_tc0
34366 ELSEIF(ISUB.EQ.371) THEN
34367 KFA=24
34368 KFB=KTECHN+111
34369 ISUB=370
34370 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
34371C... Z_L pi_tc+
34372 ELSEIF(ISUB.EQ.372) THEN
34373 KFA=KTECHN+211
34374 KFB=23
34375 ISUB=370
34376 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
34377C... pi_tc+ pi_tc0
34378 ELSEIF(ISUB.EQ.373) THEN
34379 KFA=KTECHN+211
34380 KFB=KTECHN+111
34381 ISUB=370
34382 CAB2=(1D0-RTCM(3)**2)**2
34383C... gamma pi_tc+
34384 ELSEIF(ISUB.EQ.374) THEN
34385 KFA=KTECHN+211
34386 KFB=22
34387 VRGP=QUPD*CSXI
34388 ARGP=0D0
34389 VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
34390C... Z_T pi_tc+
34391 ELSEIF(ISUB.EQ.375) THEN
34392 KFA=KTECHN+211
34393 KFB=23
34394 ISUB=374
34395 VRGP=-QUPD*CSXI*TANW
34396 ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
34397 VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
34398C... W_T pi_tc0
34399 ELSEIF(ISUB.EQ.376) THEN
34400 KFA=24
34401 KFB=KTECHN+111
34402 ISUB=374
34403 VRGP=0D0
34404 ARGP=-CSXI/(2D0*SQRT(PARU(102)))
34405 VWGP=0D0
34406C... W_T pi_tc0'
34407 ELSEIF(ISUB.EQ.377) THEN
34408 KFA=24
34409 KFB=KTECHN+221
34410 ISUB=374
34411 ARGP=0D0
34412 VRGP=CSXIP/(2D0*SQRT(PARU(102)))
34413 VWGP=CSXIP/(2D0*PARU(102))
34414 ENDIF
34415 ENDIF
34416
34417C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
34418 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
34419 IF(ITCM(5).LE.4) THEN
34420 SQDQQS=1D0/SH2
34421 SQDQQT=1D0/TH2
34422 SQDQQU=1D0/UH2
34423 SQDGGS=SQDQQS
34424 SQDGGT=SQDQQT
34425 SQDGGU=SQDQQU
34426 REDGGS=1D0/SH
34427 REDGGT=1D0/TH
34428 REDGGU=1D0/UH
34429 REDGTU=1D0/UH/TH
34430 REDGSU=1D0/SH/UH
34431 REDGST=1D0/SH/TH
34432 REDQST=1D0/SH/TH
34433 REDQTU=1D0/UH/TH
34434 SQDLGS=0D0
34435 SQDLGT=0D0
34436 SQDQTS=SQDQQS
34437 ELSEIF(ITCM(5).EQ.5) THEN
34438 TANT3=RTCM(21)
34439 IF(ITCM(2).EQ.0) THEN
34440 IMDL=1
34441 ELSE
34442 IMDL=2
34443 ENDIF
34444 ALPRHT=2.91D0*(3D0/ITCM(1))
34445 SIN2T=2D0*TANT3/(TANT3**2+1D0)
34446 SINT3=TANT3/SQRT(TANT3**2+1D0)
34447 XIG=SQRT(PYALPS(SH)/ALPRHT)
34448 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
34449 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
34450 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
34451 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
34452 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
34453 & SINT3**2)*2D0/SIN2T
34454 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
34455 & SINT3**2)*2D0/SIN2T
34456
34457 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
34458 SM1112=X12*RTCM(28)**2*SIN2T
34459 SM1121=-X21*RTCM(28)**2*SIN2T
34460 SM2212=-SM1112
34461 SM2221=-SM1121
34462 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
34463 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
34464
34465C.........SH LOOP
34466 ZTC(1,1)=DCMPLX(SH,0D0)
34467 CALL PYWIDT(3100021,SH,WDTP,WDTE)
34468 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
34469 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
34470 CALL PYWIDT(3100113,SH,WDTP,WDTE)
34471 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
34472 CALL PYWIDT(3400113,SH,WDTP,WDTE)
34473 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
34474 CALL PYWIDT(3200113,SH,WDTP,WDTE)
34475 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
34476 CALL PYWIDT(3300113,SH,WDTP,WDTE)
34477 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
34478 ZTC(1,2)=(0D0,0D0)
34479 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
34480 ZTC(1,4)=ZTC(1,3)
34481 ZTC(1,5)=ZTC(1,2)
34482 ZTC(1,6)=ZTC(1,2)
34483 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
34484 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
34485 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
34486 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
34487 ZTC(3,4)=-SM1122
34488 ZTC(3,5)=-SM1112
34489 ZTC(3,6)=-SM1121
34490 ZTC(4,5)=-SM2212
34491 ZTC(4,6)=-SM2221
34492 ZTC(5,6)=-SM1221
34493
34494 DO 110 I=1,5
34495 DO 100 J=I+1,6
34496 ZTC(J,I)=ZTC(I,J)
34497 100 CONTINUE
34498 110 CONTINUE
34499 CALL PYLDCM(ZTC,6,6,INDX,D)
34500 DO 130 I=1,6
34501 DO 120 J=1,6
34502 YTC(I,J)=(0D0,0D0)
34503 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
34504 120 CONTINUE
34505 130 CONTINUE
34506
34507 DO 140 I=1,6
34508 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
34509 140 CONTINUE
34510 DGGS=YTC(1,1)
34511 DVVS=YTC(2,2)
34512 DGVS=YTC(1,2)
34513
34514 XIG=SQRT(PYALPS(-TH)/ALPRHT)
34515C.........TH LOOP
34516 ZTC(1,1)=DCMPLX(TH)
34517 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
34518 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
34519 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
34520 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
34521 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
34522 ZTC(1,2)=(0D0,0D0)
34523 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
34524 ZTC(1,4)=ZTC(1,3)
34525 ZTC(1,5)=ZTC(1,2)
34526 ZTC(1,6)=ZTC(1,2)
34527 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
34528 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
34529 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
34530 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
34531 ZTC(3,4)=-SM1122
34532 ZTC(3,5)=-SM1112
34533 ZTC(3,6)=-SM1121
34534 ZTC(4,5)=-SM2212
34535 ZTC(4,6)=-SM2221
34536 ZTC(5,6)=-SM1221
34537 DO 160 I=1,5
34538 DO 150 J=I+1,6
34539 ZTC(J,I)=ZTC(I,J)
34540 150 CONTINUE
34541 160 CONTINUE
34542 CALL PYLDCM(ZTC,6,6,INDX,D)
34543 DO 180 I=1,6
34544 DO 170 J=1,6
34545 YTC(I,J)=(0D0,0D0)
34546 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
34547 170 CONTINUE
34548 180 CONTINUE
34549 DO 190 I=1,6
34550 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
34551 190 CONTINUE
34552 DGGT=YTC(1,1)
34553 DVVT=YTC(2,2)
34554 DGVT=YTC(1,2)
34555
34556 XIG=SQRT(PYALPS(-UH)/ALPRHT)
34557C.........UH LOOP
34558 ZTC(1,1)=DCMPLX(UH,0D0)
34559 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
34560 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
34561 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
34562 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
34563 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
34564 ZTC(1,2)=(0D0,0D0)
34565 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
34566 ZTC(1,4)=ZTC(1,3)
34567 ZTC(1,5)=ZTC(1,2)
34568 ZTC(1,6)=ZTC(1,2)
34569 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
34570 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
34571 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
34572 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
34573 ZTC(3,4)=-SM1122
34574 ZTC(3,5)=-SM1112
34575 ZTC(3,6)=-SM1121
34576 ZTC(4,5)=-SM2212
34577 ZTC(4,6)=-SM2221
34578 ZTC(5,6)=-SM1221
34579 DO 210 I=1,5
34580 DO 200 J=I+1,6
34581 ZTC(J,I)=ZTC(I,J)
34582 200 CONTINUE
34583 210 CONTINUE
34584 CALL PYLDCM(ZTC,6,6,INDX,D)
34585 DO 230 I=1,6
34586 DO 220 J=1,6
34587 YTC(I,J)=(0D0,0D0)
34588 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
34589 220 CONTINUE
34590 230 CONTINUE
34591 DO 240 I=1,6
34592 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
34593 240 CONTINUE
34594 DGGU=YTC(1,1)
34595 DVVU=YTC(2,2)
34596 DGVU=YTC(1,2)
34597
34598 IF(IMDL.EQ.1) THEN
34599 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
34600 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
34601 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
34602 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
34603 DQGS=DGGS-DGVS*DCMPLX(TANT3)
34604 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
34605 ELSE
34606 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
34607 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
34608 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
34609 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
34610 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
34611 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
34612 ENDIF
34613
34614 SQDQTS=ABS(DQTS)**2
34615 SQDQQS=ABS(DQQS)**2
34616 SQDQQT=ABS(DQQT)**2
34617 SQDQQU=ABS(DQQU)**2
34618 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
34619 REDLGS=DBLE(DQGS)
34620 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
34621 REDHGS=DBLE(DTGS)
34622 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
34623
34624 SQDGGS=ABS(DGGS)**2
34625 SQDGGT=ABS(DGGT)**2
34626 SQDGGU=ABS(DGGU)**2
34627 REDGGS=DBLE(DGGS)
34628 REDGGT=DBLE(DGGT)
34629 REDGGU=DBLE(DGGU)
34630 REDGTU=DBLE(DGGU*DCONJG(DGGT))
34631 REDGSU=DBLE(DGGU*DCONJG(DGGS))
34632 REDGST=DBLE(DGGS*DCONJG(DGGT))
34633 REDQST=DBLE(DQQS*DCONJG(DQQT))
34634 REDQTU=DBLE(DQQT*DCONJG(DQQU))
34635 ENDIF
34636 ENDIF
34637
34638
34639C...Differential cross section expressions.
34640
34641 IF(ISUB.LE.190) THEN
34642 IF(ISUB.EQ.149) THEN
34643C...g + g -> eta_tc
34644 KCTC=PYCOMP(KTECHN+331)
34645 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
34646 HS=SHR*WDTP(0)
34647 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
34648 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34649 HP=SH
34650 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
34651 HI=HP*WDTP(3)
34652 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34653 NCHN=NCHN+1
34654 ISIG(NCHN,1)=21
34655 ISIG(NCHN,2)=21
34656 ISIG(NCHN,3)=1
34657 SIGH(NCHN)=HI*FACBW*HF
34658 250 CONTINUE
34659
34660 ELSEIF(ISUB.EQ.165) THEN
34661C...q + qbar -> l+ + l- (including contact term for compositeness)
34662 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
34663 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
34664 KFF=IABS(KFPR(ISUB,1))
34665 EF=KCHG(KFF,1)/3D0
34666 AF=SIGN(1D0,EF+0.1D0)
34667 VF=AF-4D0*EF*XWV
34668 VALF=VF+AF
34669 VARF=VF-AF
34670 FCOF=1D0
34671 IF(KFF.LE.10) FCOF=3D0
34672 WID2=1D0
34673 IF(KFF.EQ.6) WID2=WIDS(6,1)
34674 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
34675 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
34676 DO 260 I=MMINA,MMAXA
34677 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
34678 EI=KCHG(IABS(I),1)/3D0
34679 AI=SIGN(1D0,EI+0.1D0)
34680 VI=AI-4D0*EI*XWV
34681 VALI=VI+AI
34682 VARI=VI-AI
34683 FCOI=1D0
34684 IF(IABS(I).LE.10) FCOI=FACA/3D0
34685 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
34686 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
34687 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
34688 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
34689 ELSE
34690 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
34691 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
34692 ENDIF
34693 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
34694 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
34695 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
34696 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
34697 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
34698 NCHN=NCHN+1
34699 ISIG(NCHN,1)=I
34700 ISIG(NCHN,2)=-I
34701 ISIG(NCHN,3)=1
34702 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
34703 260 CONTINUE
34704
34705 ELSEIF(ISUB.EQ.166) THEN
34706C...q + q'bar -> l + nu_l (including contact term for compositeness)
34707 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
34708 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
34709 KFF=IABS(KFPR(ISUB,1))
34710 FCOF=1D0
34711 IF(KFF.LE.10) FCOF=3D0
34712 DO 280 I=MMIN1,MMAX1
34713 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
34714 IA=IABS(I)
34715 DO 270 J=MMIN2,MMAX2
34716 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
34717 JA=IABS(J)
34718 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
34719 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34720 & GOTO 270
34721 FCOI=1D0
34722 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
34723 WID2=1D0
34724 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
34725 & MOD(J,2).EQ.0)) THEN
34726 IF(KFF.EQ.5) WID2=WIDS(6,2)
34727 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
34728 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
34729 ELSE
34730 IF(KFF.EQ.5) WID2=WIDS(6,3)
34731 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
34732 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
34733 ENDIF
34734 NCHN=NCHN+1
34735 ISIG(NCHN,1)=I
34736 ISIG(NCHN,2)=J
34737 ISIG(NCHN,3)=1
34738 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
34739 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
34740 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
34741 270 CONTINUE
34742 280 CONTINUE
34743 ENDIF
34744
34745 ELSEIF(ISUB.LE.200) THEN
34746 IF(ISUB.EQ.191) THEN
34747C...q + qbar -> rho_tc0.
34748 KCTC=PYCOMP(KTECHN+113)
34749 SQMRHT=PMAS(KCTC,1)**2
34750 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
34751 HS=SHR*WDTP(0)
34752 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
34753 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34754 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34755 ALPRHT=2.91D0*(3D0/ITCM(1))
34756 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
34757 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
34758 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
34759 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
34760 DO 290 I=MMINA,MMAXA
34761 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
34762 IA=IABS(I)
34763 EI=KCHG(IABS(I),1)/3D0
34764 AI=SIGN(1D0,EI+0.1D0)
34765 VI=AI-4D0*EI*XWV
34766 VALI=0.5D0*(VI+AI)
34767 VARI=0.5D0*(VI-AI)
34768 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
34769 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
34770 IF(IA.LE.10) HI=HI*FACA/3D0
34771 NCHN=NCHN+1
34772 ISIG(NCHN,1)=I
34773 ISIG(NCHN,2)=-I
34774 ISIG(NCHN,3)=1
34775 SIGH(NCHN)=HI*FACBW*HF
34776 290 CONTINUE
34777
34778 ELSEIF(ISUB.EQ.192) THEN
34779C...q + qbar' -> rho_tc+/-.
34780 KCTC=PYCOMP(KTECHN+213)
34781 SQMRHT=PMAS(KCTC,1)**2
34782 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
34783 HS=SHR*WDTP(0)
34784 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
34785 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34786 ALPRHT=2.91D0*(3D0/ITCM(1))
34787 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
34788 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
34789 DO 310 I=MMIN1,MMAX1
34790 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
34791 IA=IABS(I)
34792 DO 300 J=MMIN2,MMAX2
34793 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
34794 JA=IABS(J)
34795 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
34796 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34797 & GOTO 300
34798 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34799 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
34800 HI=HP
34801 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
34802 NCHN=NCHN+1
34803 ISIG(NCHN,1)=I
34804 ISIG(NCHN,2)=J
34805 ISIG(NCHN,3)=1
34806 SIGH(NCHN)=HI*FACBW*HF
34807 300 CONTINUE
34808 310 CONTINUE
34809
34810 ELSEIF(ISUB.EQ.193) THEN
34811C...q + qbar -> omega_tc0.
34812 KCTC=PYCOMP(KTECHN+223)
34813 SQMOMT=PMAS(KCTC,1)**2
34814 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
34815 HS=SHR*WDTP(0)
34816 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
34817 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
34818 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34819 ALPRHT=2.91D0*(3D0/ITCM(1))
34820 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
34821 & (2D0*RTCM(2)-1D0)**2
34822 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
34823 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
34824 DO 320 I=MMINA,MMAXA
34825 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
34826 IA=IABS(I)
34827 EI=KCHG(IABS(I),1)/3D0
34828 AI=SIGN(1D0,EI+0.1D0)
34829 VI=AI-4D0*EI*XWV
34830 VALI=0.5D0*(VI+AI)
34831 VARI=0.5D0*(VI-AI)
34832 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
34833 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
34834 IF(IA.LE.10) HI=HI*FACA/3D0
34835 NCHN=NCHN+1
34836 ISIG(NCHN,1)=I
34837 ISIG(NCHN,2)=-I
34838 ISIG(NCHN,3)=1
34839 SIGH(NCHN)=HI*FACBW*HF
34840 320 CONTINUE
34841
34842 ELSEIF(ISUB.EQ.194) THEN
34843C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc.
34844 KFA=KFPR(ISUBSV,1)
34845 ALPRHT=2.91D0*(3D0/ITCM(1))
34846 HP=AEM**2*COMFAC
34847 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
34848 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
34849
34850 QUPD=2D0*RTCM(2)-1D0
34851 FAR=SQRT(AEM/ALPRHT)
34852 FAO=FAR*QUPD
34853 FZR=FAR*CT2W
34854 FZO=-FAO*TANW
34855 SFAR=FAR**2
34856 SFAO=FAO**2
34857 SFZR=FZR**2
34858 SFZO=FZO**2
34859 CALL PYWIDT(23,SH,WDTP,WDTE)
34860 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
34861 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
34862 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
34863 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
34864 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
34865 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
34866 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
34867 DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
34868 DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
34869 DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
34870
34871 XWRHT=1D0/(4D0*XW*(1D0-XW))
34872 KFF=IABS(KFPR(ISUB,1))
34873 EF=KCHG(KFF,1)/3D0
34874 AF=SIGN(1D0,EF+0.1D0)
34875 VF=AF-4D0*EF*XWV
34876 VALF=0.5D0*(VF+AF)
34877 VARF=0.5D0*(VF-AF)
34878 FCOF=1D0
34879 IF(KFF.LE.10) FCOF=3D0
34880
34881 WID2=1D0
34882 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
34883 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
34884 DZZ=DZZ*DCMPLX(XWRHT,0D0)
34885 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
34886
34887 DO 330 I=MMINA,MMAXA
34888 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
34889 EI=KCHG(IABS(I),1)/3D0
34890 AI=SIGN(1D0,EI+0.1D0)
34891 VI=AI-4D0*EI*XWV
34892 VALI=0.5D0*(VI+AI)
34893 VARI=0.5D0*(VI-AI)
34894 FCOI=FCOF
34895 IF(IABS(I).LE.10) FCOI=FCOI/3D0
34896 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
34897 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
34898 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
34899 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
34900 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
34901 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
34902 NCHN=NCHN+1
34903 ISIG(NCHN,1)=I
34904 ISIG(NCHN,2)=-I
34905 ISIG(NCHN,3)=1
34906 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
34907 330 CONTINUE
34908
34909 ELSEIF(ISUB.EQ.195) THEN
34910C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+
34911 KFA=KFPR(ISUBSV,1)
34912 KFB=KFA+1
34913 ALPRHT=2.91D0*(3D0/ITCM(1))
34914 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
34915
34916 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
34917 CALL PYWIDT(24,SH,WDTP,WDTE)
34918 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
34919 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
34920 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
34921
34922 FCOF=1D0
34923 IF(KFA.LE.8) FCOF=3D0
34924 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
34925 HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF
34926
34927 DO 350 I=MMIN1,MMAX1
34928 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
34929 IA=IABS(I)
34930 DO 340 J=MMIN2,MMAX2
34931 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
34932 JA=IABS(J)
34933 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
34934 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34935 & GOTO 340
34936 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34937 HI=HP
34938 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
34939 NCHN=NCHN+1
34940 ISIG(NCHN,1)=I
34941 ISIG(NCHN,2)=J
34942 ISIG(NCHN,3)=1
34943 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
34944 340 CONTINUE
34945 350 CONTINUE
34946 ENDIF
34947
34948 ELSEIF(ISUB.LE.380) THEN
34949 IF(ISUB.EQ.361) THEN
34950C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
34951 FACA=(SH**2*BE34**2-(TH-UH)**2)
34952 ALPRHT=2.91D0*(3D0/ITCM(1))
34953 HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
34954 FAR=SQRT(AEM/ALPRHT)
34955 FAO=FAR*QUPD
34956 FZR=FAR*CT2W
34957 FZO=-FAO*TANW
34958 SFAR=FAR**2
34959 SFAO=FAO**2
34960 SFZR=FZR**2
34961 SFZO=FZO**2
34962 CALL PYWIDT(23,SH,WDTP,WDTE)
34963 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
34964 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
34965 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
34966 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
34967 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
34968 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
34969 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
34970 DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
34971 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
34972 DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
34973 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
34974 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
34975
34976 DO 360 I=MMINA,MMAXA
34977 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
34978 IA=IABS(I)
34979 EI=KCHG(IABS(I),1)/3D0
34980 AI=SIGN(1D0,EI+0.1D0)
34981 VI=AI-4D0*EI*XWV
34982 VALI=0.25D0*(VI+AI)
34983 VARI=0.25D0*(VI-AI)
34984 F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
34985 $ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
34986 F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
34987 $ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
34988 HI=ABS(F2L)**2+ABS(F2R)**2
34989 IF(IA.LE.10) HI=HI/3D0
34990 NCHN=NCHN+1
34991 ISIG(NCHN,1)=I
34992 ISIG(NCHN,2)=-I
34993 ISIG(NCHN,3)=1
34994 IF(KFA.EQ.KFB) THEN
34995 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
34996 ELSE
34997 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
34998 NCHN=NCHN+1
34999 ISIG(NCHN,1)=I
35000 ISIG(NCHN,2)=-I
35001 ISIG(NCHN,3)=2
35002 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
35003 ENDIF
35004 360 CONTINUE
35005
35006 ELSEIF(ISUB.EQ.364) THEN
35007C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35008C...W pi_tc
35009 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35010 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35011 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35012
35013 ALPRHT=2.91D0*(3D0/ITCM(1))
35014 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35015 FAR=SQRT(AEM/ALPRHT)
35016 FAO=FAR*QUPD
35017 FZR=FAR*CT2W
35018 FZO=-FAO*TANW
35019 SFAR=FAR**2
35020 SFAO=FAO**2
35021 SFZR=FZR**2
35022 SFZO=FZO**2
35023 CALL PYWIDT(23,SH,WDTP,WDTE)
35024 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35025 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35026 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35027 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35028 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35029 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35030 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35031 DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
35032 DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
35033 DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
35034 DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
35035 DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
35036 DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
35037 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
35038
35039 DO 370 I=MMINA,MMAXA
35040 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35041 IA=IABS(I)
35042 EI=KCHG(IABS(I),1)/3D0
35043 AI=SIGN(1D0,EI+0.1D0)
35044 VI=AI-4D0*EI*XWV
35045 VALI=0.25D0*(VI+AI)
35046 VARI=0.25D0*(VI-AI)
35047C...........Add in anomaly contribution
35048 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35049 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35050 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35051 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35052 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35053 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35054 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35055 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35056 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35057 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35058 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35059 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35060 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35061 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35062 HI=HI+HJ
35063 IF(IA.LE.10) HI=HI/3D0
35064 NCHN=NCHN+1
35065 ISIG(NCHN,1)=I
35066 ISIG(NCHN,2)=-I
35067 ISIG(NCHN,3)=1
35068 IF(ISUBSV.NE.368) THEN
35069 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
35070 ELSE
35071 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
35072 NCHN=NCHN+1
35073 ISIG(NCHN,1)=I
35074 ISIG(NCHN,2)=-I
35075 ISIG(NCHN,3)=2
35076 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
35077 ENDIF
35078 370 CONTINUE
35079
35080 ELSEIF(ISUB.EQ.370) THEN
35081C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
35082
35083 FACA=(SH**2*BE34**2-(TH-UH)**2)
35084 ALPRHT=2.91D0*(3D0/ITCM(1))
35085 HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
35086 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35087 CALL PYWIDT(24,SH,WDTP,WDTE)
35088 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35089 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35090 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35091 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
35092 DWW=SSMR/DETD/SH
35093 DWRHO=-1D0/DETD/SH
35094 HP=HP*ABS(DWW+DWRHO)**2
35095 DO 390 I=MMIN1,MMAX1
35096 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
35097 IA=IABS(I)
35098 DO 380 J=MMIN2,MMAX2
35099 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
35100 JA=IABS(J)
35101 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
35102 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35103 & GOTO 380
35104 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35105 HI=HP
35106 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35107 NCHN=NCHN+1
35108 ISIG(NCHN,1)=I
35109 ISIG(NCHN,2)=J
35110 ISIG(NCHN,3)=1
35111 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
35112 & WIDS(PYCOMP(KFB),2)
35113 380 CONTINUE
35114 390 CONTINUE
35115
35116 ELSEIF(ISUB.EQ.374) THEN
35117C...f + fbar' -> gamma pi_tc
35118 FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
35119 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35120 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
35121 ALPRHT=2.91D0*(3D0/ITCM(1))
35122 HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
35123 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35124 CALL PYWIDT(24,SH,WDTP,WDTE)
35125 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35126 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35127 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35128 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
35129 DWW=SSMR/DETD/SH
35130 DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
35131 HP=HP*(AFAC*ABS(DWRHO)**2+
35132 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**2)
35133 DO 410 I=MMIN1,MMAX1
35134 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
35135 IA=IABS(I)
35136 DO 400 J=MMIN2,MMAX2
35137 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
35138 JA=IABS(J)
35139 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
35140 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35141 & GOTO 400
35142 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35143 HI=HP
35144 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35145 NCHN=NCHN+1
35146 ISIG(NCHN,1)=I
35147 ISIG(NCHN,2)=J
35148 ISIG(NCHN,3)=1
35149 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
35150 & WIDS(PYCOMP(KFB),2)
35151 400 CONTINUE
35152 410 CONTINUE
35153 ENDIF
35154
35155 ELSEIF(ISUB.LE.390) THEN
35156 IF(ISUB.EQ.381) THEN
35157C...f + f' -> f + f' (g exchange)
35158 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
35159 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
35160 & MSTP(34)*2D0/3D0*UH2*REDQST)
35161 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
35162 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
35163 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
35164 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
35165C...Modifications from contact interactions (compositeness)
35166 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
35167 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
35168 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
35169 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
35170 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
35171 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
35172 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
35173 ELSEIF(ITCM(5).EQ.5) THEN
35174 FACCI1=FACQQ1
35175 FACCIB=FACQQB
35176 FACCI2=FACQQ2
35177 FACCI3=FACQQ1
35178CSM.......Check this change from
35179CSM RATCII=1D0
35180 RATCII=RATQQI
35181 ENDIF
35182 DO 430 I=MMIN1,MMAX1
35183 IA=IABS(I)
35184 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35185 DO 420 J=MMIN2,MMAX2
35186 JA=IABS(J)
35187 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35188 NCHN=NCHN+1
35189 ISIG(NCHN,1)=I
35190 ISIG(NCHN,2)=J
35191 ISIG(NCHN,3)=1
35192 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
35193 & JA.GE.3))) THEN
35194 SIGH(NCHN)=FACQQ1
35195 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
35196 ELSE
35197 SIGH(NCHN)=FACCI1
35198 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
35199 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
35200 ENDIF
35201 IF(I.EQ.J) THEN
35202 NCHN=NCHN+1
35203 ISIG(NCHN,1)=I
35204 ISIG(NCHN,2)=J
35205 ISIG(NCHN,3)=2
35206 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
35207 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
35208 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
35209 ELSE
35210 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
35211 SIGH(NCHN)=0.5D0*FACCI2*RATCII
35212 ENDIF
35213 ENDIF
35214 420 CONTINUE
35215 430 CONTINUE
35216
35217 ELSEIF(ISUB.EQ.382) THEN
35218C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
35219 CALL PYWIDT(21,SH,WDTP,WDTE)
35220 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
35221 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35222 IF(ITCM(5).EQ.1) THEN
35223C...Modifications from contact interactions (compositeness)
35224 FACCIB=FACQQB
35225 DO 440 I=1,2
35226 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
35227 & WDTE(I,2)+WDTE(I,4))
35228 440 CONTINUE
35229 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
35230 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
35231 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35232 ELSEIF(ITCM(5).EQ.5) THEN
35233 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
35234 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
35235 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
35236 ENDIF
35237 DO 450 I=MMINA,MMAXA
35238 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35239 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
35240 NCHN=NCHN+1
35241 ISIG(NCHN,1)=I
35242 ISIG(NCHN,2)=-I
35243 ISIG(NCHN,3)=1
35244 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
35245 SIGH(NCHN)=FACQQB
35246 ELSEIF(ITCM(5).EQ.5) THEN
35247 SIGH(NCHN)=FACQQB
35248 NCHN=NCHN+1
35249 ISIG(NCHN,1)=I
35250 ISIG(NCHN,2)=-I
35251 ISIG(NCHN,3)=2
35252 SIGH(NCHN)=FACCIB
35253 ELSE
35254 SIGH(NCHN)=FACCIB
35255 ENDIF
35256 450 CONTINUE
35257
35258 ELSEIF(ISUB.EQ.383) THEN
35259C...f + fbar -> g + g (q + qbar -> g + g only)
35260 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
35261 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
35262 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
35263 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
35264 IF(ITCM(5).EQ.5) THEN
35265 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
35266 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
35267 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
35268 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
35269 ENDIF
35270 DO 460 I=MMINA,MMAXA
35271 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35272 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35273 NCHN=NCHN+1
35274 ISIG(NCHN,1)=I
35275 ISIG(NCHN,2)=-I
35276 ISIG(NCHN,3)=1
35277 SIGH(NCHN)=0.5D0*FACGG1
35278 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
35279 NCHN=NCHN+1
35280 ISIG(NCHN,1)=I
35281 ISIG(NCHN,2)=-I
35282 ISIG(NCHN,3)=2
35283 SIGH(NCHN)=0.5D0*FACGG2
35284 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
35285 460 CONTINUE
35286
35287 ELSEIF(ISUB.EQ.384) THEN
35288C...f + g -> f + g (q + g -> q + g only)
35289 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
35290 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
35291 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
35292 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
35293 DO 480 I=MMINA,MMAXA
35294 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
35295 DO 470 ISDE=1,2
35296 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
35297 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
35298 NCHN=NCHN+1
35299 ISIG(NCHN,ISDE)=I
35300 ISIG(NCHN,3-ISDE)=21
35301 ISIG(NCHN,3)=1
35302 SIGH(NCHN)=FACQG1
35303 NCHN=NCHN+1
35304 ISIG(NCHN,ISDE)=I
35305 ISIG(NCHN,3-ISDE)=21
35306 ISIG(NCHN,3)=2
35307 SIGH(NCHN)=FACQG2
35308 470 CONTINUE
35309 480 CONTINUE
35310
35311 ELSEIF(ISUB.EQ.385) THEN
35312C...g + g -> f + fbar (g + g -> q + qbar only)
35313 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
35314 IDC0=MDCY(21,2)-1
35315C...Begin by d, u, s flavours.
35316 FLAVWT=0D0
35317 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
35318 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
35319 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
35320 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
35321 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
35322 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
35323 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
35324 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
35325 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
35326 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
35327 NCHN=NCHN+1
35328 ISIG(NCHN,1)=21
35329 ISIG(NCHN,2)=21
35330 ISIG(NCHN,3)=1
35331 SIGH(NCHN)=FACQQ1
35332 NCHN=NCHN+1
35333 ISIG(NCHN,1)=21
35334 ISIG(NCHN,2)=21
35335 ISIG(NCHN,3)=2
35336 SIGH(NCHN)=FACQQ2
35337C...Next c and b flavours: modified that and uhat for fixed
35338C...cos(theta-hat).
35339 DO 490 IFL=4,5
35340 SQMAVG=PMAS(IFL,1)**2
35341 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
35342 BE34=SQRT(1D0-4D0*SQMAVG/SH)
35343 THQ=-0.5D0*SH*(1D0-BE34*CTH)
35344 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
35345 THUHQ=THQ*UHQ-SQMAVG*SH
35346 IF(MSTP(34).EQ.0) THEN
35347 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
35348 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
35349 ELSE
35350 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35351 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
35352 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35353 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
35354 ENDIF
35355 IF(ITCM(5).GE.5) THEN
35356 IF(IFL.EQ.4) THEN
35357 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
35358 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35359 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
35360 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35361 ELSE
35362 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
35363 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35364 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
35365 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35366 ENDIF
35367 ENDIF
35368 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
35369 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
35370 NCHN=NCHN+1
35371 ISIG(NCHN,1)=21
35372 ISIG(NCHN,2)=21
35373 ISIG(NCHN,3)=1+2*(IFL-3)
35374 SIGH(NCHN)=FACQQ1
35375 NCHN=NCHN+1
35376 ISIG(NCHN,1)=21
35377 ISIG(NCHN,2)=21
35378 ISIG(NCHN,3)=2+2*(IFL-3)
35379 SIGH(NCHN)=FACQQ2
35380 ENDIF
35381 490 CONTINUE
35382 500 CONTINUE
35383
35384 ELSEIF(ISUB.EQ.386) THEN
35385C...g + g -> g + g
35386 IF(ITCM(5).LE.4) THEN
35387 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
35388 & 2D0*TH/SH+TH2/SH2)*FACA
35389 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
35390 & 2D0*SH/UH+SH2/UH2)*FACA
35391 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
35392 & 2D0*UH/TH+UH2/TH2)
35393 ELSE
35394 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
35395 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
35396 & 4D0*REDGST*(SH + 2D0*TH)*
35397 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
35398 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
35399 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
35400 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
35401 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
35402 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
35403 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
35404 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
35405 & 4D0*REDGSU*(SH + 2D0*UH)*
35406 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
35407 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
35408 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
35409 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
35410 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
35411 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
35412 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
35413 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
35414 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
35415 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
35416 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
35417 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
35418 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
35419 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
35420 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
35421 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
35422 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
35423 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
35424 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
35425 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
35426 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
35427 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
35428 ENDIF
35429 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
35430 NCHN=NCHN+1
35431 ISIG(NCHN,1)=21
35432 ISIG(NCHN,2)=21
35433 ISIG(NCHN,3)=1
35434 SIGH(NCHN)=0.5D0*FACGG1
35435 NCHN=NCHN+1
35436 ISIG(NCHN,1)=21
35437 ISIG(NCHN,2)=21
35438 ISIG(NCHN,3)=2
35439 SIGH(NCHN)=0.5D0*FACGG2
35440 NCHN=NCHN+1
35441 ISIG(NCHN,1)=21
35442 ISIG(NCHN,2)=21
35443 ISIG(NCHN,3)=3
35444 SIGH(NCHN)=0.5D0*FACGG3
35445 510 CONTINUE
35446
35447 ELSEIF(ISUB.EQ.387) THEN
35448C...q + qbar -> Q + Qbar
35449 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
35450 THQ=-0.5D0*SH*(1D0-BE34*CTH)
35451 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
35452 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
35453 & 2D0*SQMAVG/SH)
35454 IF(ITCM(5).GE.5) THEN
35455 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
35456 FACQQB=FACQQB*SH2*SQDQTS
35457 ELSE
35458 FACQQB=FACQQB*SH2*SQDQQS
35459 ENDIF
35460 ENDIF
35461 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
35462 WID2=1D0
35463 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
35464 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
35465 FACQQB=FACQQB*WID2
35466 DO 520 I=MMINA,MMAXA
35467 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35468 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
35469 NCHN=NCHN+1
35470 ISIG(NCHN,1)=I
35471 ISIG(NCHN,2)=-I
35472 ISIG(NCHN,3)=1
35473 SIGH(NCHN)=FACQQB
35474 520 CONTINUE
35475
35476 ELSEIF(ISUB.EQ.388) THEN
35477C...g + g -> Q + Qbar
35478 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
35479 THQ=-0.5D0*SH*(1D0-BE34*CTH)
35480 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
35481 THUHQ=THQ*UHQ-SQMAVG*SH
35482 IF(MSTP(34).EQ.0) THEN
35483 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
35484 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
35485 ELSE
35486 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35487 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
35488 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
35489 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
35490 ENDIF
35491 IF(ITCM(5).GE.5) THEN
35492 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
35493 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
35494 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35495 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
35496 & 2.25D0*THQ*UHQ/SH2*SQDHGS
35497 ELSE
35498 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
35499 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35500 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
35501 & 2.25D0*THQ*UHQ/SH2*SQDLGS
35502 ENDIF
35503 ENDIF
35504 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
35505 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
35506 IF(MSTP(35).GE.1) THEN
35507 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
35508 FACQQ1=FACQQ1*FATRE
35509 FACQQ2=FACQQ2*FATRE
35510 ENDIF
35511 WID2=1D0
35512 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
35513 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
35514 FACQQ1=FACQQ1*WID2
35515 FACQQ2=FACQQ2*WID2
35516 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
35517 NCHN=NCHN+1
35518 ISIG(NCHN,1)=21
35519 ISIG(NCHN,2)=21
35520 ISIG(NCHN,3)=1
35521 SIGH(NCHN)=FACQQ1
35522 NCHN=NCHN+1
35523 ISIG(NCHN,1)=21
35524 ISIG(NCHN,2)=21
35525 ISIG(NCHN,3)=2
35526 SIGH(NCHN)=FACQQ2
35527 530 CONTINUE
35528 ENDIF
35529 ENDIF
35530
35531CMRENNA--
35532
35533 RETURN
35534 END
35535
35536C*********************************************************************
35537
35538C...PYSGEX
35539C...Subprocess cross sections for assorted exotic processes,
35540C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
35541C...Auxiliary to PYSIGH.
35542
35543 SUBROUTINE PYSGEX(NCHN,SIGS)
35544
35545C...Double precision and integer declarations
35546 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35547 IMPLICIT INTEGER(I-N)
35548 INTEGER PYK,PYCHGE,PYCOMP
35549C...Parameter statement to help give large particle numbers.
35550 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35551 &KEXCIT=4000000,KDIMEN=5000000)
35552C...Commonblocks
35553 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35554 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35555 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35556 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35557 COMMON/PYINT1/MINT(400),VINT(400)
35558 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35559 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35560 COMMON/PYINT4/MWID(500),WIDS(500,5)
35561 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35562 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35563 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35564 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35565 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35566 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35567 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35568C...Local arrays
35569 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35570
35571C...Differential cross section expressions.
35572
35573 IF(ISUB.LE.160) THEN
35574 IF(ISUB.EQ.141) THEN
35575C...f + fbar -> gamma*/Z0/Z'0
35576 SQMZP=PMAS(32,1)**2
35577 MINT(61)=2
35578 CALL PYWIDT(32,SH,WDTP,WDTE)
35579 HP0=AEM/3D0*SH
35580 HP1=AEM/3D0*XWC*SH
35581 HP2=HP1
35582 HS=SHR*VINT(117)
35583 HSP=SHR*WDTP(0)
35584 FACZP=4D0*COMFAC*3D0
35585 DO 100 I=MMINA,MMAXA
35586 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
35587 EI=KCHG(IABS(I),1)/3D0
35588 AI=SIGN(1D0,EI)
35589 VI=AI-4D0*EI*XWV
35590 IA=IABS(I)
35591 IF(IA.LT.10) THEN
35592 IF(IA.LE.2) THEN
35593 VPI=PARU(123-2*MOD(IABS(I),2))
35594 API=PARU(124-2*MOD(IABS(I),2))
35595 ELSEIF(IA.LE.4) THEN
35596 VPI=PARJ(182-2*MOD(IABS(I),2))
35597 API=PARJ(183-2*MOD(IABS(I),2))
35598 ELSE
35599 VPI=PARJ(190-2*MOD(IABS(I),2))
35600 API=PARJ(191-2*MOD(IABS(I),2))
35601 ENDIF
35602 ELSE
35603 IF(IA.LE.12) THEN
35604 VPI=PARU(127-2*MOD(IABS(I),2))
35605 API=PARU(128-2*MOD(IABS(I),2))
35606 ELSEIF(IA.LE.14) THEN
35607 VPI=PARJ(186-2*MOD(IABS(I),2))
35608 API=PARJ(187-2*MOD(IABS(I),2))
35609 ELSE
35610 VPI=PARJ(194-2*MOD(IABS(I),2))
35611 API=PARJ(195-2*MOD(IABS(I),2))
35612 ENDIF
35613 ENDIF
35614 HI0=HP0
35615 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
35616 HI1=HP1
35617 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
35618 HI2=HP2
35619 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
35620 NCHN=NCHN+1
35621 ISIG(NCHN,1)=I
35622 ISIG(NCHN,2)=-I
35623 ISIG(NCHN,3)=1
35624 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
35625 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
35626 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
35627 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
35628 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
35629 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
35630 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
35631 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
35632 100 CONTINUE
35633
35634 ELSEIF(ISUB.EQ.142) THEN
35635C...f + fbar' -> W'+/-
35636 SQMWP=PMAS(34,1)**2
35637 CALL PYWIDT(34,SH,WDTP,WDTE)
35638 HS=SHR*WDTP(0)
35639 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
35640 HP=AEM/(24D0*XW)*SH
35641 DO 120 I=MMIN1,MMAX1
35642 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
35643 IA=IABS(I)
35644 DO 110 J=MMIN2,MMAX2
35645 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
35646 JA=IABS(J)
35647 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
35648 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35649 & GOTO 110
35650 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35651 HI=HP*(PARU(133)**2+PARU(134)**2)
35652 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
35653 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35654 NCHN=NCHN+1
35655 ISIG(NCHN,1)=I
35656 ISIG(NCHN,2)=J
35657 ISIG(NCHN,3)=1
35658 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
35659 SIGH(NCHN)=HI*FACBW*HF
35660 110 CONTINUE
35661 120 CONTINUE
35662
35663 ELSEIF(ISUB.EQ.144) THEN
35664C...f + fbar' -> R
35665 SQMR=PMAS(41,1)**2
35666 CALL PYWIDT(41,SH,WDTP,WDTE)
35667 HS=SHR*WDTP(0)
35668 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
35669 HP=AEM/(12D0*XW)*SH
35670 DO 140 I=MMIN1,MMAX1
35671 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
35672 IA=IABS(I)
35673 DO 130 J=MMIN2,MMAX2
35674 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
35675 JA=IABS(J)
35676 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
35677 HI=HP
35678 IF(IA.LE.10) HI=HI*FACA/3D0
35679 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
35680 NCHN=NCHN+1
35681 ISIG(NCHN,1)=I
35682 ISIG(NCHN,2)=J
35683 ISIG(NCHN,3)=1
35684 SIGH(NCHN)=HI*FACBW*HF
35685 130 CONTINUE
35686 140 CONTINUE
35687
35688 ELSEIF(ISUB.EQ.145) THEN
35689C...q + l -> LQ (leptoquark)
35690 SQMLQ=PMAS(42,1)**2
35691 CALL PYWIDT(42,SH,WDTP,WDTE)
35692 HS=SHR*WDTP(0)
35693 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
35694 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
35695 HP=AEM/4D0*SH
35696 KFLQQ=KFDP(MDCY(42,2),1)
35697 KFLQL=KFDP(MDCY(42,2),2)
35698 DO 160 I=MMIN1,MMAX1
35699 IF(KFAC(1,I).EQ.0) GOTO 160
35700 IA=IABS(I)
35701 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
35702 DO 150 J=MMIN2,MMAX2
35703 IF(KFAC(2,J).EQ.0) GOTO 150
35704 JA=IABS(J)
35705 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
35706 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
35707 IF(JA.EQ.IA) GOTO 150
35708 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
35709 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
35710 HI=HP*PARU(151)
35711 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
35712 NCHN=NCHN+1
35713 ISIG(NCHN,1)=I
35714 ISIG(NCHN,2)=J
35715 ISIG(NCHN,3)=1
35716 SIGH(NCHN)=HI*FACBW*HF
35717 150 CONTINUE
35718 160 CONTINUE
35719
35720 ELSEIF(ISUB.EQ.146) THEN
35721C...e + gamma* -> e* (excited lepton)
35722 KFQSTR=KFPR(ISUB,1)
35723 KCQSTR=PYCOMP(KFQSTR)
35724 KFQEXC=MOD(KFQSTR,KEXCIT)
35725 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
35726 HS=SHR*WDTP(0)
35727 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
35728 QF=-RTCM(43)/2D0-RTCM(44)/2D0
35729 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
35730 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
35731 & FACBW=0D0
35732 HP=SH
35733 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
35734 DO 170 ISDE=1,2
35735 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
35736 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
35737 HI=HP
35738 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35739 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
35740 NCHN=NCHN+1
35741 ISIG(NCHN,ISDE)=I
35742 ISIG(NCHN,3-ISDE)=22
35743 ISIG(NCHN,3)=1
35744 SIGH(NCHN)=HI*FACBW*HF
35745 170 CONTINUE
35746 180 CONTINUE
35747
35748 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
35749C...d + g -> d* and u + g -> u* (excited quarks)
35750 KFQSTR=KFPR(ISUB,1)
35751 KCQSTR=PYCOMP(KFQSTR)
35752 KFQEXC=MOD(KFQSTR,KEXCIT)
35753 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
35754 HS=SHR*WDTP(0)
35755 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
35756 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
35757 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
35758 & FACBW=0D0
35759 HP=SH
35760 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
35761 DO 190 ISDE=1,2
35762 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
35763 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
35764 HI=HP
35765 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35766 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
35767 NCHN=NCHN+1
35768 ISIG(NCHN,ISDE)=I
35769 ISIG(NCHN,3-ISDE)=21
35770 ISIG(NCHN,3)=1
35771 SIGH(NCHN)=HI*FACBW*HF
35772 190 CONTINUE
35773 200 CONTINUE
35774 ENDIF
35775
35776 ELSEIF(ISUB.LE.190) THEN
35777 IF(ISUB.EQ.162) THEN
35778C...q + g -> LQ + lbar; LQ=leptoquark
35779 SQMLQ=PMAS(42,1)**2
35780 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
35781 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
35782 KFLQQ=KFDP(MDCY(42,2),1)
35783 DO 220 I=MMINA,MMAXA
35784 IF(IABS(I).NE.KFLQQ) GOTO 220
35785 KCHLQ=ISIGN(1,I)
35786 DO 210 ISDE=1,2
35787 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
35788 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
35789 NCHN=NCHN+1
35790 ISIG(NCHN,ISDE)=I
35791 ISIG(NCHN,3-ISDE)=21
35792 ISIG(NCHN,3)=1
35793 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
35794 210 CONTINUE
35795 220 CONTINUE
35796
35797 ELSEIF(ISUB.EQ.163) THEN
35798C...g + g -> LQ + LQbar; LQ=leptoquark
35799 SQMLQ=PMAS(42,1)**2
35800 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
35801 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
35802 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
35803 & ((TH-SQMLQ)*(UH-SQMLQ)))
35804 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
35805 NCHN=NCHN+1
35806 ISIG(NCHN,1)=21
35807 ISIG(NCHN,2)=21
35808C...Since don't know proper colour flow, randomize between alternatives
35809 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
35810 SIGH(NCHN)=FACLQ
35811 230 CONTINUE
35812
35813 ELSEIF(ISUB.EQ.164) THEN
35814C...q + qbar -> LQ + LQbar; LQ=leptoquark
35815 DELTA=0.25D0*(SQM3-SQM4)**2/SH
35816 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
35817 TH=TH-DELTA
35818 UH=UH-DELTA
35819C SQMLQ=PMAS(42,1)**2
35820 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
35821 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
35822 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
35823 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
35824 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
35825 KFLQQ=KFDP(MDCY(42,2),1)
35826 DO 240 I=MMINA,MMAXA
35827 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35828 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
35829 NCHN=NCHN+1
35830 ISIG(NCHN,1)=I
35831 ISIG(NCHN,2)=-I
35832 ISIG(NCHN,3)=1
35833 SIGH(NCHN)=FACLQA
35834 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
35835 240 CONTINUE
35836
35837 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
35838C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
35839 KFQSTR=KFPR(ISUB,2)
35840 KCQSTR=PYCOMP(KFQSTR)
35841 KFQEXC=MOD(KFQSTR,KEXCIT)
35842 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
35843 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
35844 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
35845C...Propagators: as simulated in PYOFSH and as desired
35846 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
35847 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
35848 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
35849 GMMQC=SQRT(SQM4)*WDTP(0)
35850 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
35851 FACQSA=FACQSA*HBW4C/HBW4
35852 FACQSB=FACQSB*HBW4C/HBW4
35853C...Branching ratios.
35854 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
35855 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
35856 DO 260 I=MMIN1,MMAX1
35857 IA=IABS(I)
35858 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
35859 DO 250 J=MMIN2,MMAX2
35860 JA=IABS(J)
35861 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
35862 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
35863 NCHN=NCHN+1
35864 ISIG(NCHN,1)=I
35865 ISIG(NCHN,2)=J
35866 ISIG(NCHN,3)=1
35867 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
35868 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
35869 NCHN=NCHN+1
35870 ISIG(NCHN,1)=I
35871 ISIG(NCHN,2)=J
35872 ISIG(NCHN,3)=2
35873 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
35874 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
35875 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
35876 NCHN=NCHN+1
35877 ISIG(NCHN,1)=I
35878 ISIG(NCHN,2)=J
35879 ISIG(NCHN,3)=1
35880 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
35881 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
35882 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
35883 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
35884 NCHN=NCHN+1
35885 ISIG(NCHN,1)=I
35886 ISIG(NCHN,2)=J
35887 ISIG(NCHN,3)=1
35888 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
35889 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
35890 NCHN=NCHN+1
35891 ISIG(NCHN,1)=I
35892 ISIG(NCHN,2)=J
35893 ISIG(NCHN,3)=2
35894 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
35895 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
35896 ELSEIF(I.EQ.-J) THEN
35897 NCHN=NCHN+1
35898 ISIG(NCHN,1)=I
35899 ISIG(NCHN,2)=J
35900 ISIG(NCHN,3)=1
35901 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35902 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35903 NCHN=NCHN+1
35904 ISIG(NCHN,1)=I
35905 ISIG(NCHN,2)=J
35906 ISIG(NCHN,3)=2
35907 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35908 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35909 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
35910 NCHN=NCHN+1
35911 ISIG(NCHN,1)=I
35912 ISIG(NCHN,2)=J
35913 ISIG(NCHN,3)=1
35914 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
35915 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
35916 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
35917 ENDIF
35918 250 CONTINUE
35919 260 CONTINUE
35920
35921 ELSEIF(ISUB.EQ.169) THEN
35922C...q + qbar -> e + e* (excited lepton)
35923 KFQSTR=KFPR(ISUB,2)
35924 KCQSTR=PYCOMP(KFQSTR)
35925 KFQEXC=MOD(KFQSTR,KEXCIT)
35926 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
35927 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
35928C...Propagators: as simulated in PYOFSH and as desired
35929 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
35930 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
35931 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
35932 GMMQC=SQRT(SQM4)*WDTP(0)
35933 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
35934 FACQSB=FACQSB*HBW4C/HBW4
35935C...Branching ratios.
35936 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
35937 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
35938 DO 270 I=MMIN1,MMAX1
35939 IA=IABS(I)
35940 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
35941 J=-I
35942 JA=IABS(J)
35943 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
35944 NCHN=NCHN+1
35945 ISIG(NCHN,1)=I
35946 ISIG(NCHN,2)=J
35947 ISIG(NCHN,3)=1
35948 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35949 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35950 NCHN=NCHN+1
35951 ISIG(NCHN,1)=I
35952 ISIG(NCHN,2)=J
35953 ISIG(NCHN,3)=2
35954 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
35955 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
35956 270 CONTINUE
35957 ENDIF
35958
35959 ELSEIF(ISUB.LE.360) THEN
35960 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
35961C...l + l -> H_L++/-- or H_R++/--.
35962 KFRES=KFPR(ISUB,1)
35963 KFREC=PYCOMP(KFRES)
35964 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
35965 HS=SHR*WDTP(0)
35966 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
35967 DO 290 I=MMIN1,MMAX1
35968 IA=IABS(I)
35969 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
35970 & GOTO 290
35971 DO 280 J=MMIN2,MMAX2
35972 JA=IABS(J)
35973 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
35974 & GOTO 280
35975 IF(I*J.LT.0) GOTO 280
35976 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35977 NCHN=NCHN+1
35978 ISIG(NCHN,1)=I
35979 ISIG(NCHN,2)=J
35980 ISIG(NCHN,3)=1
35981 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
35982 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
35983 SIGH(NCHN)=HI*FACBW*HF
35984 280 CONTINUE
35985 290 CONTINUE
35986
35987 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
35988C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
35989 KFRES=KFPR(ISUB,1)
35990 KFREC=PYCOMP(KFRES)
35991C...Propagators: as simulated in PYOFSH and as desired
35992 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
35993 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
35994 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
35995 GMMC=SQRT(SQM3)*WDTP(0)
35996 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
35997 FHCC=COMFAC*AEM*HBW3C/HBW3
35998 DO 310 I=MMINA,MMAXA
35999 IA=IABS(I)
36000 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36001 SQML=PMAS(IA,1)**2
36002 J=ISIGN(KFPR(ISUB,2),-I)
36003 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36004 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36005 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36006 & (UH-SQM3)**2
36007 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36008 & (TH-SQM4)*SH)/(TH-SQM4)**2
36009 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36010 & SH)/(SH-SQML)**2
36011 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36012 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36013 & ((UH-SQM3)*(TH-SQM4))
36014 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36015 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36016 & ((UH-SQM3)*(SH-SQML))
36017 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36018 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36019 & ((SH-SQML)*(TH-SQM4))
36020 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36021 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36022 DO 300 ISDE=1,2
36023 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36024 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36025 NCHN=NCHN+1
36026 ISIG(NCHN,ISDE)=I
36027 ISIG(NCHN,3-ISDE)=22
36028 ISIG(NCHN,3)=0
36029 SIGH(NCHN)=FHCC*SMM*WIDSC
36030 300 CONTINUE
36031 310 CONTINUE
36032
36033 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36034C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36035 KFRES=KFPR(ISUB,1)
36036 KFREC=PYCOMP(KFRES)
36037 SQMH=PMAS(KFREC,1)**2
36038 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36039C...Propagators: H++/-- as simulated in PYOFSH and as desired
36040 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36041 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36042 GMMH3=SQRT(SQM3)*WDTP(0)
36043 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36044 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36045 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36046 GMMH4=SQRT(SQM4)*WDTP(0)
36047 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36048C...Kinematical and coupling functions
36049 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36050 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36051C...Loop over allowed flavours
36052 DO 320 I=MMINA,MMAXA
36053 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36054 EI=KCHG(IABS(I),1)/3D0
36055 AI=SIGN(1D0,EI+0.1D0)
36056 VI=AI-4D0*EI*XWV
36057 FCOI=1D0
36058 IF(IABS(I).LE.10) FCOI=FACA/3D0
36059 IF(ISUB.EQ.349) THEN
36060 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36061 IF(IABS(I).LT.10) THEN
36062 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36063 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36064 & (VI**2+AI**2)*XWHH**2*HBWZ)
36065 ELSE
36066 IAOFF=181+3*((IABS(I)-11)/2)
36067 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36068 & (4D0*PARU(1))
36069 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36070 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36071 & (VI**2+AI**2)*XWHH**2*HBWZ)+
36072 & 8D0*AEM*(EI*HSUM/(SH*TH)+
36073 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
36074 & 4D0*HSUM**2/TH2
36075 ENDIF
36076 ELSE
36077 IF(IABS(I).LT.10) THEN
36078 DSIGHH=8D0*AEM**2*EI**2/SH2
36079 ELSE
36080 IAOFF=181+3*((IABS(I)-11)/2)
36081 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36082 & (4D0*PARU(1))
36083 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
36084 & 4D0*HSUM**2/TH2
36085 ENDIF
36086 ENDIF
36087 NCHN=NCHN+1
36088 ISIG(NCHN,1)=I
36089 ISIG(NCHN,2)=-I
36090 ISIG(NCHN,3)=1
36091 SIGH(NCHN)=FACHH*FCOI*DSIGHH
36092 320 CONTINUE
36093
36094 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
36095C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
36096 KFRES=KFPR(ISUB,1)
36097 KFREC=PYCOMP(KFRES)
36098 SQMH=PMAS(KFREC,1)**2
36099 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
36100 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
36101 & PMAS(PYCOMP(9900024),1)**2
36102 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
36103 FACPRT=1D0/((VINT(204)**2-VINT(215))*
36104 & (VINT(209)**2-VINT(216)))
36105 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
36106 & (VINT(209)**2+2D0*VINT(218)))
36107 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36108 HS=SHR*WDTP(0)
36109 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
36110 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
36111 & FACBW=0D0
36112 DO 340 I=MMIN1,MMAX1
36113 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
36114 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
36115 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
36116 DO 330 J=MMIN2,MMAX2
36117 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
36118 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
36119 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
36120 KCHH=KCHWI+KCHWJ
36121 IF(IABS(KCHH).NE.2) GOTO 330
36122 FACLR=VINT(180+I)*VINT(180+J)
36123 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36124 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
36125 FACPRP=0.5D0*(FACPRT+FACPRU)**2
36126 ELSE
36127 FACPRP=FACPRT**2
36128 ENDIF
36129 NCHN=NCHN+1
36130 ISIG(NCHN,1)=I
36131 ISIG(NCHN,2)=J
36132 ISIG(NCHN,3)=1
36133 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
36134 330 CONTINUE
36135 340 CONTINUE
36136
36137 ELSEIF(ISUB.EQ.353) THEN
36138C...f + fbar -> Z_R0
36139 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
36140 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
36141 HS=SHR*WDTP(0)
36142 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
36143 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36144 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
36145 DO 350 I=MMINA,MMAXA
36146 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
36147 IF(IABS(I).LE.8) THEN
36148 EI=KCHG(IABS(I),1)/3D0
36149 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
36150 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
36151 ELSE
36152 AI=-(1D0-2D0*XW)
36153 VI=-1D0+4D0*XW
36154 ENDIF
36155 HI=HP*(VI**2+AI**2)
36156 IF(IABS(I).LE.10) HI=HI*FACA/3D0
36157 NCHN=NCHN+1
36158 ISIG(NCHN,1)=I
36159 ISIG(NCHN,2)=-I
36160 ISIG(NCHN,3)=1
36161 SIGH(NCHN)=HI*FACBW*HF
36162 350 CONTINUE
36163
36164 ELSEIF(ISUB.EQ.354) THEN
36165C...f + fbar' -> W_R+/-
36166 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
36167 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
36168 HS=SHR*WDTP(0)
36169 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
36170 HP=AEM/(24D0*XW)*SH
36171 DO 370 I=MMIN1,MMAX1
36172 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
36173 IA=IABS(I)
36174 DO 360 J=MMIN2,MMAX2
36175 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
36176 JA=IABS(J)
36177 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
36178 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36179 & GOTO 360
36180 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36181 HI=HP*2D0
36182 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36183 NCHN=NCHN+1
36184 ISIG(NCHN,1)=I
36185 ISIG(NCHN,2)=J
36186 ISIG(NCHN,3)=1
36187 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36188 SIGH(NCHN)=HI*FACBW*HF
36189 360 CONTINUE
36190 370 CONTINUE
36191 ENDIF
36192
36193 ELSEIF(ISUB.LE.400) THEN
36194 IF(ISUB.EQ.391) THEN
36195C...f + fbar -> G*.
36196 KFGSTR=KFPR(ISUB,1)
36197 KCGSTR=PYCOMP(KFGSTR)
36198 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
36199 HS=SHR*WDTP(0)
36200 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36201 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
36202 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
36203C...Modify cross section in wings of peak.
36204 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
36205 DO 380 I=MMINA,MMAXA
36206 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
36207 HI=1D0
36208 IF(IABS(I).LE.10) HI=HI*FACA/3D0
36209 NCHN=NCHN+1
36210 ISIG(NCHN,1)=I
36211 ISIG(NCHN,2)=-I
36212 ISIG(NCHN,3)=1
36213 SIGH(NCHN)=FACG*HI
36214 380 CONTINUE
36215
36216 ELSEIF(ISUB.EQ.392) THEN
36217C...g + g -> G*.
36218 KFGSTR=KFPR(ISUB,1)
36219 KCGSTR=PYCOMP(KFGSTR)
36220 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
36221 HS=SHR*WDTP(0)
36222 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36223 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
36224 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
36225C...Modify cross section in wings of peak.
36226 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
36227 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
36228 NCHN=NCHN+1
36229 ISIG(NCHN,1)=21
36230 ISIG(NCHN,2)=21
36231 ISIG(NCHN,3)=1
36232 SIGH(NCHN)=FACG
36233 390 CONTINUE
36234
36235 ELSEIF(ISUB.EQ.393) THEN
36236C...q + qbar -> g + G*.
36237 KFGSTR=KFPR(ISUB,2)
36238 KCGSTR=PYCOMP(KFGSTR)
36239 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
36240 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
36241 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
36242 & 2D0*SH2/(TH*UH))
36243C...Propagators: as simulated in PYOFSH and as desired
36244 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
36245 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
36246 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
36247 HS=SQRT(SQM4)*WDTP(0)
36248 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36249 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
36250 FACG=FACG*HBW4C/HBW4
36251 DO 400 I=MMINA,MMAXA
36252 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36253 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
36254 NCHN=NCHN+1
36255 ISIG(NCHN,1)=I
36256 ISIG(NCHN,2)=-I
36257 ISIG(NCHN,3)=1
36258 SIGH(NCHN)=FACG
36259 400 CONTINUE
36260
36261 ELSEIF(ISUB.EQ.394) THEN
36262C...q + g -> q + G*.
36263 KFGSTR=KFPR(ISUB,2)
36264 KCGSTR=PYCOMP(KFGSTR)
36265 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
36266 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
36267 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
36268 & 2D0*TH2*TH/(UH*SH2))
36269C...Propagators: as simulated in PYOFSH and as desired
36270 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
36271 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
36272 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
36273 HS=SQRT(SQM4)*WDTP(0)
36274 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36275 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
36276 FACG=FACG*HBW4C/HBW4
36277 DO 420 I=MMINA,MMAXA
36278 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
36279 DO 410 ISDE=1,2
36280 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
36281 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
36282 NCHN=NCHN+1
36283 ISIG(NCHN,ISDE)=I
36284 ISIG(NCHN,3-ISDE)=21
36285 ISIG(NCHN,3)=1
36286 SIGH(NCHN)=FACG
36287 410 CONTINUE
36288 420 CONTINUE
36289
36290 ELSEIF(ISUB.EQ.395) THEN
36291C...g + g -> g + G*.
36292 KFGSTR=KFPR(ISUB,2)
36293 KCGSTR=PYCOMP(KFGSTR)
36294 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
36295 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
36296 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
36297C...Propagators: as simulated in PYOFSH and as desired
36298 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
36299 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
36300 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
36301 HS=SQRT(SQM4)*WDTP(0)
36302 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36303 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
36304 FACG=FACG*HBW4C/HBW4
36305 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
36306 NCHN=NCHN+1
36307 ISIG(NCHN,1)=21
36308 ISIG(NCHN,2)=21
36309 ISIG(NCHN,3)=1
36310 SIGH(NCHN)=FACG
36311 ENDIF
36312 ENDIF
36313 ENDIF
36314
36315 RETURN
36316 END
36317
36318C*********************************************************************
36319
36320C...PYPDFU
36321C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
36322C...parton distributions according to a few different parametrizations.
36323C...Note that what is coded is x times the probability distribution,
36324C...i.e. xq(x,Q2) etc.
36325
36326 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
36327
36328C...Double precision and integer declarations.
36329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36330 IMPLICIT INTEGER(I-N)
36331 INTEGER PYK,PYCHGE,PYCOMP
36332C...Commonblocks.
36333 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
36334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36336 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36337 COMMON/PYINT1/MINT(400),VINT(400)
36338 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
36339 &XPDIR(-6:6)
36340 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
36341 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
36342 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
36343 & XMI(2,240),PT2MI(240),IMISEP(0:240)
36344 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
36345 &/PYINT9/,/PYINTM/
36346C...Local arrays.
36347 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
36348 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
36349 SAVE PPAR
36350
36351C...Interface to PDFLIB.
36352 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
36353 SAVE /W50513/
36354 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
36355 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
36356 CHARACTER*20 PARM(20)
36357 DATA VALUE/20*0D0/,PARM/20*' '/
36358
36359C...Data related to Schuler-Sjostrand photon distributions.
36360 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
36361
36362C...Valence PDF momentum integral parametrizations PER PARTON!
36363 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
36364 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
36365 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
36366 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
36367
36368C...Reset parton distributions.
36369 MINT(92)=0
36370 DO 100 KFL=-25,25
36371 XPQ(KFL)=0D0
36372 100 CONTINUE
36373 DO 110 KFL=-6,6
36374 XPVAL(KFL)=0D0
36375 110 CONTINUE
36376
36377C...Check x and particle species.
36378 IF(X.LE.0D0.OR.X.GE.1D0) THEN
36379 WRITE(MSTU(11),5000) X
36380 GOTO 9999
36381 ENDIF
36382 KFA=IABS(KF)
36383 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
36384 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
36385 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
36386 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
36387 &KFA.NE.310.AND.KFA.NE.130) THEN
36388 WRITE(MSTU(11),5100) KF
36389 GOTO 9999
36390 ENDIF
36391
36392C...Electron (or muon or tau) parton distribution call.
36393 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
36394 CALL PYPDEL(KFA,X,Q2,XPEL)
36395 DO 120 KFL=-25,25
36396 XPQ(KFL)=XPEL(KFL)
36397 120 CONTINUE
36398
36399C...Photon parton distribution call (VDM+anomalous).
36400 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
36401 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
36402 CALL PYPDGA(X,Q2,XPGA)
36403 DO 130 KFL=-6,6
36404 XPQ(KFL)=XPGA(KFL)
36405 130 CONTINUE
36406 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
36407 XPVAL(1)=XPVU/4D0
36408 XPVAL(2)=XPVU
36409 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
36410 XPVAL(4)=MIN(XPQ(4),XPVU)
36411 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
36412 XPVAL(-1)=XPVAL(1)
36413 XPVAL(-2)=XPVAL(2)
36414 XPVAL(-3)=XPVAL(3)
36415 XPVAL(-4)=XPVAL(4)
36416 XPVAL(-5)=XPVAL(5)
36417 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
36418 Q2MX=Q2
36419 P2MX=0.36D0
36420 IF(MSTP(55).GE.7) P2MX=4.0D0
36421 IF(MSTP(57).EQ.0) Q2MX=P2MX
36422 P2=0D0
36423 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36424 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
36425 DO 140 KFL=-6,6
36426 XPQ(KFL)=XPGA(KFL)
36427 XPVAL(KFL)=VXPDGM(KFL)
36428 140 CONTINUE
36429 VINT(231)=P2MX
36430 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
36431 Q2MX=Q2
36432 P2MX=0.36D0
36433 IF(MSTP(55).GE.11) P2MX=4.0D0
36434 IF(MSTP(57).EQ.0) Q2MX=P2MX
36435 P2=0D0
36436 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36437 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
36438 DO 150 KFL=-6,6
36439 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
36440 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
36441 150 CONTINUE
36442 VINT(231)=P2MX
36443 ELSEIF(MSTP(56).EQ.2) THEN
36444C...Call PDFLIB parton distributions.
36445 PARM(1)='NPTYPE'
36446 VALUE(1)=3
36447 PARM(2)='NGROUP'
36448 VALUE(2)=MSTP(55)/1000
36449 PARM(3)='NSET'
36450 VALUE(3)=MOD(MSTP(55),1000)
36451 IF(MINT(93).NE.3000000+MSTP(55)) THEN
36452 CALL PDFSET(PARM,VALUE)
36453 MINT(93)=3000000+MSTP(55)
36454 ENDIF
36455 XX=X
36456 QQ2=MAX(0D0,Q2MIN,Q2)
36457 IF(MSTP(57).EQ.0) QQ2=Q2MIN
36458 P2=0D0
36459 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36460 IP2=MSTP(60)
36461 IF(MSTP(55).EQ.5004) THEN
36462 IF(5D0*P2.LT.QQ2.AND.
36463 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
36464 & P2.GE.0D0.AND.P2.LT.10D0.AND.
36465 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
36466 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
36467 & BOT,TOP,GLU)
36468 ELSE
36469 UPV=0D0
36470 DNV=0D0
36471 USEA=0D0
36472 DSEA=0D0
36473 STR=0D0
36474 CHM=0D0
36475 BOT=0D0
36476 TOP=0D0
36477 GLU=0D0
36478 ENDIF
36479 ELSE
36480 IF(P2.LT.QQ2) THEN
36481 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
36482 & BOT,TOP,GLU)
36483 ELSE
36484 UPV=0D0
36485 DNV=0D0
36486 USEA=0D0
36487 DSEA=0D0
36488 STR=0D0
36489 CHM=0D0
36490 BOT=0D0
36491 TOP=0D0
36492 GLU=0D0
36493 ENDIF
36494 ENDIF
36495 VINT(231)=Q2MIN
36496 XPQ(0)=GLU
36497 XPQ(1)=DNV
36498 XPQ(-1)=DNV
36499 XPQ(2)=UPV
36500 XPQ(-2)=UPV
36501 XPQ(3)=STR
36502 XPQ(-3)=STR
36503 XPQ(4)=CHM
36504 XPQ(-4)=CHM
36505 XPQ(5)=BOT
36506 XPQ(-5)=BOT
36507 XPQ(6)=TOP
36508 XPQ(-6)=TOP
36509 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
36510 XPVAL(1)=XPVU/4D0
36511 XPVAL(2)=XPVU
36512 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
36513 XPVAL(4)=MIN(XPQ(4),XPVU)
36514 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
36515 XPVAL(-1)=XPVAL(1)
36516 XPVAL(-2)=XPVAL(2)
36517 XPVAL(-3)=XPVAL(3)
36518 XPVAL(-4)=XPVAL(4)
36519 XPVAL(-5)=XPVAL(5)
36520 ELSE
36521 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
36522 ENDIF
36523
36524C...Pion/gammaVDM parton distribution call.
36525 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
36526 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
36527 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
36528 & MSTP(55).LE.12) THEN
36529 ISET=1+MOD(MSTP(55)-1,4)
36530 Q2MX=Q2
36531 P2MX=0.36D0
36532 IF(ISET.GE.3) P2MX=4.0D0
36533 IF(MSTP(57).EQ.0) Q2MX=P2MX
36534 P2=0D0
36535 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36536 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
36537 DO 160 KFL=-6,6
36538 XPQ(KFL)=XPVMD(KFL)
36539 XPVAL(KFL)=VXPVMD(KFL)
36540 160 CONTINUE
36541 VINT(231)=P2MX
36542 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
36543 CALL PYPDPI(X,Q2,XPPI)
36544 DO 170 KFL=-6,6
36545 XPQ(KFL)=XPPI(KFL)
36546 170 CONTINUE
36547 XPVAL(2)=XPQ(2)-XPQ(-2)
36548 XPVAL(-1)=XPQ(-1)-XPQ(1)
36549 ELSEIF(MSTP(54).EQ.2) THEN
36550C...Call PDFLIB parton distributions.
36551 PARM(1)='NPTYPE'
36552 VALUE(1)=2
36553 PARM(2)='NGROUP'
36554 VALUE(2)=MSTP(53)/1000
36555 PARM(3)='NSET'
36556 VALUE(3)=MOD(MSTP(53),1000)
36557 IF(MINT(93).NE.2000000+MSTP(53)) THEN
36558 CALL PDFSET(PARM,VALUE)
36559 MINT(93)=2000000+MSTP(53)
36560 ENDIF
36561 XX=X
36562 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
36563 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
36564 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
36565 VINT(231)=Q2MIN
36566 XPQ(0)=GLU
36567 XPQ(1)=DSEA
36568 XPQ(-1)=UPV+DSEA
36569 XPQ(2)=UPV+USEA
36570 XPQ(-2)=USEA
36571 XPQ(3)=STR
36572 XPQ(-3)=STR
36573 XPQ(4)=CHM
36574 XPQ(-4)=CHM
36575 XPQ(5)=BOT
36576 XPQ(-5)=BOT
36577 XPQ(6)=TOP
36578 XPQ(-6)=TOP
36579 XPVAL(2)=UPV
36580 XPVAL(-1)=UPV
36581 ELSE
36582 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
36583 ENDIF
36584
36585C...Anomalous photon parton distribution call.
36586 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
36587 Q2MX=Q2
36588 P2MX=PARP(15)**2
36589 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
36590 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
36591 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
36592 IF(MSTP(57).EQ.0) Q2MX=P2MX
36593 P2=0D0
36594 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36595 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
36596 DO 180 KFL=-6,6
36597 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
36598 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
36599 180 CONTINUE
36600 VINT(231)=P2MX
36601 ELSEIF(MSTP(56).EQ.1) THEN
36602 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
36603 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
36604 IF(MSTP(57).EQ.0) Q2MX=P2MX
36605 P2=0D0
36606 IF(VINT(120).LT.0D0) P2=VINT(120)**2
36607 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
36608 DO 190 KFL=-6,6
36609 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
36610 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
36611 190 CONTINUE
36612 VINT(231)=P2MX
36613 ELSEIF(MSTP(56).EQ.2) THEN
36614 IF(MSTP(57).EQ.0) Q2MX=P2MX
36615 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
36616 DO 200 KFL=-6,6
36617 XPQ(KFL)=XPGA(KFL)
36618 XPVAL(KFL)=VXPGA(KFL)
36619 200 CONTINUE
36620 VINT(231)=P2MX
36621 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
36622 IF(MSTP(57).EQ.0) Q2MX=P2MX
36623 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
36624 DO 210 KFL=-6,6
36625 XPQ(KFL)=XPGA(KFL)
36626 XPVAL(KFL)=VXPGA(KFL)
36627 210 CONTINUE
36628 VINT(231)=P2MX
36629 ELSE
36630 220 RKF=11D0*PYR(0)
36631 KFR=1
36632 IF(RKF.GT.1D0) KFR=2
36633 IF(RKF.GT.5D0) KFR=3
36634 IF(RKF.GT.6D0) KFR=4
36635 IF(RKF.GT.10D0) KFR=5
36636 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
36637 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
36638 IF(MSTP(57).EQ.0) Q2MX=P2MX
36639 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
36640 DO 230 KFL=-6,6
36641 XPQ(KFL)=XPGA(KFL)
36642 XPVAL(KFL)=VXPGA(KFL)
36643 230 CONTINUE
36644 VINT(231)=P2MX
36645 ENDIF
36646
36647C...Proton parton distribution call.
36648 ELSE
36649 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
36650 CALL PYPDPR(X,Q2,XPPR)
36651 DO 240 KFL=-6,6
36652 XPQ(KFL)=XPPR(KFL)
36653 240 CONTINUE
36654 XPVAL(1)=XPQ(1)-XPQ(-1)
36655 XPVAL(2)=XPQ(2)-XPQ(-2)
36656 ELSEIF(MSTP(52).EQ.2) THEN
36657C...Call PDFLIB parton distributions.
36658 PARM(1)='NPTYPE'
36659 VALUE(1)=1
36660 PARM(2)='NGROUP'
36661 VALUE(2)=MSTP(51)/1000
36662 PARM(3)='NSET'
36663 VALUE(3)=MOD(MSTP(51),1000)
36664 IF(MINT(93).NE.1000000+MSTP(51)) THEN
36665 CALL PDFSET(PARM,VALUE)
36666 MINT(93)=1000000+MSTP(51)
36667 ENDIF
36668 XX=X
36669 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
36670 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
36671 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
36672 VINT(231)=Q2MIN
36673 XPQ(0)=GLU
36674 XPQ(1)=DNV+DSEA
36675 XPQ(-1)=DSEA
36676 XPQ(2)=UPV+USEA
36677 XPQ(-2)=USEA
36678 XPQ(3)=STR
36679 XPQ(-3)=STR
36680 XPQ(4)=CHM
36681 XPQ(-4)=CHM
36682 XPQ(5)=BOT
36683 XPQ(-5)=BOT
36684 XPQ(6)=TOP
36685 XPQ(-6)=TOP
36686 XPVAL(1)=DNV
36687 XPVAL(2)=UPV
36688 ELSE
36689 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
36690 ENDIF
36691 ENDIF
36692
36693C...Isospin average for pi0/gammaVDM.
36694 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
36695 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
36696 XPV=XPQ(2)-XPQ(1)
36697 XPQ(2)=XPQ(1)
36698 XPQ(-2)=XPQ(-1)
36699 ELSE
36700 XPS=0.5D0*(XPQ(1)+XPQ(-2))
36701 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
36702 XPQ(2)=XPS
36703 XPQ(-1)=XPS
36704 ENDIF
36705 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
36706 & XPVAL(3)+XPVAL(4)+XPVAL(5)
36707 DO 250 KFL=-6,6
36708 XPVAL(KFL)=0D0
36709 250 CONTINUE
36710 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
36711 XPQ(1)=XPQ(1)+0.2D0*XPV
36712 XPQ(2)=XPQ(2)+0.8D0*XPV
36713 XPVAL(1)=0.2D0*XPVL
36714 XPVAL(2)=0.8D0*XPVL
36715 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
36716 XPQ(3)=XPQ(3)+XPV
36717 XPVAL(3)=XPVL
36718 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
36719 XPQ(4)=XPQ(4)+XPV
36720 XPVAL(4)=XPVL
36721 IF(MSTP(55).GE.9) THEN
36722 DO 260 KFL=-6,6
36723 XPQ(KFL)=0D0
36724 260 CONTINUE
36725 ENDIF
36726 ELSE
36727 XPQ(1)=XPQ(1)+0.5D0*XPV
36728 XPQ(2)=XPQ(2)+0.5D0*XPV
36729 XPVAL(1)=0.5D0*XPVL
36730 XPVAL(2)=0.5D0*XPVL
36731 ENDIF
36732 DO 270 KFL=1,6
36733 XPQ(-KFL)=XPQ(KFL)
36734 XPVAL(-KFL)=XPVAL(KFL)
36735 270 CONTINUE
36736
36737C...Rescale for gammaVDM by effective gamma -> rho coupling.
36738C+++Do not rescale?
36739 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
36740 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
36741 DO 280 KFL=-6,6
36742 XPQ(KFL)=VINT(281)*XPQ(KFL)
36743 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
36744 280 CONTINUE
36745 VINT(232)=VINT(281)*XPV
36746 ENDIF
36747
36748C...Simple recipes for kaons.
36749 ELSEIF(KFA.EQ.321) THEN
36750 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
36751 XPQ(-1)=XPQ(1)
36752 XPVAL(-3)=XPVAL(-1)
36753 XPVAL(-1)=0D0
36754 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
36755 XPS=0.5D0*(XPQ(1)+XPQ(-2))
36756 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
36757 XPQ(2)=XPS
36758 XPQ(-1)=XPS
36759 XPQ(1)=XPQ(1)+0.5D0*XPV
36760 XPQ(-1)=XPQ(-1)+0.5D0*XPV
36761 XPQ(3)=XPQ(3)+0.5D0*XPV
36762 XPQ(-3)=XPQ(-3)+0.5D0*XPV
36763 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
36764 XPVAL(2)=0D0
36765 XPVAL(-1)=0D0
36766 XPVAL(1)=0.5D0*XPV
36767 XPVAL(-1)=0.5D0*XPV
36768 XPVAL(3)=0.5D0*XPV
36769 XPVAL(-3)=0.5D0*XPV
36770
36771C...Isospin conjugation for neutron.
36772 ELSEIF(KFA.EQ.2112) THEN
36773 XPSV=XPQ(1)
36774 XPQ(1)=XPQ(2)
36775 XPQ(2)=XPSV
36776 XPSV=XPQ(-1)
36777 XPQ(-1)=XPQ(-2)
36778 XPQ(-2)=XPSV
36779 XPSV=XPVAL(1)
36780 XPVAL(1)=XPVAL(2)
36781 XPVAL(2)=XPSV
36782
36783C...Simple recipes for hyperon (average valence parton distribution).
36784 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
36785 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
36786 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
36787 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
36788 XPQ(1)=XPS
36789 XPQ(2)=XPS
36790 XPQ(-1)=XPS
36791 XPQ(-2)=XPS
36792 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
36793 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
36794 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
36795 XPV=(XPVAL(1)+XPVAL(2))/3D0
36796 XPVAL(1)=0D0
36797 XPVAL(2)=0D0
36798 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
36799 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
36800 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
36801 ENDIF
36802
36803C...Charge conjugation for antiparticle.
36804 IF(KF.LT.0) THEN
36805 DO 290 KFL=1,25
36806 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
36807 XPSV=XPQ(KFL)
36808 XPQ(KFL)=XPQ(-KFL)
36809 XPQ(-KFL)=XPSV
36810 290 CONTINUE
36811 DO 300 KFL=1,6
36812 XPSV=XPVAL(KFL)
36813 XPVAL(KFL)=XPVAL(-KFL)
36814 XPVAL(-KFL)=XPSV
36815 300 CONTINUE
36816 ENDIF
36817
36818C...MULTIPLE INTERACTIONS - PDF RESHAPING.
36819C...Set side.
36820 JS=MINT(30)
36821C...Only reshape PDFs for the non-first interactions;
36822C...But need valence/sea separation already from first interaction.
36823 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
36824 KFVSEL=KFIVAL(JS,1)
36825C...If valence quark kicked out of pi0 or gamma then that decides
36826C...whether we should consider state as d dbar, u ubar, s sbar, etc.
36827 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
36828 XPVL=0D0
36829 DO 310 KFL=1,6
36830 XPVL=XPVL+XPVAL(KFL)
36831 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
36832 XPVAL(KFL)=0D0
36833 310 CONTINUE
36834 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
36835 XPVAL(IABS(KFVSEL))=XPVL
36836 DO 320 KFL=1,6
36837 XPQ(-KFL)=XPQ(KFL)
36838 XPVAL(-KFL)=XPVAL(KFL)
36839 320 CONTINUE
36840
36841C...If valence quark kicked out of K0S or K0S then that decides whether
36842C...we should consider state as d sbar or s dbar.
36843 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
36844 KFS=1
36845 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
36846 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
36847 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
36848 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
36849 XPVAL(-KFS)=0D0
36850 KFS=-3*KFS
36851 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
36852 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
36853 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
36854 XPVAL(-KFS)=0D0
36855 ENDIF
36856
36857C...XPQ distributions are nominal for a (signed) beam particle
36858C...of KF type, with 1-Sum(x_prev) rescaled to 1.
36859 CMPFAC=1D0
36860 NRESC=0
36861 345 NRESC=NRESC+1
36862 PVCTOT(JS,-1)=0D0
36863 PVCTOT(JS, 0)=0D0
36864 PVCTOT(JS, 1)=0D0
36865 DO 350 IFL=-6,6
36866 IF(IFL.EQ.0) GOTO 350
36867
36868C...Count up number of original IFL valence quarks.
36869 IVORG=0
36870 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
36871 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
36872 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
36873C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
36874C...bookkeep as if d dbar (for total momentum sum in valence sector).
36875 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
36876C...Count down number of remaining IFL valence quarks. Skip current
36877C...interaction initiator.
36878 IVREM=IVORG
36879 DO 330 I1=1,NMI(JS)
36880 IF (I1.EQ.MINT(36)) GOTO 330
36881 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
36882 & IVREM=IVREM-1
36883 330 CONTINUE
36884
36885C...Separate out original VALENCE and SEA content.
36886 VAL=XPVAL(IFL)
36887 SEA=MAX(0D0,XPQ(IFL)-VAL)
36888 XPSVC(IFL,0)=VAL
36889 XPSVC(IFL,-1)=SEA
36890
36891C...Rescale valence content if changed.
36892 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
36893 & (VAL*IVREM)/IVORG
36894
36895C...Momentum integrals of original and removed valence quarks.
36896 IF(IVORG.NE.0) THEN
36897C...For p/n/pbar/nbar beams can split into d_val and u_val.
36898C...Isospin conjugation for neutrons
36899 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
36900 IAFLP=IABS(IFL)
36901 IF (KFA.EQ.2112) IAFLP=3-IAFLP
36902 VPAVG=PAVG(IAFLP,Q2)
36903C...For other baryons average d_val and u_val, like for PDFs.
36904 ELSEIF(KFA.GT.1000) THEN
36905 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
36906C...For mesons and photon average d_val and u_val and scale by 3/2.
36907C...Very crude, especially for photon.
36908 ELSE
36909 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
36910 ENDIF
36911 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
36912 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
36913 ENDIF
36914
36915C...Now add companions (at X with partner having been at Z=XASSOC).
36916C...NOTE: due to the assumed simple x scaling, the partner was at what
36917C...corresponds to a higher Z than XASSOC, if there were intermediate
36918C...scatterings. Nothing done about that for the moment.
36919 DO 340 IVC=1,NVC(JS,IFL)
36920C...Skip companions that have been kicked out
36921 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
36922 XPSVC(IFL,IVC)=0D0
36923 GOTO 340
36924 ELSE
36925C...Momentum fraction of the partner quark.
36926C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
36927 XS=XASSOC(JS,IFL,IVC)
36928 XREM=VINT(142+JS)
36929 YS=XS/(XREM+XS)
36930C...Momentum fraction of the companion quark.
36931C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
36932 Y=X*(1D0-YS)
36933 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
36934C...Add to momentum sum, with rescaling compensation factor.
36935 XCFAC=(XREM+XS)/XREM*CMPFAC
36936 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
36937 ENDIF
36938 340 CONTINUE
36939 350 CONTINUE
36940
36941C...Wait until all flavours treated, then rescale seas and gluon.
36942 XPSVC(0,-1)=XPQ(0)
36943 XPSVC(0,0)=0D0
36944 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
36945 IF (RSFAC.LE.0D0) THEN
36946C...First calculate factor needed to exactly restore pz cons.
36947 IF (NRESC.EQ.1) CMPFAC =
36948 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
36949C...Add a bit of headroom
36950 CMPFAC=0.99*CMPFAC
36951C...Try a few times if more headroom is needed, then print error message.
36952 IF (NRESC.LE.10) GOTO 345
36953 CALL PYERRM(15,
36954 & '(PYPDFU:) Negative reshaping factor persists!')
36955 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
36956 RSFAC=0D0
36957 ENDIF
36958 DO 370 IFL=-6,6
36959 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
36960C...Also store resulting distributions in XPQ
36961 XPQ(IFL)=0D0
36962 DO 360 ISVC=-1,NVC(JS,IFL)
36963 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
36964 360 CONTINUE
36965 370 CONTINUE
36966C...Save companion reweighting factor for PYPTIS.
36967 VINT(140)=CMPFAC
36968 ENDIF
36969
36970
36971C...Allow gluon also in position 21.
36972 XPQ(21)=XPQ(0)
36973
36974C...Check positivity and reset above maximum allowed flavour.
36975 DO 380 KFL=-25,25
36976 XPQ(KFL)=MAX(0D0,XPQ(KFL))
36977 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
36978 380 CONTINUE
36979
36980C...Formats for error printouts.
36981 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
36982 5100 FORMAT(' Error: illegal particle code for parton distribution;',
36983 &' KF =',I5)
36984 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
36985 &3I5)
36986 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
36987 & ' Removed valence momentum fraction : ',F6.3/
36988 & ' Added companion momentum fraction : ',F6.3/
36989 & ' Resulting rescale factor : ',F6.3)
36990
36991C...Reset side pointer and return
36992 9999 MINT(30)=0
36993
36994 RETURN
36995 END
36996
36997C*********************************************************************
36998
36999C...PYPDFL
37000C...Gives proton parton distribution at small x and/or Q^2 according to
37001C...correct limiting behaviour.
37002
37003 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37004
37005C...Double precision and integer declarations.
37006 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37007 IMPLICIT INTEGER(I-N)
37008 INTEGER PYK,PYCHGE,PYCOMP
37009C...Commonblocks.
37010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37011 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37012 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37013 COMMON/PYINT1/MINT(400),VINT(400)
37014 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37015C...Local arrays.
37016 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37017 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37018
37019C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37020 MINT(92)=0
37021 KFA=IABS(KF)
37022 IACC=0
37023 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37024 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37025 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37026 IF(IACC.EQ.0) THEN
37027 CALL PYPDFU(KF,X,Q2,XPQ)
37028 RETURN
37029 ENDIF
37030
37031C...Reset. Check x.
37032 DO 100 KFL=-25,25
37033 XPQ(KFL)=0D0
37034 100 CONTINUE
37035 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37036 WRITE(MSTU(11),5000) X
37037 RETURN
37038 ENDIF
37039
37040C...Define valence content.
37041 KFC=KF
37042 NV1=2
37043 NV2=1
37044 IF(KF.EQ.2212) THEN
37045 KFV1=2
37046 KFV2=1
37047 ELSEIF(KF.EQ.-2212) THEN
37048 KFV1=-2
37049 KFV2=-1
37050 ELSEIF(KF.EQ.2112) THEN
37051 KFV1=1
37052 KFV2=2
37053 ELSEIF(KF.EQ.-2112) THEN
37054 KFV1=-1
37055 KFV2=-2
37056 ELSEIF(KF.EQ.211) THEN
37057 NV1=1
37058 KFV1=2
37059 KFV2=-1
37060 ELSEIF(KF.EQ.-211) THEN
37061 NV1=1
37062 KFV1=-2
37063 KFV2=1
37064 ELSEIF(MINT(105).LE.223) THEN
37065 KFV1=1
37066 WTV1=0.2D0
37067 KFV2=2
37068 WTV2=0.8D0
37069 ELSEIF(MINT(105).EQ.333) THEN
37070 KFV1=3
37071 WTV1=1.0D0
37072 KFV2=1
37073 WTV2=0.0D0
37074 ELSEIF(MINT(105).EQ.443) THEN
37075 KFV1=4
37076 WTV1=1.0D0
37077 KFV2=1
37078 WTV2=0.0D0
37079 ENDIF
37080
37081C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
37082 MINT30=MINT(30)
37083 CALL PYPDFU(KFC,X,Q2,XPA)
37084 Q2MN=MAX(3D0,VINT(231))
37085 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
37086 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
37087
37088C...Large Q2 and large x: naive call is enough.
37089 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
37090 DO 110 KFL=-25,25
37091 XPQ(KFL)=XPA(KFL)
37092 110 CONTINUE
37093 MINT(92)=1
37094
37095C...Small Q2 and large x: dampen boundary value.
37096 ELSEIF(X.GT.XMN) THEN
37097
37098C...Evaluate at boundary and define dampening factors.
37099 MINT(30)=MINT30
37100 CALL PYPDFU(KFC,X,Q2MN,XPA)
37101 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
37102 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
37103
37104C...Separate valence and sea parts of parton distribution.
37105 IF(KFA.NE.22) THEN
37106 XFV1=XPA(KFV1)-XPA(-KFV1)
37107 XPA(KFV1)=XPA(-KFV1)
37108 XFV2=XPA(KFV2)-XPA(-KFV2)
37109 XPA(KFV2)=XPA(-KFV2)
37110 ELSE
37111 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
37112 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
37113 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
37114 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
37115 ENDIF
37116
37117C...Dampen valence and sea separately. Put back together.
37118 DO 120 KFL=-25,25
37119 XPQ(KFL)=FS*XPA(KFL)
37120 120 CONTINUE
37121 IF(KFA.NE.22) THEN
37122 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
37123 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
37124 ELSE
37125 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
37126 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
37127 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
37128 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
37129 ENDIF
37130 MINT(92)=2
37131
37132C...Large Q2 and small x: interpolate behaviour.
37133 ELSEIF(Q2.GT.Q2MN) THEN
37134
37135C...Evaluate at extremes and define coefficients for interpolation.
37136 MINT(30)=MINT30
37137 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
37138 VI232A=VINT(232)
37139 MINT(30)=MINT30
37140 CALL PYPDFU(KFC,X,Q2B,XPB)
37141 VI232B=VINT(232)
37142 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
37143 FVA=(X/XMN)**0.45D0*FLA
37144 FSA=(X/XMN)**(-0.08D0)*FLA
37145 FB=1D0-FLA
37146
37147C...Separate valence and sea parts of parton distribution.
37148 IF(KFA.NE.22) THEN
37149 XFVA1=XPA(KFV1)-XPA(-KFV1)
37150 XPA(KFV1)=XPA(-KFV1)
37151 XFVA2=XPA(KFV2)-XPA(-KFV2)
37152 XPA(KFV2)=XPA(-KFV2)
37153 XFVB1=XPB(KFV1)-XPB(-KFV1)
37154 XPB(KFV1)=XPB(-KFV1)
37155 XFVB2=XPB(KFV2)-XPB(-KFV2)
37156 XPB(KFV2)=XPB(-KFV2)
37157 ELSE
37158 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
37159 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
37160 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
37161 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
37162 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
37163 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
37164 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
37165 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
37166 ENDIF
37167
37168C...Interpolate for valence and sea. Put back together.
37169 DO 130 KFL=-25,25
37170 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
37171 130 CONTINUE
37172 IF(KFA.NE.22) THEN
37173 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
37174 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
37175 ELSE
37176 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
37177 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
37178 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
37179 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
37180 ENDIF
37181 MINT(92)=3
37182
37183C...Small Q2 and small x: dampen boundary value and add term.
37184 ELSE
37185
37186C...Evaluate at boundary and define dampening factors.
37187 MINT(30)=MINT30
37188 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
37189 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
37190 FA=1D0-FB
37191 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
37192 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
37193 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
37194 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
37195 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
37196 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
37197
37198C...Separate valence and sea parts of parton distribution.
37199 IF(KFA.NE.22) THEN
37200 XFV1=XPA(KFV1)-XPA(-KFV1)
37201 XPA(KFV1)=XPA(-KFV1)
37202 XFV2=XPA(KFV2)-XPA(-KFV2)
37203 XPA(KFV2)=XPA(-KFV2)
37204 ELSE
37205 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
37206 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
37207 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
37208 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
37209 ENDIF
37210
37211C...Dampen valence and sea separately. Add constant terms.
37212C...Put back together.
37213 DO 140 KFL=-25,25
37214 XPQ(KFL)=FSA*XPA(KFL)
37215 140 CONTINUE
37216 IF(KFA.NE.22) THEN
37217 DO 150 KFL=-3,3
37218 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
37219 150 CONTINUE
37220 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
37221 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
37222 ELSE
37223 DO 160 KFL=-3,3
37224 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
37225 160 CONTINUE
37226 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
37227 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
37228 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
37229 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
37230 ENDIF
37231 XPQ(21)=XPQ(0)
37232 MINT(92)=4
37233 ENDIF
37234
37235C...Format for error printout.
37236 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37237
37238 RETURN
37239 END
37240
37241C*********************************************************************
37242
37243C...PYPDEL
37244C...Gives electron (or muon, or tau) parton distribution.
37245
37246 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
37247
37248C...Double precision and integer declarations.
37249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37250 IMPLICIT INTEGER(I-N)
37251 INTEGER PYK,PYCHGE,PYCOMP
37252C...Commonblocks.
37253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37255 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37256 COMMON/PYINT1/MINT(400),VINT(400)
37257 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37258C...Local arrays.
37259 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
37260
37261C...Interface to PDFLIB.
37262 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
37263 SAVE /W50513/
37264 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
37265 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
37266 CHARACTER*20 PARM(20)
37267 DATA VALUE/20*0D0/,PARM/20*' '/
37268
37269C...Some common constants.
37270 DO 100 KFL=-25,25
37271 XPEL(KFL)=0D0
37272 100 CONTINUE
37273 AEM=PARU(101)
37274 PME=PMAS(11,1)
37275 IF(KFA.EQ.13) PME=PMAS(13,1)
37276 IF(KFA.EQ.15) PME=PMAS(15,1)
37277 XL=LOG(MAX(1D-10,X))
37278 X1L=LOG(MAX(1D-10,1D0-X))
37279 HLE=LOG(MAX(3D0,Q2/PME**2))
37280 HBE2=(AEM/PARU(1))*(HLE-1D0)
37281
37282C...Electron inside electron, see R. Kleiss et al., in Z physics at
37283C...LEP 1, CERN 89-08, p. 34
37284 IF(MSTP(59).LE.1) THEN
37285 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
37286 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
37287 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
37288 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
37289 & 4D0*XL/(1D0-X)-5D0-X)
37290 ELSE
37291 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
37292 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
37293 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
37294 ENDIF
37295C...Zero distribution for very large x and rescale it for intermediate.
37296 IF(X.GT.1D0-1D-10) THEN
37297 HEE=0D0
37298 ELSEIF(X.GT.1D0-1D-7) THEN
37299 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
37300 ENDIF
37301 XPEL(KFA)=X*HEE
37302
37303C...Photon and (transverse) W- inside electron.
37304 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
37305 IF(MSTP(13).LE.1) THEN
37306 HLG=HLE
37307 ELSE
37308 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
37309 ENDIF
37310 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
37311 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
37312 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
37313
37314C...Electron or positron inside photon inside electron.
37315 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
37316 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
37317 & 2D0*X*(1D0+X)*XL)
37318 XPEL(11)=XPEL(11)+XFSEA
37319 XPEL(-11)=XFSEA
37320
37321C...Initialize PDFLIB photon parton distributions.
37322 IF(MSTP(56).EQ.2) THEN
37323 PARM(1)='NPTYPE'
37324 VALUE(1)=3
37325 PARM(2)='NGROUP'
37326 VALUE(2)=MSTP(55)/1000
37327 PARM(3)='NSET'
37328 VALUE(3)=MOD(MSTP(55),1000)
37329 IF(MINT(93).NE.3000000+MSTP(55)) THEN
37330 CALL PDFSET(PARM,VALUE)
37331 MINT(93)=3000000+MSTP(55)
37332 ENDIF
37333 ENDIF
37334
37335C...Quarks and gluons inside photon inside electron:
37336C...numerical convolution required.
37337 DO 110 KFL=0,6
37338 SXP(KFL)=0D0
37339 110 CONTINUE
37340 SUMXPP=0D0
37341 ITER=-1
37342 120 ITER=ITER+1
37343 SUMXP=SUMXPP
37344 NSTP=2**(ITER-1)
37345 IF(ITER.EQ.0) NSTP=2
37346 DO 130 KFL=0,6
37347 SXP(KFL)=0.5D0*SXP(KFL)
37348 130 CONTINUE
37349 WTSTP=0.5D0/NSTP
37350 IF(ITER.EQ.0) WTSTP=0.5D0
37351C...Pick grid of x_{gamma} values logarithmically even.
37352 DO 150 ISTP=1,NSTP
37353 IF(ITER.EQ.0) THEN
37354 XLE=XL*(ISTP-1)
37355 ELSE
37356 XLE=XL*(ISTP-0.5D0)/NSTP
37357 ENDIF
37358 XE=MIN(1D0-1D-10,EXP(XLE))
37359 XG=MIN(1D0-1D-10,X/XE)
37360C...Evaluate photon inside electron parton distribution for convolution.
37361 XPGP=1D0+(1D0-XE)**2
37362 IF(MSTP(13).LE.1) THEN
37363 XPGP=XPGP*HLE
37364 ELSE
37365 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
37366 ENDIF
37367C...Evaluate photon parton distributions for convolution.
37368 IF(MSTP(56).EQ.1) THEN
37369 IF(MSTP(55).EQ.1) THEN
37370 CALL PYPDGA(XG,Q2,XPGA)
37371 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37372 Q2MX=Q2
37373 P2MX=0.36D0
37374 IF(MSTP(55).GE.7) P2MX=4.0D0
37375 IF(MSTP(57).EQ.0) Q2MX=P2MX
37376 P2=0D0
37377 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37378 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37379 VINT(231)=P2MX
37380 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37381 Q2MX=Q2
37382 P2MX=0.36D0
37383 IF(MSTP(55).GE.11) P2MX=4.0D0
37384 IF(MSTP(57).EQ.0) Q2MX=P2MX
37385 P2=0D0
37386 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37387 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37388 VINT(231)=P2MX
37389 ENDIF
37390 DO 140 KFL=0,5
37391 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
37392 140 CONTINUE
37393 ELSEIF(MSTP(56).EQ.2) THEN
37394C...Call PDFLIB parton distributions.
37395 XX=XG
37396 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37397 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37398 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37399 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
37400 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
37401 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
37402 SXP(3)=SXP(3)+WTSTP*XPGP*STR
37403 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
37404 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
37405 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
37406 ENDIF
37407 150 CONTINUE
37408 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
37409 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
37410 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
37411
37412C...Put convolution into output arrays.
37413 FCONV=AEMP*(-XL)
37414 XPEL(0)=FCONV*SXP(0)
37415 DO 160 KFL=1,6
37416 XPEL(KFL)=FCONV*SXP(KFL)
37417 XPEL(-KFL)=XPEL(KFL)
37418 160 CONTINUE
37419 ENDIF
37420
37421 RETURN
37422 END
37423
37424C*********************************************************************
37425
37426C...PYPDGA
37427C...Gives photon parton distribution.
37428
37429 SUBROUTINE PYPDGA(X,Q2,XPGA)
37430
37431C...Double precision and integer declarations.
37432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37433 IMPLICIT INTEGER(I-N)
37434 INTEGER PYK,PYCHGE,PYCOMP
37435C...Commonblocks.
37436 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37437 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37438 COMMON/PYINT1/MINT(400),VINT(400)
37439 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
37440C...Local arrays.
37441 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
37442 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
37443 &DGCS(4,3),DGDS(4,3),DGES(4,3)
37444
37445C...The following data lines are coefficients needed in the
37446C...Drees and Grassie photon parton distribution parametrization.
37447 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
37448 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
37449 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
37450 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
37451 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
37452 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
37453 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
37454 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
37455 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
37456 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
37457 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
37458 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
37459 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
37460 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
37461 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
37462 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
37463 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
37464 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
37465 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
37466 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
37467 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
37468 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
37469 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
37470 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
37471 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
37472 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
37473
37474C...Photon parton distribution from Drees and Grassie.
37475C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
37476 DO 100 KFL=-6,6
37477 XPGA(KFL)=0D0
37478 100 CONTINUE
37479 VINT(231)=1D0
37480 IF(MSTP(57).LE.0) THEN
37481 T=LOG(1D0/0.16D0)
37482 ELSE
37483 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
37484 ENDIF
37485 X1=1D0-X
37486 NF=3
37487 IF(Q2.GT.25D0) NF=4
37488 IF(Q2.GT.300D0) NF=5
37489 NFE=NF-2
37490 AEM=PARU(101)
37491
37492C...Evaluate gluon content.
37493 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
37494 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
37495 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
37496 XPGL=DGA*X**DGB*X1**DGC
37497
37498C...Evaluate up- and down-type quark content.
37499 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
37500 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
37501 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
37502 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
37503 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
37504 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
37505 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
37506 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
37507 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
37508 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
37509 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
37510 DGF=9D0
37511 IF(NF.EQ.4) DGF=10D0
37512 IF(NF.EQ.5) DGF=55D0/6D0
37513 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
37514 IF(NF.LE.3) THEN
37515 XPQU=(XPQS+9D0*XPQN)/6D0
37516 XPQD=(XPQS-4.5D0*XPQN)/6D0
37517 ELSEIF(NF.EQ.4) THEN
37518 XPQU=(XPQS+6D0*XPQN)/8D0
37519 XPQD=(XPQS-6D0*XPQN)/8D0
37520 ELSE
37521 XPQU=(XPQS+7.5D0*XPQN)/10D0
37522 XPQD=(XPQS-5D0*XPQN)/10D0
37523 ENDIF
37524
37525C...Put into output arrays.
37526 XPGA(0)=AEM*XPGL
37527 XPGA(1)=AEM*XPQD
37528 XPGA(2)=AEM*XPQU
37529 XPGA(3)=AEM*XPQD
37530 IF(NF.GE.4) XPGA(4)=AEM*XPQU
37531 IF(NF.GE.5) XPGA(5)=AEM*XPQD
37532 DO 110 KFL=1,6
37533 XPGA(-KFL)=XPGA(KFL)
37534 110 CONTINUE
37535
37536 RETURN
37537 END
37538
37539C*********************************************************************
37540
37541C...PYGGAM
37542C...Constructs the F2 and parton distributions of the photon
37543C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
37544C...For F2, c and b are included by the Bethe-Heitler formula;
37545C...in the 'MSbar' scheme additionally a Cgamma term is added.
37546C...Contains the SaS sets 1D, 1M, 2D and 2M.
37547C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
37548
37549 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
37550
37551C...Double precision and integer declarations.
37552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37553 IMPLICIT INTEGER(I-N)
37554 INTEGER PYK,PYCHGE,PYCOMP
37555C...Commonblocks.
37556 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37557 &XPDIR(-6:6)
37558 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37559 SAVE /PYINT8/,/PYINT9/
37560C...Local arrays.
37561 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
37562C...Charm and bottom masses (low to compensate for J/psi etc.).
37563 DATA PMC/1.3D0/, PMB/4.6D0/
37564C...alpha_em and alpha_em/(2*pi).
37565 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
37566C...Lambda value for 4 flavours.
37567 DATA ALAM/0.20D0/
37568C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
37569 DATA FRACU/0.8D0/
37570C...VMD couplings f_V**2/(4*pi).
37571 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
37572C...Masses for rho (=omega) and phi.
37573 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
37574C...Number of points in integration for IP2=1.
37575 DATA NSTEP/100/
37576
37577C...Reset output.
37578 F2GM=0D0
37579 DO 100 KFL=-6,6
37580 XPDFGM(KFL)=0D0
37581 XPVMD(KFL)=0D0
37582 XPANL(KFL)=0D0
37583 XPANH(KFL)=0D0
37584 XPBEH(KFL)=0D0
37585 XPDIR(KFL)=0D0
37586 VXPVMD(KFL)=0D0
37587 VXPANL(KFL)=0D0
37588 VXPANH(KFL)=0D0
37589 VXPDGM(KFL)=0D0
37590 100 CONTINUE
37591
37592C...Set Q0 cut-off parameter as function of set used.
37593 IF(ISET.LE.2) THEN
37594 Q0=0.6D0
37595 ELSE
37596 Q0=2D0
37597 ENDIF
37598 Q02=Q0**2
37599
37600C...Scale choice for off-shell photon; common factors.
37601 Q2A=Q2
37602 FACNOR=1D0
37603 IF(IP2.EQ.1) THEN
37604 P2MX=P2+Q02
37605 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
37606 FACNOR=LOG(Q2/Q02)/NSTEP
37607 ELSEIF(IP2.EQ.2) THEN
37608 P2MX=MAX(P2,Q02)
37609 ELSEIF(IP2.EQ.3) THEN
37610 P2MX=P2+Q02
37611 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
37612 ELSEIF(IP2.EQ.4) THEN
37613 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37614 & ((Q2+P2)*(Q02+P2)))
37615 ELSEIF(IP2.EQ.5) THEN
37616 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37617 & ((Q2+P2)*(Q02+P2)))
37618 P2MX=Q0*SQRT(P2MXA)
37619 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
37620 ELSEIF(IP2.EQ.6) THEN
37621 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37622 & ((Q2+P2)*(Q02+P2)))
37623 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
37624 ELSE
37625 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
37626 & ((Q2+P2)*(Q02+P2)))
37627 P2MX=Q0*SQRT(P2MXA)
37628 P2MXB=P2MX
37629 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
37630 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
37631 IF(ABS(Q2-Q02).GT.1D-6) THEN
37632 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
37633 ELSEIF(P2.LT.Q02) THEN
37634 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
37635 ELSE
37636 FACNOR=1D0
37637 ENDIF
37638 ENDIF
37639
37640C...Call VMD parametrization for d quark and use to give rho, omega,
37641C...phi. Note dipole dampening for off-shell photon.
37642 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37643 XFVAL=VXPGA(1)
37644 XPGA(1)=XPGA(2)
37645 XPGA(-1)=XPGA(-2)
37646 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
37647 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
37648 DO 110 KFL=-5,5
37649 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
37650 110 CONTINUE
37651 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
37652 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
37653 XPVMD(3)=XPVMD(3)+FACS*XFVAL
37654 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
37655 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
37656 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
37657 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
37658 VXPVMD(2)=FRACU*FACUD*XFVAL
37659 VXPVMD(3)=FACS*XFVAL
37660 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
37661 VXPVMD(-2)=FRACU*FACUD*XFVAL
37662 VXPVMD(-3)=FACS*XFVAL
37663
37664 IF(IP2.NE.1) THEN
37665C...Anomalous parametrizations for different strategies
37666C...for off-shell photons; except full integration.
37667
37668C...Call anomalous parametrization for d + u + s.
37669 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37670 DO 120 KFL=-5,5
37671 XPANL(KFL)=FACNOR*XPGA(KFL)
37672 VXPANL(KFL)=FACNOR*VXPGA(KFL)
37673 120 CONTINUE
37674
37675C...Call anomalous parametrization for c and b.
37676 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37677 DO 130 KFL=-5,5
37678 XPANH(KFL)=FACNOR*XPGA(KFL)
37679 VXPANH(KFL)=FACNOR*VXPGA(KFL)
37680 130 CONTINUE
37681 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
37682 DO 140 KFL=-5,5
37683 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
37684 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
37685 140 CONTINUE
37686
37687 ELSE
37688C...Special option: loop over flavours and integrate over k2.
37689 DO 170 KF=1,5
37690 DO 160 ISTEP=1,NSTEP
37691 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
37692 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
37693 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
37694 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
37695 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
37696 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
37697 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
37698 DO 150 KFL=-5,5
37699 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
37700 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
37701 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
37702 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
37703 150 CONTINUE
37704 160 CONTINUE
37705 170 CONTINUE
37706 ENDIF
37707
37708C...Call Bethe-Heitler term expression for charm and bottom.
37709 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
37710 XPBEH(4)=XPBH
37711 XPBEH(-4)=XPBH
37712 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
37713 XPBEH(5)=XPBH
37714 XPBEH(-5)=XPBH
37715
37716C...For MSbar subtraction call C^gamma term expression for d, u, s.
37717 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
37718 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
37719 DO 180 KFL=-5,5
37720 XPDIR(KFL)=XPGA(KFL)
37721 180 CONTINUE
37722 ENDIF
37723
37724C...Store result in output array.
37725 DO 190 KFL=-5,5
37726 CHSQ=1D0/9D0
37727 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
37728 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37729 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
37730 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
37731 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
37732 190 CONTINUE
37733
37734 RETURN
37735 END
37736
37737C*********************************************************************
37738
37739C...PYGVMD
37740C...Evaluates the VMD parton distributions of a photon,
37741C...evolved homogeneously from an initial scale P2 to Q2.
37742C...Does not include dipole suppression factor.
37743C...ISET is parton distribution set, see above;
37744C...additionally ISET=0 is used for the evolution of an anomalous photon
37745C...which branched at a scale P2 and then evolved homogeneously to Q2.
37746C...ALAM is the 4-flavour Lambda, which is automatically converted
37747C...to 3- and 5-flavour equivalents as needed.
37748C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
37749
37750 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
37751
37752C...Double precision and integer declarations.
37753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37754 IMPLICIT INTEGER(I-N)
37755 INTEGER PYK,PYCHGE,PYCOMP
37756C...Local arrays and data.
37757 DIMENSION XPGA(-6:6), VXPGA(-6:6)
37758 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
37759
37760C...Reset output.
37761 DO 100 KFL=-6,6
37762 XPGA(KFL)=0D0
37763 VXPGA(KFL)=0D0
37764 100 CONTINUE
37765 KFA=IABS(KF)
37766
37767C...Calculate Lambda; protect against unphysical Q2 and P2 input.
37768 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
37769 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
37770 P2EFF=MAX(P2,1.2D0*ALAM3**2)
37771 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
37772 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
37773 Q2EFF=MAX(Q2,P2EFF)
37774
37775C...Find number of flavours at lower and upper scale.
37776 NFP=4
37777 IF(P2EFF.LT.PMC**2) NFP=3
37778 IF(P2EFF.GT.PMB**2) NFP=5
37779 NFQ=4
37780 IF(Q2EFF.LT.PMC**2) NFQ=3
37781 IF(Q2EFF.GT.PMB**2) NFQ=5
37782
37783C...Find s as sum of 3-, 4- and 5-flavour parts.
37784 S=0D0
37785 IF(NFP.EQ.3) THEN
37786 Q2DIV=PMC**2
37787 IF(NFQ.EQ.3) Q2DIV=Q2EFF
37788 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
37789 ENDIF
37790 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
37791 P2DIV=P2EFF
37792 IF(NFP.EQ.3) P2DIV=PMC**2
37793 Q2DIV=Q2EFF
37794 IF(NFQ.EQ.5) Q2DIV=PMB**2
37795 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
37796 ENDIF
37797 IF(NFQ.EQ.5) THEN
37798 P2DIV=PMB**2
37799 IF(NFP.EQ.5) P2DIV=P2EFF
37800 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
37801 ENDIF
37802
37803C...Calculate frequent combinations of x and s.
37804 X1=1D0-X
37805 XL=-LOG(X)
37806 S2=S**2
37807 S3=S**3
37808 S4=S**4
37809
37810C...Evaluate homogeneous anomalous parton distributions below or
37811C...above threshold.
37812 IF(ISET.EQ.0) THEN
37813 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37814 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37815 XVAL = X * 1.5D0 * (X**2+X1**2)
37816 XGLU = 0D0
37817 XSEA = 0D0
37818 ELSE
37819 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
37820 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
37821 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
37822 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
37823 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
37824 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
37825 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
37826 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
37827 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
37828 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
37829 & (2D0*X-1D0)*X*XL**2)
37830 ENDIF
37831
37832C...Evaluate set 1D parton distributions below or above threshold.
37833 ELSEIF(ISET.EQ.1) THEN
37834 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37835 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37836 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
37837 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
37838 XSEA = 0.100D0 * X1**3.76D0
37839 ELSE
37840 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
37841 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
37842 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
37843 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
37844 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
37845 & X**0.40D0 * X1**(1.76D0+3D0*S)
37846 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
37847 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
37848 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
37849 XSEA0 = 0.100D0 * X1**3.76D0
37850 ENDIF
37851
37852C...Evaluate set 1M parton distributions below or above threshold.
37853 ELSEIF(ISET.EQ.2) THEN
37854 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37855 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37856 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
37857 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
37858 XSEA = 0D0
37859 ELSE
37860 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
37861 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
37862 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
37863 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
37864 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
37865 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
37866 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
37867 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
37868 & XL**(2.8D0*S)
37869 XSEA0 = 0D0
37870 ENDIF
37871
37872C...Evaluate set 2D parton distributions below or above threshold.
37873 ELSEIF(ISET.EQ.3) THEN
37874 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37875 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37876 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
37877 XGLU = 1.925D0 * X1**2
37878 XSEA = 0.242D0 * X1**4
37879 ELSE
37880 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
37881 & X**(0.46D0+0.25D0*S) *
37882 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
37883 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
37884 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
37885 & EXP(-18.67D0*S) *
37886 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
37887 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
37888 & XL**(9.3D0*S/(1D0+1.7D0*S))
37889 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
37890 & (1D0-0.607D0*S+21.95D0*S2) *
37891 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
37892 XSEA0 = 0.242D0 * X1**4
37893 ENDIF
37894
37895C...Evaluate set 2M parton distributions below or above threshold.
37896 ELSEIF(ISET.EQ.4) THEN
37897 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
37898 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
37899 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
37900 XGLU = 1.808D0 * X1**2
37901 XSEA = 0.209D0 * X1**4
37902 ELSE
37903 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
37904 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
37905 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
37906 & XL**(5.15D0*S/(1D0+2D0*S)) +
37907 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
37908 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
37909 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
37910 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
37911 & XL**(10.9D0*S/(1D0+2.5D0*S))
37912 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
37913 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
37914 & X1**(4D0+S) * XL**(0.45D0*S)
37915 XSEA0 = 0.209D0 * X1**4
37916 ENDIF
37917 ENDIF
37918
37919C...Threshold factors for c and b sea.
37920 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
37921 XCHM=0D0
37922 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
37923 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
37924 IF(ISET.EQ.0) THEN
37925 XCHM=XSEA*(1D0-(SCH/SLL)**2)
37926 ELSE
37927 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
37928 ENDIF
37929 ENDIF
37930 XBOT=0D0
37931 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
37932 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
37933 IF(ISET.EQ.0) THEN
37934 XBOT=XSEA*(1D0-(SBT/SLL)**2)
37935 ELSE
37936 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
37937 ENDIF
37938 ENDIF
37939
37940C...Fill parton distributions.
37941 XPGA(0)=XGLU
37942 XPGA(1)=XSEA
37943 XPGA(2)=XSEA
37944 XPGA(3)=XSEA
37945 XPGA(4)=XCHM
37946 XPGA(5)=XBOT
37947 XPGA(KFA)=XPGA(KFA)+XVAL
37948 DO 110 KFL=1,5
37949 XPGA(-KFL)=XPGA(KFL)
37950 110 CONTINUE
37951 VXPGA(KFA)=XVAL
37952 VXPGA(-KFA)=XVAL
37953
37954 RETURN
37955 END
37956
37957C*********************************************************************
37958
37959C...PYGANO
37960C...Evaluates the parton distributions of the anomalous photon,
37961C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
37962C...KF=0 gives the sum over (up to) 5 flavours,
37963C...KF<0 limits to flavours up to abs(KF),
37964C...KF>0 is for flavour KF only.
37965C...ALAM is the 4-flavour Lambda, which is automatically converted
37966C...to 3- and 5-flavour equivalents as needed.
37967C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
37968
37969 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
37970
37971C...Double precision and integer declarations.
37972 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37973 IMPLICIT INTEGER(I-N)
37974 INTEGER PYK,PYCHGE,PYCOMP
37975C...Local arrays and data.
37976 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
37977 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
37978
37979C...Reset output.
37980 DO 100 KFL=-6,6
37981 XPGA(KFL)=0D0
37982 VXPGA(KFL)=0D0
37983 100 CONTINUE
37984 IF(Q2.LE.P2) RETURN
37985 KFA=IABS(KF)
37986
37987C...Calculate Lambda; protect against unphysical Q2 and P2 input.
37988 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
37989 ALAMSQ(4)=ALAM**2
37990 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
37991 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
37992 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
37993 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
37994 Q2EFF=MAX(Q2,P2EFF)
37995 XL=-LOG(X)
37996
37997C...Find number of flavours at lower and upper scale.
37998 NFP=4
37999 IF(P2EFF.LT.PMC**2) NFP=3
38000 IF(P2EFF.GT.PMB**2) NFP=5
38001 NFQ=4
38002 IF(Q2EFF.LT.PMC**2) NFQ=3
38003 IF(Q2EFF.GT.PMB**2) NFQ=5
38004
38005C...Define range of flavour loop.
38006 IF(KF.EQ.0) THEN
38007 KFLMN=1
38008 KFLMX=5
38009 ELSEIF(KF.LT.0) THEN
38010 KFLMN=1
38011 KFLMX=KFA
38012 ELSE
38013 KFLMN=KFA
38014 KFLMX=KFA
38015 ENDIF
38016
38017C...Loop over flavours the photon can branch into.
38018 DO 110 KFL=KFLMN,KFLMX
38019
38020C...Light flavours: calculate t range and (approximate) s range.
38021 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38022 TDIFF=LOG(Q2EFF/P2EFF)
38023 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38024 & LOG(P2EFF/ALAMSQ(NFQ)))
38025 IF(NFQ.GT.NFP) THEN
38026 Q2DIV=PMB**2
38027 IF(NFQ.EQ.4) Q2DIV=PMC**2
38028 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38029 & LOG(P2EFF/ALAMSQ(NFQ)))
38030 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38031 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38032 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38033 ENDIF
38034 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38035 Q2DIV=PMC**2
38036 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38037 & LOG(P2EFF/ALAMSQ(4)))
38038 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38039 & LOG(P2EFF/ALAMSQ(3)))
38040 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38041 ENDIF
38042
38043C...u and s quark do not need a separate treatment when d has been done.
38044 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38045
38046C...Charm: as above, but only include range above c threshold.
38047 ELSEIF(KFL.EQ.4) THEN
38048 IF(Q2.LE.PMC**2) GOTO 110
38049 P2EFF=MAX(P2EFF,PMC**2)
38050 Q2EFF=MAX(Q2EFF,P2EFF)
38051 TDIFF=LOG(Q2EFF/P2EFF)
38052 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38053 & LOG(P2EFF/ALAMSQ(NFQ)))
38054 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38055 Q2DIV=PMB**2
38056 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38057 & LOG(P2EFF/ALAMSQ(NFQ)))
38058 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38059 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38060 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38061 ENDIF
38062
38063C...Bottom: as above, but only include range above b threshold.
38064 ELSEIF(KFL.EQ.5) THEN
38065 IF(Q2.LE.PMB**2) GOTO 110
38066 P2EFF=MAX(P2EFF,PMB**2)
38067 Q2EFF=MAX(Q2,P2EFF)
38068 TDIFF=LOG(Q2EFF/P2EFF)
38069 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38070 & LOG(P2EFF/ALAMSQ(NFQ)))
38071 ENDIF
38072
38073C...Evaluate flavour-dependent prefactor (charge^2 etc.).
38074 CHSQ=1D0/9D0
38075 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
38076 FAC=AEM2PI*2D0*CHSQ*TDIFF
38077
38078C...Evaluate parton distributions (normalized to unit momentum sum).
38079 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
38080 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
38081 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
38082 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
38083 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
38084 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
38085 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
38086 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
38087 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
38088 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
38089 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
38090 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
38091
38092C...Threshold factors for c and b sea.
38093 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38094 XCHM=0D0
38095 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38096 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38097 XCHM=XSEA*(1D0-(SCH/SLL)**3)
38098 ENDIF
38099 XBOT=0D0
38100 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38101 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38102 XBOT=XSEA*(1D0-(SBT/SLL)**3)
38103 ENDIF
38104 ENDIF
38105
38106C...Add contribution of each valence flavour.
38107 XPGA(0)=XPGA(0)+FAC*XGLU
38108 XPGA(1)=XPGA(1)+FAC*XSEA
38109 XPGA(2)=XPGA(2)+FAC*XSEA
38110 XPGA(3)=XPGA(3)+FAC*XSEA
38111 XPGA(4)=XPGA(4)+FAC*XCHM
38112 XPGA(5)=XPGA(5)+FAC*XBOT
38113 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
38114 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
38115 110 CONTINUE
38116 DO 120 KFL=1,5
38117 XPGA(-KFL)=XPGA(KFL)
38118 VXPGA(-KFL)=VXPGA(KFL)
38119 120 CONTINUE
38120
38121 RETURN
38122 END
38123
38124
38125C*********************************************************************
38126
38127C...PYGBEH
38128C...Evaluates the Bethe-Heitler cross section for heavy flavour
38129C...production.
38130C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38131
38132 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
38133
38134C...Double precision and integer declarations.
38135 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38136 IMPLICIT INTEGER(I-N)
38137 INTEGER PYK,PYCHGE,PYCOMP
38138
38139C...Local data.
38140 DATA AEM2PI/0.0011614D0/
38141
38142C...Reset output.
38143 XPBH=0D0
38144 SIGBH=0D0
38145
38146C...Check kinematics limits.
38147 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
38148 W2=Q2*(1D0-X)/X-P2
38149 BETA2=1D0-4D0*PM2/W2
38150 IF(BETA2.LT.1D-10) RETURN
38151 BETA=SQRT(BETA2)
38152 RMQ=4D0*PM2/Q2
38153
38154C...Simple case: P2 = 0.
38155 IF(P2.LT.1D-4) THEN
38156 IF(BETA.LT.0.99D0) THEN
38157 XBL=LOG((1D0+BETA)/(1D0-BETA))
38158 ELSE
38159 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
38160 ENDIF
38161 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
38162 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
38163
38164C...Complicated case: P2 > 0, based on approximation of
38165C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
38166 ELSE
38167 RPQ=1D0-4D0*X**2*P2/Q2
38168 IF(RPQ.GT.1D-10) THEN
38169 RPBE=SQRT(RPQ*BETA2)
38170 IF(RPBE.LT.0.99D0) THEN
38171 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
38172 XBI=2D0*RPBE/(1D0-RPBE**2)
38173 ELSE
38174 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
38175 XBL=LOG((1D0+RPBE)**2/RPBESN)
38176 XBI=2D0*RPBE/RPBESN
38177 ENDIF
38178 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
38179 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
38180 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
38181 ENDIF
38182 ENDIF
38183
38184C...Multiply by charge-squared etc. to get parton distribution.
38185 CHSQ=1D0/9D0
38186 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
38187 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
38188
38189 RETURN
38190 END
38191
38192C*********************************************************************
38193
38194C...PYGDIR
38195C...Evaluates the direct contribution, i.e. the C^gamma term,
38196C...as needed in MSbar parametrizations.
38197C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38198
38199 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
38200
38201C...Double precision and integer declarations.
38202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38203 IMPLICIT INTEGER(I-N)
38204 INTEGER PYK,PYCHGE,PYCOMP
38205C...Local array and data.
38206 DIMENSION XPGA(-6:6)
38207 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
38208
38209C...Reset output.
38210 DO 100 KFL=-6,6
38211 XPGA(KFL)=0D0
38212 100 CONTINUE
38213
38214C...Evaluate common x-dependent expression.
38215 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
38216 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
38217
38218C...d, u, s part by simple charge factor.
38219 XPGA(1)=(1D0/9D0)*CGAM
38220 XPGA(2)=(4D0/9D0)*CGAM
38221 XPGA(3)=(1D0/9D0)*CGAM
38222
38223C...Also fill for antiquarks.
38224 DO 110 KF=1,5
38225 XPGA(-KF)=XPGA(KF)
38226 110 CONTINUE
38227
38228 RETURN
38229 END
38230
38231C*********************************************************************
38232
38233C...PYPDPI
38234C...Gives pi+ parton distribution according to two different
38235C...parametrizations.
38236
38237 SUBROUTINE PYPDPI(X,Q2,XPPI)
38238
38239C...Double precision and integer declarations.
38240 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38241 IMPLICIT INTEGER(I-N)
38242 INTEGER PYK,PYCHGE,PYCOMP
38243C...Commonblocks.
38244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38245 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38246 COMMON/PYINT1/MINT(400),VINT(400)
38247 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38248C...Local arrays.
38249 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
38250
38251C...The following data lines are coefficients needed in the
38252C...Owens pion parton distribution parametrizations, see below.
38253C...Expansion coefficients for up and down valence quark distributions.
38254 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
38255 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38256 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38257 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
38258 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
38259 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38260 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
38261 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
38262C...Expansion coefficients for gluon distribution.
38263 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
38264 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
38265 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
38266 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
38267 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
38268 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
38269 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
38270 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
38271C...Expansion coefficients for (up+down+strange) quark sea distribution.
38272 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
38273 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
38274 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
38275 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
38276 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
38277 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
38278 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
38279 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
38280C...Expansion coefficients for charm quark sea distribution.
38281 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
38282 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
38283 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
38284 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
38285 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
38286 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
38287 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
38288 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
38289
38290C...Euler's beta function, requires ordinary Gamma function
38291 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
38292
38293C...Reset output array.
38294 DO 100 KFL=-6,6
38295 XPPI(KFL)=0D0
38296 100 CONTINUE
38297
38298 IF(MSTP(53).LE.2) THEN
38299C...Pion parton distributions from Owens.
38300C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
38301
38302C...Determine set, Lambda and s expansion variable.
38303 NSET=MSTP(53)
38304 IF(NSET.EQ.1) ALAM=0.2D0
38305 IF(NSET.EQ.2) ALAM=0.4D0
38306 VINT(231)=4D0
38307 IF(MSTP(57).LE.0) THEN
38308 SD=0D0
38309 ELSE
38310 Q2IN=MIN(2D3,MAX(4D0,Q2))
38311 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
38312 ENDIF
38313
38314C...Calculate parton distributions.
38315 DO 120 KFL=1,4
38316 DO 110 IS=1,5
38317 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
38318 & COW(3,IS,KFL,NSET)*SD**2
38319 110 CONTINUE
38320 IF(KFL.EQ.1) THEN
38321 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
38322 ELSE
38323 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
38324 & TS(5)*X**2)
38325 ENDIF
38326 120 CONTINUE
38327
38328C...Put into output array.
38329 XPPI(0)=XQ(2)
38330 XPPI(1)=XQ(3)/6D0
38331 XPPI(2)=XQ(1)+XQ(3)/6D0
38332 XPPI(3)=XQ(3)/6D0
38333 XPPI(4)=XQ(4)
38334 XPPI(-1)=XQ(1)+XQ(3)/6D0
38335 XPPI(-2)=XQ(3)/6D0
38336 XPPI(-3)=XQ(3)/6D0
38337 XPPI(-4)=XQ(4)
38338
38339C...Leading order pion parton distributions from Glueck, Reya and Vogt.
38340C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
38341C...10^-5 < x < 1.
38342 ELSE
38343
38344C...Determine s expansion variable and some x expressions.
38345 VINT(231)=0.25D0
38346 IF(MSTP(57).LE.0) THEN
38347 SD=0D0
38348 ELSE
38349 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
38350 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
38351 ENDIF
38352 SD2=SD**2
38353 XL=-LOG(X)
38354 XS=SQRT(X)
38355
38356C...Evaluate valence, gluon and sea distributions.
38357 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
38358 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
38359 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
38360 & SD-0.175D0*SD2)+
38361 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
38362 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
38363 & XL)))*
38364 & (1D0-X)**(0.390D0+1.053D0*SD)
38365 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
38366 & X)**3.359D0*
38367 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
38368 & XL))/
38369 & XL**(2.538D0-0.763D0*SD)
38370 IF(SD.LE.0.888D0) THEN
38371 XFCHM=0D0
38372 ELSE
38373 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
38374 & 0.771D0*SD)*
38375 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
38376 & XL))
38377 ENDIF
38378 IF(SD.LE.1.351D0) THEN
38379 XFBOT=0D0
38380 ELSE
38381 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
38382 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
38383 & XL))
38384 ENDIF
38385
38386C...Put into output array.
38387 XPPI(0)=XFGLU
38388 XPPI(1)=XFSEA
38389 XPPI(2)=XFSEA
38390 XPPI(3)=XFSEA
38391 XPPI(4)=XFCHM
38392 XPPI(5)=XFBOT
38393 DO 130 KFL=1,5
38394 XPPI(-KFL)=XPPI(KFL)
38395 130 CONTINUE
38396 XPPI(2)=XPPI(2)+XFVAL
38397 XPPI(-1)=XPPI(-1)+XFVAL
38398 ENDIF
38399
38400 RETURN
38401 END
38402
38403C*********************************************************************
38404
38405C...PYPDPR
38406C...Gives proton parton distributions according to a few different
38407C...parametrizations.
38408
38409 SUBROUTINE PYPDPR(X,Q2,XPPR)
38410
38411C...Double precision and integer declarations.
38412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38413 IMPLICIT INTEGER(I-N)
38414 INTEGER PYK,PYCHGE,PYCOMP
38415C...Commonblocks.
38416 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38417 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38418 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38419 COMMON/PYINT1/MINT(400),VINT(400)
38420 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38421C...Arrays and data.
38422 DIMENSION XPPR(-6:6),Q2MIN(16)
38423 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
38424 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
38425
38426C...Reset output array.
38427 DO 100 KFL=-6,6
38428 XPPR(KFL)=0D0
38429 100 CONTINUE
38430
38431C...Common preliminaries.
38432 NSET=MAX(1,MIN(16,MSTP(51)))
38433 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
38434 VINT(231)=Q2MIN(NSET)
38435 IF(MSTP(57).EQ.0) THEN
38436 Q2L=Q2MIN(NSET)
38437 ELSE
38438 Q2L=MAX(Q2MIN(NSET),Q2)
38439 ENDIF
38440
38441 IF(NSET.GE.1.AND.NSET.LE.3) THEN
38442C...Interface to the CTEQ 3 parton distributions.
38443 QRT=SQRT(MAX(1D0,Q2L))
38444
38445C...Loop over flavours.
38446 DO 110 I=-6,6
38447 IF(I.LE.0) THEN
38448 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
38449 ELSEIF(I.LE.2) THEN
38450 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
38451 ELSE
38452 XPPR(I)=XPPR(-I)
38453 ENDIF
38454 110 CONTINUE
38455
38456 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
38457C...Interface to the GRV 94 distributions.
38458 IF(NSET.EQ.4) THEN
38459 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38460 ELSEIF(NSET.EQ.5) THEN
38461 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38462 ELSE
38463 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38464 ENDIF
38465
38466C...Put into output array.
38467 XPPR(0)=GL
38468 XPPR(-1)=0.5D0*(UDB+DEL)
38469 XPPR(-2)=0.5D0*(UDB-DEL)
38470 XPPR(-3)=SB
38471 XPPR(-4)=CHM
38472 XPPR(-5)=BOT
38473 XPPR(1)=DV+XPPR(-1)
38474 XPPR(2)=UV+XPPR(-2)
38475 XPPR(3)=SB
38476 XPPR(4)=CHM
38477 XPPR(5)=BOT
38478
38479 ELSEIF(NSET.EQ.7) THEN
38480C...Interface to the CTEQ 5L parton distributions.
38481C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
38482C...freezing x*f(x,Q2) at borders.
38483 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
38484 XIN=MAX(1D-6,MIN(1D0,X))
38485
38486C...Loop over flavours (with u <-> d notation mismatch).
38487 SUMUDB=PYCT5L(-1,XIN,QRT)
38488 RATUDB=PYCT5L(-2,XIN,QRT)
38489 DO 120 I=-5,2
38490 IF(I.EQ.1) THEN
38491 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
38492 ELSEIF(I.EQ.2) THEN
38493 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
38494 ELSEIF(I.EQ.-1) THEN
38495 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
38496 ELSEIF(I.EQ.-2) THEN
38497 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
38498 ELSE
38499 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
38500 IF(I.LT.0) XPPR(-I)=XPPR(I)
38501 ENDIF
38502 120 CONTINUE
38503
38504 ELSEIF(NSET.EQ.8) THEN
38505C...Interface to the CTEQ 5M1 parton distributions.
38506 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
38507 XIN=MAX(1D-6,MIN(1D0,X))
38508
38509C...Loop over flavours (with u <-> d notation mismatch).
38510 SUMUDB=PYCT5M(-1,XIN,QRT)
38511 RATUDB=PYCT5M(-2,XIN,QRT)
38512 DO 130 I=-5,2
38513 IF(I.EQ.1) THEN
38514 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
38515 ELSEIF(I.EQ.2) THEN
38516 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
38517 ELSEIF(I.EQ.-1) THEN
38518 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
38519 ELSEIF(I.EQ.-2) THEN
38520 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
38521 ELSE
38522 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
38523 IF(I.LT.0) XPPR(-I)=XPPR(I)
38524 ENDIF
38525 130 CONTINUE
38526
38527 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
38528C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
38529C...obsolete but offers backwards compatibility.
38530 CALL PYPDPO(X,Q2L,XPPR)
38531
38532C...Symmetric choice for debugging only
38533 ELSEIF(NSET.EQ.16) THEN
38534 XPPR(0)=.5D0/X
38535 XPPR(1)=.05D0/X
38536 XPPR(2)=.05D0/X
38537 XPPR(3)=.05D0/X
38538 XPPR(4)=.05D0/X
38539 XPPR(5)=.05D0/X
38540 XPPR(-1)=.05D0/X
38541 XPPR(-2)=.05D0/X
38542 XPPR(-3)=.05D0/X
38543 XPPR(-4)=.05D0/X
38544 XPPR(-5)=.05D0/X
38545
38546 ENDIF
38547
38548 RETURN
38549 END
38550
38551C*********************************************************************
38552
38553C...PYCTEQ
38554C...Gives the CTEQ 3 parton distribution function sets in
38555C...parametrized form, of October 24, 1994.
38556C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
38557C...J. Qiu, W.K. Tung and H. Weerts.
38558
38559 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
38560
38561C...Double precision declaration.
38562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38563 IMPLICIT INTEGER(I-N)
38564
38565C...Data on Lambda values of fits, minimum Q and quark masses.
38566 DIMENSION ALM(3), QMS(4:6)
38567 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
38568 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
38569
38570C....Check flavour thresholds. Set up QI for SB.
38571 IP = IABS(IPRT)
38572 IF(IP .GE. 4) THEN
38573 IF(Q .LE. QMS(IP)) THEN
38574 PYCTEQ = 0D0
38575 RETURN
38576 ENDIF
38577 QI = QMS(IP)
38578 ELSE
38579 QI = QMN
38580 ENDIF
38581
38582C...Use "standard lambda" of parametrization program for expansion.
38583 ALAM = ALM (ISET)
38584 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
38585 SB = LOG (SBL)
38586 SB2 = SB*SB
38587 SB3 = SB2*SB
38588
38589C...Expansion for CTEQ3L.
38590 IF(ISET .EQ. 1) THEN
38591 IF(IPRT .EQ. 2) THEN
38592 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
38593 & 0.3171D+00*SB3)
38594 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
38595 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
38596 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
38597 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
38598 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
38599 ELSEIF(IPRT .EQ. 1) THEN
38600 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
38601 & 0.7728D+00*SB3)
38602 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
38603 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
38604 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
38605 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
38606 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
38607 ELSEIF(IPRT .EQ. 0) THEN
38608 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
38609 & 0.5343D+00*SB3)
38610 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
38611 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
38612 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
38613 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
38614 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
38615 ELSEIF(IPRT .EQ. -1) THEN
38616 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
38617 & 0.2031D+01*SB3)
38618 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
38619 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
38620 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
38621 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
38622 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
38623 ELSEIF(IPRT .EQ. -2) THEN
38624 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
38625 & 0.9872D-01*SB3)
38626 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
38627 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
38628 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
38629 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
38630 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
38631 ELSEIF(IPRT .EQ. -3) THEN
38632 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
38633 & 0.8390D+00*SB3)
38634 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
38635 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
38636 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
38637 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
38638 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
38639 ELSEIF(IPRT .EQ. -4) THEN
38640 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
38641 & 0.1651D-01*SB2)
38642 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
38643 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
38644 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
38645 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
38646 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
38647 ELSEIF(IPRT .EQ. -5) THEN
38648 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
38649 & 0.3702D+01*SB2)
38650 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
38651 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
38652 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
38653 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
38654 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
38655 ELSEIF(IPRT .EQ. -6) THEN
38656 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
38657 & 0.6943D+00*SB2)
38658 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
38659 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
38660 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
38661 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
38662 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
38663 ENDIF
38664
38665C...Expansion for CTEQ3M.
38666 ELSEIF(ISET .EQ. 2) THEN
38667 IF(IPRT .EQ. 2) THEN
38668 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
38669 & 0.2935D+00*SB3)
38670 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
38671 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
38672 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
38673 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
38674 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
38675 ELSEIF(IPRT .EQ. 1) THEN
38676 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
38677 & 0.4305D-01*SB3)
38678 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
38679 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
38680 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
38681 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
38682 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
38683 ELSEIF(IPRT .EQ. 0) THEN
38684 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
38685 & 0.1037D-01*SB3)
38686 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
38687 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
38688 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
38689 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
38690 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
38691 ELSEIF(IPRT .EQ. -1) THEN
38692 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
38693 & 0.1602D+01*SB3)
38694 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
38695 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
38696 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
38697 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
38698 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
38699 ELSEIF(IPRT .EQ. -2) THEN
38700 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
38701 & 0.2496D+00*SB3)
38702 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
38703 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
38704 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
38705 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
38706 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
38707 ELSEIF(IPRT .EQ. -3) THEN
38708 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
38709 & 0.1936D+01*SB3)
38710 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
38711 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
38712 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
38713 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
38714 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
38715 ELSEIF(IPRT .EQ. -4) THEN
38716 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
38717 & 0.5348D+00*SB2)
38718 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
38719 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
38720 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
38721 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
38722 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
38723 ELSEIF(IPRT .EQ. -5) THEN
38724 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
38725 & 0.1569D+01*SB2)
38726 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
38727 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
38728 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
38729 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
38730 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
38731 ELSEIF(IPRT .EQ. -6) THEN
38732 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
38733 & 0.8838D+01*SB2)
38734 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
38735 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
38736 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
38737 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
38738 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
38739 ENDIF
38740
38741C...Expansion for CTEQ3D.
38742 ELSEIF(ISET .EQ. 3) THEN
38743 IF(IPRT .EQ. 2) THEN
38744 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
38745 & 0.2902D+00*SB3)
38746 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
38747 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
38748 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
38749 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
38750 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
38751 ELSEIF(IPRT .EQ. 1) THEN
38752 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
38753 & 0.7257D+00*SB3)
38754 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
38755 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
38756 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
38757 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
38758 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
38759 ELSEIF(IPRT .EQ. 0) THEN
38760 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
38761 & 0.2734D-04*SB3)
38762 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
38763 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
38764 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
38765 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
38766 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
38767 ELSEIF(IPRT .EQ. -1) THEN
38768 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
38769 & 0.1671D+01*SB3)
38770 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
38771 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
38772 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
38773 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
38774 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
38775 ELSEIF(IPRT .EQ. -2) THEN
38776 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
38777 & 0.2223D+00*SB3)
38778 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
38779 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
38780 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
38781 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
38782 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
38783 ELSEIF(IPRT .EQ. -3) THEN
38784 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
38785 & 0.1937D+01*SB3)
38786 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
38787 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
38788 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
38789 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
38790 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
38791 ELSEIF(IPRT .EQ. -4) THEN
38792 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
38793 & 0.5137D+00*SB2)
38794 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
38795 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
38796 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
38797 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
38798 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
38799 ELSEIF(IPRT .EQ. -5) THEN
38800 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
38801 & 0.2143D+01*SB2)
38802 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
38803 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
38804 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
38805 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
38806 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
38807 ELSEIF(IPRT .EQ. -6) THEN
38808 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
38809 & 0.9998D+01*SB2)
38810 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
38811 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
38812 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
38813 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
38814 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
38815 ENDIF
38816 ENDIF
38817
38818C...Calculation of x * f(x, Q).
38819 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
38820 & *(LOG(1D0+1D0/X))**A5 )
38821
38822 RETURN
38823 END
38824
38825C*********************************************************************
38826
38827C...PYGRVL
38828C...Gives the GRV 94 L (leading order) parton distribution function set
38829C...in parametrized form.
38830C...Authors: M. Glueck, E. Reya and A. Vogt.
38831
38832 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38833
38834C...Double precision declaration.
38835 IMPLICIT DOUBLE PRECISION (A - Z)
38836
38837C...Common expressions.
38838 MU2 = 0.23D0
38839 LAM2 = 0.2322D0 * 0.2322D0
38840 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38841 DS = SQRT (S)
38842 S2 = S * S
38843 S3 = S2 * S
38844
38845C...uv :
38846 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
38847 AKU = 0.590D0 - 0.024D0 * S
38848 BKU = 0.131D0 + 0.063D0 * S
38849 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
38850 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
38851 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
38852 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
38853 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
38854
38855C...dv :
38856 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
38857 AKD = 0.376D0
38858 BKD = 0.486D0 + 0.062D0 * S
38859 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
38860 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
38861 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
38862 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
38863 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
38864
38865C...del :
38866 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
38867 AKE = 0.409D0 - 0.005D0 * S
38868 BKE = 0.799D0 + 0.071D0 * S
38869 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
38870 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
38871 CE = 0.0D0
38872 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
38873 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
38874
38875C...udb :
38876 ALX = 1.451D0
38877 BEX = 0.271D0
38878 AKX = 0.410D0 - 0.232D0 * S
38879 BKX = 0.534D0 - 0.457D0 * S
38880 AGX = 0.890D0 - 0.140D0 * S
38881 BGX = -0.981D0
38882 CX = 0.320D0 + 0.683D0 * S
38883 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
38884 EX = 4.119D0 + 1.713D0 * S
38885 ESX = 0.682D0 + 2.978D0 * S
38886 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
38887 & DX, EX, ESX)
38888
38889C...sb :
38890 STS = 0D0
38891 ALS = 0.914D0
38892 BES = 0.577D0
38893 AKS = 1.798D0 - 0.596D0 * S
38894 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
38895 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
38896 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
38897 EST = 3.981D0 + 1.638D0 * S
38898 ESS = 6.402D0
38899 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
38900
38901C...cb :
38902 STC = 0.888D0
38903 ALC = 1.01D0
38904 BEC = 0.37D0
38905 AKC = 0D0
38906 AC = 0D0
38907 BC = 4.24D0 - 0.804D0 * S
38908 DCT = 3.46D0 - 1.076D0 * S
38909 ECT = 4.61D0 + 1.49D0 * S
38910 ESC = 2.555D0 + 1.961D0 * S
38911 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
38912
38913C...bb :
38914 STB = 1.351D0
38915 ALB = 1.00D0
38916 BEB = 0.51D0
38917 AKB = 0D0
38918 AB = 0D0
38919 BB = 1.848D0
38920 DBT = 2.929D0 + 1.396D0 * S
38921 EBT = 4.71D0 + 1.514D0 * S
38922 ESB = 4.02D0 + 1.239D0 * S
38923 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
38924
38925C...gl :
38926 ALG = 0.524D0
38927 BEG = 1.088D0
38928 AKG = 1.742D0 - 0.930D0 * S
38929 BKG = - 0.399D0 * S2
38930 AG = 7.486D0 - 2.185D0 * S
38931 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
38932 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
38933 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
38934 EG = 0.807D0 + 2.005D0 * S
38935 ESG = 3.841D0 + 0.316D0 * S
38936 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
38937 & DG, EG, ESG)
38938
38939 RETURN
38940 END
38941
38942C*********************************************************************
38943
38944C...PYGRVM
38945C...Gives the GRV 94 M (MSbar) parton distribution function set
38946C...in parametrized form.
38947C...Authors: M. Glueck, E. Reya and A. Vogt.
38948
38949 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
38950
38951C...Double precision declaration.
38952 IMPLICIT DOUBLE PRECISION (A - Z)
38953
38954C...Common expressions.
38955 MU2 = 0.34D0
38956 LAM2 = 0.248D0 * 0.248D0
38957 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
38958 DS = SQRT (S)
38959 S2 = S * S
38960 S3 = S2 * S
38961
38962C...uv :
38963 NU = 1.304D0 + 0.863D0 * S
38964 AKU = 0.558D0 - 0.020D0 * S
38965 BKU = 0.183D0 * S
38966 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
38967 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
38968 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
38969 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
38970 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
38971
38972C...dv :
38973 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
38974 AKD = 0.270D0 - 0.019D0 * S
38975 BKD = 0.260D0
38976 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
38977 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
38978 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
38979 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
38980 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
38981
38982C...del :
38983 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
38984 AKE = 0.409D0 - 0.007D0 * S
38985 BKE = 0.782D0 + 0.082D0 * S
38986 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
38987 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
38988 CE = 0.0D0
38989 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
38990 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
38991
38992C...udb :
38993 ALX = 0.877D0
38994 BEX = 0.561D0
38995 AKX = 0.275D0
38996 BKX = 0.0D0
38997 AGX = 0.997D0
38998 BGX = 3.210D0 - 1.866D0 * S
38999 CX = 7.300D0
39000 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39001 EX = 3.077D0 + 1.446D0 * S
39002 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39003 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39004 & DX, EX, ESX)
39005
39006C...sb :
39007 STS = 0D0
39008 ALS = 0.756D0
39009 BES = 0.216D0
39010 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39011 AS = -4.329D0 + 1.131D0 * S
39012 BS = 9.568D0 - 1.744D0 * S
39013 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39014 EST = 3.031D0 + 1.639D0 * S
39015 ESS = 5.837D0 + 0.815D0 * S
39016 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39017
39018C...cb :
39019 STC = 0.820D0
39020 ALC = 0.98D0
39021 BEC = 0D0
39022 AKC = -0.625D0 - 0.523D0 * S
39023 AC = 0D0
39024 BC = 1.896D0 + 1.616D0 * S
39025 DCT = 4.12D0 + 0.683D0 * S
39026 ECT = 4.36D0 + 1.328D0 * S
39027 ESC = 0.677D0 + 0.679D0 * S
39028 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39029
39030C...bb :
39031 STB = 1.297D0
39032 ALB = 0.99D0
39033 BEB = 0D0
39034 AKB = - 0.193D0 * S
39035 AB = 0D0
39036 BB = 0D0
39037 DBT = 3.447D0 + 0.927D0 * S
39038 EBT = 4.68D0 + 1.259D0 * S
39039 ESB = 1.892D0 + 2.199D0 * S
39040 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39041
39042C...gl :
39043 ALG = 1.014D0
39044 BEG = 1.738D0
39045 AKG = 1.724D0 + 0.157D0 * S
39046 BKG = 0.800D0 + 1.016D0 * S
39047 AG = 7.517D0 - 2.547D0 * S
39048 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39049 CG = 4.039D0 + 1.491D0 * S
39050 DG = 3.404D0 + 0.830D0 * S
39051 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39052 ESG = 3.256D0 - 0.436D0 * S
39053 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39054
39055 RETURN
39056 END
39057
39058C*********************************************************************
39059
39060C...PYGRVD
39061C...Gives the GRV 94 D (DIS) parton distribution function set
39062C...in parametrized form.
39063C...Authors: M. Glueck, E. Reya and A. Vogt.
39064
39065 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39066
39067C...Double precision declaration.
39068 IMPLICIT DOUBLE PRECISION (A - Z)
39069
39070C...Common expressions.
39071 MU2 = 0.34D0
39072 LAM2 = 0.248D0 * 0.248D0
39073 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39074 DS = SQRT (S)
39075 S2 = S * S
39076 S3 = S2 * S
39077
39078C...uv :
39079 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
39080 AKU = 0.563D0 - 0.025D0 * S
39081 BKU = 0.054D0 + 0.154D0 * S
39082 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
39083 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
39084 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
39085 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
39086 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39087
39088C...dv :
39089 ND = 0.156D0 - 0.017D0 * S
39090 AKD = 0.299D0 - 0.022D0 * S
39091 BKD = 0.259D0 - 0.015D0 * S
39092 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
39093 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
39094 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
39095 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
39096 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39097
39098C...del :
39099 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
39100 AKE = 0.419D0 - 0.013D0 * S
39101 BKE = 1.064D0 - 0.038D0 * S
39102 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
39103 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
39104 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
39105 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
39106 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39107
39108C...udb :
39109 ALX = 1.215D0
39110 BEX = 0.466D0
39111 AKX = 0.326D0 + 0.150D0 * S
39112 BKX = 0.956D0 + 0.405D0 * S
39113 AGX = 0.272D0
39114 BGX = 3.794D0 - 2.359D0 * DS
39115 CX = 2.014D0
39116 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
39117 EX = 3.049D0 + 1.597D0 * S
39118 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
39119 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39120 & DX, EX, ESX)
39121
39122C...sb :
39123 STS = 0D0
39124 ALS = 0.175D0
39125 BES = 0.344D0
39126 AKS = 1.415D0 - 0.641D0 * DS
39127 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
39128 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
39129 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
39130 EST = 4.546D0 + 0.372D0 * S2
39131 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
39132 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39133
39134C...cb :
39135 STC = 0.820D0
39136 ALC = 0.98D0
39137 BEC = 0D0
39138 AKC = -0.625D0 - 0.523D0 * S
39139 AC = 0D0
39140 BC = 1.896D0 + 1.616D0 * S
39141 DCT = 4.12D0 + 0.683D0 * S
39142 ECT = 4.36D0 + 1.328D0 * S
39143 ESC = 0.677D0 + 0.679D0 * S
39144 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39145
39146C...bb :
39147 STB = 1.297D0
39148 ALB = 0.99D0
39149 BEB = 0D0
39150 AKB = - 0.193D0 * S
39151 AB = 0D0
39152 BB = 0D0
39153 DBT = 3.447D0 + 0.927D0 * S
39154 EBT = 4.68D0 + 1.259D0 * S
39155 ESB = 1.892D0 + 2.199D0 * S
39156 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39157
39158C...gl :
39159 ALG = 1.258D0
39160 BEG = 1.846D0
39161 AKG = 2.423D0
39162 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
39163 AG = 25.09D0 - 7.935D0 * S
39164 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
39165 CG = 590.3D0 - 173.8D0 * S
39166 DG = 5.196D0 + 1.857D0 * S
39167 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
39168 ESG = 3.232D0 - 0.542D0 * S
39169 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39170
39171 RETURN
39172 END
39173
39174C*********************************************************************
39175
39176C...PYGRVV
39177C...Auxiliary for the GRV 94 parton distribution functions
39178C...for u and d valence and d-u sea.
39179C...Authors: M. Glueck, E. Reya and A. Vogt.
39180
39181 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
39182
39183C...Double precision declaration.
39184 IMPLICIT DOUBLE PRECISION (A - Z)
39185
39186C...Evaluation.
39187 DX = SQRT (X)
39188 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
39189 & (1D0- X)**D
39190
39191 RETURN
39192 END
39193
39194C*********************************************************************
39195
39196C...PYGRVW
39197C...Auxiliary for the GRV 94 parton distribution functions
39198C...for d+u sea and gluon.
39199C...Authors: M. Glueck, E. Reya and A. Vogt.
39200
39201 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
39202
39203C...Double precision declaration.
39204 IMPLICIT DOUBLE PRECISION (A - Z)
39205
39206C...Evaluation.
39207 LX = LOG (1D0/X)
39208 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
39209 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
39210
39211 RETURN
39212 END
39213
39214C*********************************************************************
39215
39216C...PYGRVS
39217C...Auxiliary for the GRV 94 parton distribution functions
39218C...for s, c and b sea.
39219C...Authors: M. Glueck, E. Reya and A. Vogt.
39220
39221 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
39222
39223C...Double precision declaration.
39224 IMPLICIT DOUBLE PRECISION (A - Z)
39225
39226C...Evaluation.
39227 IF(S.LE.STH) THEN
39228 PYGRVS = 0D0
39229 ELSE
39230 DX = SQRT (X)
39231 LX = LOG (1D0/X)
39232 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
39233 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
39234 ENDIF
39235
39236 RETURN
39237 END
39238
39239C*********************************************************************
39240
39241C...PYCT5L
39242C...Auxiliary function for parametrization of CTEQ5L.
39243C...Author: J. Pumplin 9/99.
39244
39245C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
39246C...in Parametrized Form
39247C... September 15, 1999
39248C
39249C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
39250C... CTEQ5 PPARTON DISTRIBUTIONS"
39251C...hep-ph/9903282
39252
39253C...The CTEQ5M1 set given here is an updated version of the original
39254C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
39255C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
39256C...almost all applications.
39257C...The improvement is in the QCD evolution which is now more
39258C...accurate, and which agrees completely with the benchmark work
39259C...of the HERA 96/97 Workshop.
39260C...The differences between the parametrized and the corresponding
39261C...table versions (on which it is based) are of similar order as
39262C...between the two version.
39263
39264C...!! Because accurate parametrizations over a wide range of (x,Q)
39265C...is hard to obtain, only the most widely used sets CTEQ5M and
39266C...CTEQ5L are available in parametrized form for now.
39267
39268C...These parametrizations were obtained by Jon Pumplin.
39269
39270C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
39271C -------------------------------------------------------------------
39272C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
39273C 3 CTEQ5L Leading Order 0.127 192 146
39274C -------------------------------------------------------------------
39275C...Note the Qcd-lambda values given for CTEQ5L is for the leading
39276C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
39277C...calibration.
39278
39279C...The two Iset value are adopted to agree with the standard table
39280C...versions.
39281
39282C...Range of validity:
39283C...The range of (x, Q) covered by this parametrization of the QCD
39284C...evolved parton distributions is 1E-6 < x < 1 ;
39285C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
39286C...data only in a subset of that region; and the assumed DGLAP
39287C...evolution is unlikely to be valid for all of it either.
39288
39289C...The range of (x, Q) used in the CTEQ5 round of global analysis is
39290C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
39291C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
39292C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
39293
39294 FUNCTION PYCT5L(IFL,X,Q)
39295
39296C...Double precision declaration.
39297 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39298 IMPLICIT INTEGER(I-N)
39299
39300 PARAMETER (NEX=8, NLF=2)
39301 DIMENSION AM(0:NEX,0:NLF,-5:2)
39302 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
39303 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
39304 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
39305 DIMENSION AF(0:NEX)
39306
39307 DATA MEXVEC( 2) / 8 /
39308 DATA MLFVEC( 2) / 2 /
39309 DATA UT1VEC( 2) / 0.4971265E+01 /
39310 DATA UT2VEC( 2) / -0.1105128E+01 /
39311 DATA ALFVEC( 2) / 0.2987216E+00 /
39312 DATA QMAVEC( 2) / 0.0000000E+00 /
39313 DATA (AM( 0,K, 2),K=0, 2)
39314 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
39315 DATA (AM( 1,K, 2),K=0, 2)
39316 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
39317 DATA (AM( 2,K, 2),K=0, 2)
39318 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
39319 DATA (AM( 3,K, 2),K=0, 2)
39320 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
39321 DATA (AM( 4,K, 2),K=0, 2)
39322 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
39323 DATA (AM( 5,K, 2),K=0, 2)
39324 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
39325 DATA (AM( 6,K, 2),K=0, 2)
39326 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
39327 DATA (AM( 7,K, 2),K=0, 2)
39328 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
39329 DATA (AM( 8,K, 2),K=0, 2)
39330 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
39331
39332 DATA MEXVEC( 1) / 8 /
39333 DATA MLFVEC( 1) / 2 /
39334 DATA UT1VEC( 1) / 0.2612618E+01 /
39335 DATA UT2VEC( 1) / -0.1258304E+06 /
39336 DATA ALFVEC( 1) / 0.3407552E+00 /
39337 DATA QMAVEC( 1) / 0.0000000E+00 /
39338 DATA (AM( 0,K, 1),K=0, 2)
39339 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
39340 DATA (AM( 1,K, 1),K=0, 2)
39341 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
39342 DATA (AM( 2,K, 1),K=0, 2)
39343 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
39344 DATA (AM( 3,K, 1),K=0, 2)
39345 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
39346 DATA (AM( 4,K, 1),K=0, 2)
39347 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
39348 DATA (AM( 5,K, 1),K=0, 2)
39349 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
39350 DATA (AM( 6,K, 1),K=0, 2)
39351 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
39352 DATA (AM( 7,K, 1),K=0, 2)
39353 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
39354 DATA (AM( 8,K, 1),K=0, 2)
39355 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
39356
39357 DATA MEXVEC( 0) / 8 /
39358 DATA MLFVEC( 0) / 2 /
39359 DATA UT1VEC( 0) / -0.4656819E+00 /
39360 DATA UT2VEC( 0) / -0.2742390E+03 /
39361 DATA ALFVEC( 0) / 0.4491863E+00 /
39362 DATA QMAVEC( 0) / 0.0000000E+00 /
39363 DATA (AM( 0,K, 0),K=0, 2)
39364 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
39365 DATA (AM( 1,K, 0),K=0, 2)
39366 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
39367 DATA (AM( 2,K, 0),K=0, 2)
39368 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
39369 DATA (AM( 3,K, 0),K=0, 2)
39370 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
39371 DATA (AM( 4,K, 0),K=0, 2)
39372 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
39373 DATA (AM( 5,K, 0),K=0, 2)
39374 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
39375 DATA (AM( 6,K, 0),K=0, 2)
39376 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
39377 DATA (AM( 7,K, 0),K=0, 2)
39378 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
39379 DATA (AM( 8,K, 0),K=0, 2)
39380 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
39381
39382 DATA MEXVEC(-1) / 8 /
39383 DATA MLFVEC(-1) / 2 /
39384 DATA UT1VEC(-1) / 0.3862583E+01 /
39385 DATA UT2VEC(-1) / -0.1265969E+01 /
39386 DATA ALFVEC(-1) / 0.2457668E+00 /
39387 DATA QMAVEC(-1) / 0.0000000E+00 /
39388 DATA (AM( 0,K,-1),K=0, 2)
39389 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
39390 DATA (AM( 1,K,-1),K=0, 2)
39391 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
39392 DATA (AM( 2,K,-1),K=0, 2)
39393 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
39394 DATA (AM( 3,K,-1),K=0, 2)
39395 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
39396 DATA (AM( 4,K,-1),K=0, 2)
39397 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
39398 DATA (AM( 5,K,-1),K=0, 2)
39399 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
39400 DATA (AM( 6,K,-1),K=0, 2)
39401 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
39402 DATA (AM( 7,K,-1),K=0, 2)
39403 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
39404 DATA (AM( 8,K,-1),K=0, 2)
39405 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
39406
39407 DATA MEXVEC(-2) / 7 /
39408 DATA MLFVEC(-2) / 2 /
39409 DATA UT1VEC(-2) / 0.1895615E+00 /
39410 DATA UT2VEC(-2) / -0.3069097E+01 /
39411 DATA ALFVEC(-2) / 0.5293999E+00 /
39412 DATA QMAVEC(-2) / 0.0000000E+00 /
39413 DATA (AM( 0,K,-2),K=0, 2)
39414 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
39415 DATA (AM( 1,K,-2),K=0, 2)
39416 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
39417 DATA (AM( 2,K,-2),K=0, 2)
39418 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
39419 DATA (AM( 3,K,-2),K=0, 2)
39420 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
39421 DATA (AM( 4,K,-2),K=0, 2)
39422 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
39423 DATA (AM( 5,K,-2),K=0, 2)
39424 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
39425 DATA (AM( 6,K,-2),K=0, 2)
39426 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
39427 DATA (AM( 7,K,-2),K=0, 2)
39428 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
39429
39430 DATA MEXVEC(-3) / 7 /
39431 DATA MLFVEC(-3) / 2 /
39432 DATA UT1VEC(-3) / 0.3753257E+01 /
39433 DATA UT2VEC(-3) / -0.1113085E+01 /
39434 DATA ALFVEC(-3) / 0.3713141E+00 /
39435 DATA QMAVEC(-3) / 0.0000000E+00 /
39436 DATA (AM( 0,K,-3),K=0, 2)
39437 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
39438 DATA (AM( 1,K,-3),K=0, 2)
39439 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
39440 DATA (AM( 2,K,-3),K=0, 2)
39441 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
39442 DATA (AM( 3,K,-3),K=0, 2)
39443 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
39444 DATA (AM( 4,K,-3),K=0, 2)
39445 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
39446 DATA (AM( 5,K,-3),K=0, 2)
39447 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
39448 DATA (AM( 6,K,-3),K=0, 2)
39449 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
39450 DATA (AM( 7,K,-3),K=0, 2)
39451 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
39452
39453 DATA MEXVEC(-4) / 7 /
39454 DATA MLFVEC(-4) / 2 /
39455 DATA UT1VEC(-4) / 0.4400772E+01 /
39456 DATA UT2VEC(-4) / -0.1356116E+01 /
39457 DATA ALFVEC(-4) / 0.3712017E-01 /
39458 DATA QMAVEC(-4) / 0.1300000E+01 /
39459 DATA (AM( 0,K,-4),K=0, 2)
39460 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
39461 DATA (AM( 1,K,-4),K=0, 2)
39462 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
39463 DATA (AM( 2,K,-4),K=0, 2)
39464 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
39465 DATA (AM( 3,K,-4),K=0, 2)
39466 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
39467 DATA (AM( 4,K,-4),K=0, 2)
39468 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
39469 DATA (AM( 5,K,-4),K=0, 2)
39470 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
39471 DATA (AM( 6,K,-4),K=0, 2)
39472 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
39473 DATA (AM( 7,K,-4),K=0, 2)
39474 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
39475
39476 DATA MEXVEC(-5) / 6 /
39477 DATA MLFVEC(-5) / 2 /
39478 DATA UT1VEC(-5) / 0.5562568E+01 /
39479 DATA UT2VEC(-5) / -0.1801317E+01 /
39480 DATA ALFVEC(-5) / 0.4952010E-02 /
39481 DATA QMAVEC(-5) / 0.4500000E+01 /
39482 DATA (AM( 0,K,-5),K=0, 2)
39483 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
39484 DATA (AM( 1,K,-5),K=0, 2)
39485 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
39486 DATA (AM( 2,K,-5),K=0, 2)
39487 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
39488 DATA (AM( 3,K,-5),K=0, 2)
39489 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
39490 DATA (AM( 4,K,-5),K=0, 2)
39491 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
39492 DATA (AM( 5,K,-5),K=0, 2)
39493 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
39494 DATA (AM( 6,K,-5),K=0, 2)
39495 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
39496
39497 IF(Q .LE. QMAVEC(IFL)) THEN
39498 PYCT5L = 0.D0
39499 RETURN
39500 ENDIF
39501
39502 IF(X .GE. 1.D0) THEN
39503 PYCT5L = 0.D0
39504 RETURN
39505 ENDIF
39506
39507 TMP = LOG(Q/ALFVEC(IFL))
39508 IF(TMP .LE. 0.D0) THEN
39509 PYCT5L = 0.D0
39510 RETURN
39511 ENDIF
39512
39513 SB = LOG(TMP)
39514 SB1 = SB - 1.2D0
39515 SB2 = SB1*SB1
39516
39517 DO 110 I = 0, NEX
39518 AF(I) = 0.D0
39519 SBX = 1.D0
39520 DO 100 K = 0, MLFVEC(IFL)
39521 AF(I) = AF(I) + SBX*AM(I,K,IFL)
39522 SBX = SB1*SBX
39523 100 CONTINUE
39524 110 CONTINUE
39525
39526 Y = -LOG(X)
39527 U = LOG(X/0.00001D0)
39528
39529 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
39530 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
39531 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
39532 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
39533 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
39534
39535 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
39536
39537C...Include threshold factor.
39538 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
39539
39540 RETURN
39541 END
39542
39543C*********************************************************************
39544
39545C...PYCT5M
39546C...Auxiliary function for parametrization of CTEQ5M1.
39547C...Author: J. Pumplin 9/99.
39548
39549 FUNCTION PYCT5M(IFL,X,Q)
39550
39551C...Double precision declaration.
39552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39553 IMPLICIT INTEGER(I-N)
39554
39555 PARAMETER (NEX=8, NLF=2)
39556 DIMENSION AM(0:NEX,0:NLF,-5:2)
39557 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
39558 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
39559 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
39560 DIMENSION AF(0:NEX)
39561
39562 DATA MEXVEC( 2) / 8 /
39563 DATA MLFVEC( 2) / 2 /
39564 DATA UT1VEC( 2) / 0.5141718E+01 /
39565 DATA UT2VEC( 2) / -0.1346944E+01 /
39566 DATA ALFVEC( 2) / 0.5260555E+00 /
39567 DATA QMAVEC( 2) / 0.0000000E+00 /
39568 DATA (AM( 0,K, 2),K=0, 2)
39569 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
39570 DATA (AM( 1,K, 2),K=0, 2)
39571 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
39572 DATA (AM( 2,K, 2),K=0, 2)
39573 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
39574 DATA (AM( 3,K, 2),K=0, 2)
39575 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
39576 DATA (AM( 4,K, 2),K=0, 2)
39577 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
39578 DATA (AM( 5,K, 2),K=0, 2)
39579 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
39580 DATA (AM( 6,K, 2),K=0, 2)
39581 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
39582 DATA (AM( 7,K, 2),K=0, 2)
39583 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
39584 DATA (AM( 8,K, 2),K=0, 2)
39585 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
39586
39587 DATA MEXVEC( 1) / 8 /
39588 DATA MLFVEC( 1) / 2 /
39589 DATA UT1VEC( 1) / 0.4138426E+01 /
39590 DATA UT2VEC( 1) / -0.3221374E+01 /
39591 DATA ALFVEC( 1) / 0.4960962E+00 /
39592 DATA QMAVEC( 1) / 0.0000000E+00 /
39593 DATA (AM( 0,K, 1),K=0, 2)
39594 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
39595 DATA (AM( 1,K, 1),K=0, 2)
39596 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
39597 DATA (AM( 2,K, 1),K=0, 2)
39598 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
39599 DATA (AM( 3,K, 1),K=0, 2)
39600 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
39601 DATA (AM( 4,K, 1),K=0, 2)
39602 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
39603 DATA (AM( 5,K, 1),K=0, 2)
39604 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
39605 DATA (AM( 6,K, 1),K=0, 2)
39606 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
39607 DATA (AM( 7,K, 1),K=0, 2)
39608 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
39609 DATA (AM( 8,K, 1),K=0, 2)
39610 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
39611
39612 DATA MEXVEC( 0) / 8 /
39613 DATA MLFVEC( 0) / 2 /
39614 DATA UT1VEC( 0) / -0.1026789E+01 /
39615 DATA UT2VEC( 0) / -0.9051707E+01 /
39616 DATA ALFVEC( 0) / 0.9462977E+00 /
39617 DATA QMAVEC( 0) / 0.0000000E+00 /
39618 DATA (AM( 0,K, 0),K=0, 2)
39619 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
39620 DATA (AM( 1,K, 0),K=0, 2)
39621 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
39622 DATA (AM( 2,K, 0),K=0, 2)
39623 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
39624 DATA (AM( 3,K, 0),K=0, 2)
39625 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
39626 DATA (AM( 4,K, 0),K=0, 2)
39627 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
39628 DATA (AM( 5,K, 0),K=0, 2)
39629 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
39630 DATA (AM( 6,K, 0),K=0, 2)
39631 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
39632 DATA (AM( 7,K, 0),K=0, 2)
39633 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
39634 DATA (AM( 8,K, 0),K=0, 2)
39635 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
39636
39637 DATA MEXVEC(-1) / 8 /
39638 DATA MLFVEC(-1) / 2 /
39639 DATA UT1VEC(-1) / 0.5243571E+01 /
39640 DATA UT2VEC(-1) / -0.2870513E+01 /
39641 DATA ALFVEC(-1) / 0.6701448E+00 /
39642 DATA QMAVEC(-1) / 0.0000000E+00 /
39643 DATA (AM( 0,K,-1),K=0, 2)
39644 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
39645 DATA (AM( 1,K,-1),K=0, 2)
39646 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
39647 DATA (AM( 2,K,-1),K=0, 2)
39648 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
39649 DATA (AM( 3,K,-1),K=0, 2)
39650 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
39651 DATA (AM( 4,K,-1),K=0, 2)
39652 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
39653 DATA (AM( 5,K,-1),K=0, 2)
39654 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
39655 DATA (AM( 6,K,-1),K=0, 2)
39656 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
39657 DATA (AM( 7,K,-1),K=0, 2)
39658 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
39659 DATA (AM( 8,K,-1),K=0, 2)
39660 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
39661
39662 DATA MEXVEC(-2) / 7 /
39663 DATA MLFVEC(-2) / 2 /
39664 DATA UT1VEC(-2) / 0.4782210E+01 /
39665 DATA UT2VEC(-2) / -0.1976856E+02 /
39666 DATA ALFVEC(-2) / 0.7558374E+00 /
39667 DATA QMAVEC(-2) / 0.0000000E+00 /
39668 DATA (AM( 0,K,-2),K=0, 2)
39669 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
39670 DATA (AM( 1,K,-2),K=0, 2)
39671 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
39672 DATA (AM( 2,K,-2),K=0, 2)
39673 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
39674 DATA (AM( 3,K,-2),K=0, 2)
39675 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
39676 DATA (AM( 4,K,-2),K=0, 2)
39677 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
39678 DATA (AM( 5,K,-2),K=0, 2)
39679 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
39680 DATA (AM( 6,K,-2),K=0, 2)
39681 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
39682 DATA (AM( 7,K,-2),K=0, 2)
39683 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
39684
39685 DATA MEXVEC(-3) / 7 /
39686 DATA MLFVEC(-3) / 2 /
39687 DATA UT1VEC(-3) / 0.4518239E+01 /
39688 DATA UT2VEC(-3) / -0.2690590E+01 /
39689 DATA ALFVEC(-3) / 0.6124079E+00 /
39690 DATA QMAVEC(-3) / 0.0000000E+00 /
39691 DATA (AM( 0,K,-3),K=0, 2)
39692 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
39693 DATA (AM( 1,K,-3),K=0, 2)
39694 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
39695 DATA (AM( 2,K,-3),K=0, 2)
39696 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
39697 DATA (AM( 3,K,-3),K=0, 2)
39698 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
39699 DATA (AM( 4,K,-3),K=0, 2)
39700 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
39701 DATA (AM( 5,K,-3),K=0, 2)
39702 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
39703 DATA (AM( 6,K,-3),K=0, 2)
39704 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
39705 DATA (AM( 7,K,-3),K=0, 2)
39706 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
39707
39708 DATA MEXVEC(-4) / 7 /
39709 DATA MLFVEC(-4) / 2 /
39710 DATA UT1VEC(-4) / 0.2783230E+01 /
39711 DATA UT2VEC(-4) / -0.1746328E+01 /
39712 DATA ALFVEC(-4) / 0.1115653E+01 /
39713 DATA QMAVEC(-4) / 0.1300000E+01 /
39714 DATA (AM( 0,K,-4),K=0, 2)
39715 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
39716 DATA (AM( 1,K,-4),K=0, 2)
39717 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
39718 DATA (AM( 2,K,-4),K=0, 2)
39719 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
39720 DATA (AM( 3,K,-4),K=0, 2)
39721 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
39722 DATA (AM( 4,K,-4),K=0, 2)
39723 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
39724 DATA (AM( 5,K,-4),K=0, 2)
39725 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
39726 DATA (AM( 6,K,-4),K=0, 2)
39727 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
39728 DATA (AM( 7,K,-4),K=0, 2)
39729 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
39730
39731 DATA MEXVEC(-5) / 6 /
39732 DATA MLFVEC(-5) / 2 /
39733 DATA UT1VEC(-5) / 0.1619654E+02 /
39734 DATA UT2VEC(-5) / -0.3367346E+01 /
39735 DATA ALFVEC(-5) / 0.5109891E-02 /
39736 DATA QMAVEC(-5) / 0.4500000E+01 /
39737 DATA (AM( 0,K,-5),K=0, 2)
39738 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
39739 DATA (AM( 1,K,-5),K=0, 2)
39740 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
39741 DATA (AM( 2,K,-5),K=0, 2)
39742 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
39743 DATA (AM( 3,K,-5),K=0, 2)
39744 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
39745 DATA (AM( 4,K,-5),K=0, 2)
39746 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
39747 DATA (AM( 5,K,-5),K=0, 2)
39748 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
39749 DATA (AM( 6,K,-5),K=0, 2)
39750 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
39751
39752 IF(Q .LE. QMAVEC(IFL)) THEN
39753 PYCT5M = 0.D0
39754 RETURN
39755 ENDIF
39756
39757 IF(X .GE. 1.D0) THEN
39758 PYCT5M = 0.D0
39759 RETURN
39760 ENDIF
39761
39762 TMP = LOG(Q/ALFVEC(IFL))
39763 IF(TMP .LE. 0.D0) THEN
39764 PYCT5M = 0.D0
39765 RETURN
39766 ENDIF
39767
39768 SB = LOG(TMP)
39769 SB1 = SB - 1.2D0
39770 SB2 = SB1*SB1
39771
39772 DO 110 I = 0, NEX
39773 AF(I) = 0.D0
39774 SBX = 1.D0
39775 DO 100 K = 0, MLFVEC(IFL)
39776 AF(I) = AF(I) + SBX*AM(I,K,IFL)
39777 SBX = SB1*SBX
39778 100 CONTINUE
39779 110 CONTINUE
39780
39781 Y = -LOG(X)
39782 U = LOG(X/0.00001D0)
39783
39784 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
39785 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
39786 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
39787 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
39788 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
39789
39790 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
39791
39792C...Include threshold factor.
39793 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
39794
39795 RETURN
39796 END
39797
39798C*********************************************************************
39799
39800C...PYPDPO
39801C...Auxiliary to PYPDPR. Gives proton parton distributions according to
39802C...a few older parametrizations, now obsolete but convenient for
39803C...backwards checks.
39804
39805 SUBROUTINE PYPDPO(X,Q2,XPPR)
39806
39807C...Double precision and integer declarations.
39808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39809 IMPLICIT INTEGER(I-N)
39810 INTEGER PYK,PYCHGE,PYCOMP
39811C...Commonblocks.
39812 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39813 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39814 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39815 COMMON/PYINT1/MINT(400),VINT(400)
39816 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39817 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
39818 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
39819
39820
39821C...The following data lines are coefficients needed in the
39822C...Eichten, Hinchliffe, Lane, Quigg proton structure function
39823C...parametrizations, see below.
39824C...Powers of 1-x in different cases.
39825 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
39826C...Expansion coefficients for up valence quark distribution.
39827 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
39828 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
39829 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
39830 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
39831 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
39832 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
39833 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
39834 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
39835 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
39836 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
39837 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
39838 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
39839 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
39840 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
39841 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
39842 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
39843 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
39844 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
39845 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
39846 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
39847 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
39848 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
39849 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
39850 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
39851 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
39852 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
39853C...Expansion coefficients for down valence quark distribution.
39854 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
39855 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
39856 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
39857 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
39858 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
39859 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
39860 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
39861 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
39862 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
39863 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
39864 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
39865 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
39866 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
39867 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
39868 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
39869 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
39870 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
39871 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
39872 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
39873 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
39874 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
39875 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
39876 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
39877 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
39878 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
39879 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
39880C...Expansion coefficients for up and down sea quark distributions.
39881 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
39882 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
39883 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
39884 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
39885 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
39886 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
39887 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
39888 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
39889 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
39890 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
39891 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
39892 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
39893 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
39894 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
39895 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
39896 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
39897 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
39898 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
39899 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
39900 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
39901 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
39902 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
39903 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
39904 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
39905 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
39906 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
39907C...Expansion coefficients for gluon distribution.
39908 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
39909 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
39910 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
39911 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
39912 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
39913 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
39914 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
39915 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
39916 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
39917 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
39918 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
39919 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
39920 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
39921 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
39922 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
39923 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
39924 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
39925 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
39926 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
39927 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
39928 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
39929 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
39930 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
39931 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
39932 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
39933 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
39934C...Expansion coefficients for strange sea quark distribution.
39935 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
39936 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
39937 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
39938 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
39939 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
39940 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
39941 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
39942 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
39943 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
39944 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
39945 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
39946 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
39947 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
39948 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
39949 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
39950 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
39951 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
39952 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
39953 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
39954 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
39955 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
39956 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
39957 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
39958 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
39959 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
39960 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
39961C...Expansion coefficients for charm sea quark distribution.
39962 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
39963 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
39964 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
39965 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
39966 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
39967 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
39968 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
39969 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
39970 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
39971 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
39972 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
39973 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
39974 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
39975 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
39976 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
39977 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
39978 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
39979 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
39980 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
39981 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
39982 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
39983 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
39984 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
39985 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
39986 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
39987 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
39988C...Expansion coefficients for bottom sea quark distribution.
39989 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
39990 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
39991 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
39992 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
39993 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
39994 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
39995 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
39996 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
39997 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
39998 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
39999 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40000 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40001 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40002 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40003 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40004 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40005 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40006 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40007 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40008 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40009 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40010 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40011 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40012 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40013 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40014 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40015C...Expansion coefficients for top sea quark distribution.
40016 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40017 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40018 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40019 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40020 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40021 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40022 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40023 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40024 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40025 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40026 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40027 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40028 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40029 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40030 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40031 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40032 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40033 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40034 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40035 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40036 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40037 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40038 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40039 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40040 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40041 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40042
40043C...The following data lines are coefficients needed in the
40044C...Duke, Owens proton structure function parametrizations, see below.
40045C...Expansion coefficients for (up+down) valence quark distribution.
40046 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40047 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40048 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40049 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40050 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40051 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40052 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40053 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40054C...Expansion coefficients for down valence quark distribution.
40055 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40056 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40057 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40058 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40059 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40060 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40061 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40062 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40063C...Expansion coefficients for (up+down+strange) sea quark distribution.
40064 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40065 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40066 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40067 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
40068 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
40069 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40070 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
40071 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
40072C...Expansion coefficients for charm sea quark distribution.
40073 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
40074 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40075 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
40076 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
40077 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
40078 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40079 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
40080 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
40081C...Expansion coefficients for gluon distribution.
40082 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
40083 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40084 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
40085 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
40086 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
40087 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40088 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
40089 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
40090
40091C...Euler's beta function, requires ordinary Gamma function
40092 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40093
40094C...Leading order proton parton distributions from Glueck, Reya and
40095C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40096C...10^-5 < x < 1.
40097 IF(MSTP(51).EQ.11) THEN
40098
40099C...Determine s expansion variable and some x expressions.
40100 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40101 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40102 SD2=SD**2
40103 XL=-LOG(X)
40104 XS=SQRT(X)
40105
40106C...Evaluate valence, gluon and sea distributions.
40107 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
40108 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
40109 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
40110 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
40111 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
40112 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
40113 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
40114 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
40115 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
40116 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
40117 & SQRT(4.066D0*SD**1.218D0*XL)))*
40118 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
40119 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
40120 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
40121 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
40122 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
40123 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
40124 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
40125 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
40126 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
40127 IF(SD.LE.0.888D0) THEN
40128 XFCHM=0D0
40129 ELSE
40130 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
40131 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
40132 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
40133 ENDIF
40134 IF(SD.LE.1.351D0) THEN
40135 XFBOT=0D0
40136 ELSE
40137 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
40138 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
40139 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
40140 ENDIF
40141
40142C...Put into output array.
40143 XPPR(0)=XFGLU
40144 XPPR(1)=XFVDD+XFSEA
40145 XPPR(2)=XFVUD-XFVDD+XFSEA
40146 XPPR(3)=XFSTR
40147 XPPR(4)=XFCHM
40148 XPPR(5)=XFBOT
40149 XPPR(-1)=XFSEA
40150 XPPR(-2)=XFSEA
40151 XPPR(-3)=XFSTR
40152 XPPR(-4)=XFCHM
40153 XPPR(-5)=XFBOT
40154
40155C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
40156C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
40157 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
40158
40159C...Determine set, Lambda and x and t expansion variables.
40160 NSET=MSTP(51)-11
40161 IF(NSET.EQ.1) ALAM=0.2D0
40162 IF(NSET.EQ.2) ALAM=0.29D0
40163 TMIN=LOG(5D0/ALAM**2)
40164 TMAX=LOG(1D8/ALAM**2)
40165 T=LOG(MAX(1D0,Q2/ALAM**2))
40166 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
40167 NX=1
40168 IF(X.LE.0.1D0) NX=2
40169 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
40170 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
40171
40172C...Chebyshev polynomials for x and t expansion.
40173 TX(1)=1D0
40174 TX(2)=VX
40175 TX(3)=2D0*VX**2-1D0
40176 TX(4)=4D0*VX**3-3D0*VX
40177 TX(5)=8D0*VX**4-8D0*VX**2+1D0
40178 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
40179 TT(1)=1D0
40180 TT(2)=VT
40181 TT(3)=2D0*VT**2-1D0
40182 TT(4)=4D0*VT**3-3D0*VT
40183 TT(5)=8D0*VT**4-8D0*VT**2+1D0
40184 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
40185
40186C...Calculate structure functions.
40187 DO 120 KFL=1,6
40188 XQSUM=0D0
40189 DO 110 IT=1,6
40190 DO 100 IX=1,6
40191 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
40192 100 CONTINUE
40193 110 CONTINUE
40194 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
40195 120 CONTINUE
40196
40197C...Put into output array.
40198 XPPR(0)=XQ(4)
40199 XPPR(1)=XQ(2)+XQ(3)
40200 XPPR(2)=XQ(1)+XQ(3)
40201 XPPR(3)=XQ(5)
40202 XPPR(4)=XQ(6)
40203 XPPR(-1)=XQ(3)
40204 XPPR(-2)=XQ(3)
40205 XPPR(-3)=XQ(5)
40206 XPPR(-4)=XQ(6)
40207
40208C...Special expansion for bottom (threshold effects).
40209 IF(MSTP(58).GE.5) THEN
40210 IF(NSET.EQ.1) TMIN=8.1905D0
40211 IF(NSET.EQ.2) TMIN=7.4474D0
40212 IF(T.GT.TMIN) THEN
40213 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
40214 TT(1)=1D0
40215 TT(2)=VT
40216 TT(3)=2D0*VT**2-1D0
40217 TT(4)=4D0*VT**3-3D0*VT
40218 TT(5)=8D0*VT**4-8D0*VT**2+1D0
40219 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
40220 XQSUM=0D0
40221 DO 140 IT=1,6
40222 DO 130 IX=1,6
40223 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
40224 130 CONTINUE
40225 140 CONTINUE
40226 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
40227 XPPR(-5)=XPPR(5)
40228 ENDIF
40229 ENDIF
40230
40231C...Special expansion for top (threshold effects).
40232 IF(MSTP(58).GE.6) THEN
40233 IF(NSET.EQ.1) TMIN=11.5528D0
40234 IF(NSET.EQ.2) TMIN=10.8097D0
40235 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
40236 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
40237 IF(T.GT.TMIN) THEN
40238 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
40239 TT(1)=1D0
40240 TT(2)=VT
40241 TT(3)=2D0*VT**2-1D0
40242 TT(4)=4D0*VT**3-3D0*VT
40243 TT(5)=8D0*VT**4-8D0*VT**2+1D0
40244 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
40245 XQSUM=0D0
40246 DO 160 IT=1,6
40247 DO 150 IX=1,6
40248 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
40249 150 CONTINUE
40250 160 CONTINUE
40251 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
40252 XPPR(-6)=XPPR(6)
40253 ENDIF
40254 ENDIF
40255
40256C...Proton parton distributions from Duke, Owens.
40257C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
40258 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
40259
40260C...Determine set, Lambda and s expansion parameter.
40261 NSET=MSTP(51)-13
40262 IF(NSET.EQ.1) ALAM=0.2D0
40263 IF(NSET.EQ.2) ALAM=0.4D0
40264 Q2IN=MIN(1D6,MAX(4D0,Q2))
40265 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40266
40267C...Calculate structure functions.
40268 DO 180 KFL=1,5
40269 DO 170 IS=1,6
40270 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
40271 & CDO(3,IS,KFL,NSET)*SD**2
40272 170 CONTINUE
40273 IF(KFL.LE.2) THEN
40274 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
40275 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
40276 ELSE
40277 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40278 & TS(5)*X**2+TS(6)*X**3)
40279 ENDIF
40280 180 CONTINUE
40281
40282C...Put into output arrays.
40283 XPPR(0)=XQ(5)
40284 XPPR(1)=XQ(2)+XQ(3)/6D0
40285 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
40286 XPPR(3)=XQ(3)/6D0
40287 XPPR(4)=XQ(4)
40288 XPPR(-1)=XQ(3)/6D0
40289 XPPR(-2)=XQ(3)/6D0
40290 XPPR(-3)=XQ(3)/6D0
40291 XPPR(-4)=XQ(4)
40292
40293 ENDIF
40294
40295 RETURN
40296 END
40297
40298C*********************************************************************
40299
40300C...PYHFTH
40301C...Gives threshold attractive/repulsive factor for heavy flavour
40302C...production.
40303
40304 FUNCTION PYHFTH(SH,SQM,FRATT)
40305
40306C...Double precision and integer declarations.
40307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40308 IMPLICIT INTEGER(I-N)
40309 INTEGER PYK,PYCHGE,PYCOMP
40310C...Commonblocks.
40311 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40312 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40313 COMMON/PYINT1/MINT(400),VINT(400)
40314 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40315
40316C...Value for alpha_strong.
40317 IF(MSTP(35).LE.1) THEN
40318 ALSSG=PARP(35)
40319 ELSE
40320 MST115=MSTU(115)
40321 MSTU(115)=MSTP(36)
40322 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
40323 & PARP(36)**2)))
40324 ALSSG=PYALPS(Q2BN)
40325 MSTU(115)=MST115
40326 ENDIF
40327
40328C...Evaluate attractive and repulsive factors.
40329 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
40330 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
40331 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
40332 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
40333 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
40334 VINT(138)=PYHFTH
40335
40336 RETURN
40337 END
40338
40339C*********************************************************************
40340
40341C...PYSPLI
40342C...Splits a hadron remnant into two (partons or hadron + parton)
40343C...in case it is more complicated than just a quark or a diquark.
40344
40345 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
40346
40347C...Double precision and integer declarations.
40348 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40349 IMPLICIT INTEGER(I-N)
40350 INTEGER PYK,PYCHGE,PYCOMP
40351C...Commonblocks. PYDAT1 temporary
40352 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40353 COMMON/PYINT1/MINT(400),VINT(400)
40354 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40355 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
40356C...Local array.
40357 DIMENSION KFL(3)
40358
40359C...Preliminaries. Parton composition.
40360 KFA=IABS(KF)
40361 KFS=ISIGN(1,KF)
40362 KFL(1)=MOD(KFA/1000,10)
40363 KFL(2)=MOD(KFA/100,10)
40364 KFL(3)=MOD(KFA/10,10)
40365 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
40366 KFL(2)=INT(1.5D0+PYR(0))
40367 IF(MINT(105).EQ.333) KFL(2)=3
40368 IF(MINT(105).EQ.443) KFL(2)=4
40369 KFL(3)=KFL(2)
40370 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
40371 KFL(2)=2
40372 KFL(3)=2
40373 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
40374 KFL(2)=1
40375 KFL(3)=1
40376 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
40377 KFL(2)=MOD(KFA/10,10)
40378 KFL(3)=MOD(KFA/100,10)
40379 ENDIF
40380 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
40381 KFLR=KFLIN*KFS
40382 ELSE
40383 KFLR=KFLIN
40384 ENDIF
40385 KFLCH=0
40386
40387C...Subdivide lepton.
40388 IF(KFA.GE.11.AND.KFA.LE.18) THEN
40389 IF(KFLR.EQ.KFA) THEN
40390 KFLSP=KFS*22
40391 ELSEIF(KFLR.EQ.22) THEN
40392 KFLSP=KFA
40393 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
40394 KFLSP=KFA+1
40395 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
40396 KFLSP=KFA-1
40397 ELSEIF(KFLR.EQ.21) THEN
40398 KFLSP=KFA
40399 KFLCH=KFS*21
40400 ELSE
40401 KFLSP=KFA
40402 KFLCH=-KFLR
40403 ENDIF
40404
40405C...Subdivide photon.
40406 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
40407 IF(KFLR.NE.21) THEN
40408 KFLSP=-KFLR
40409 ELSE
40410 RAGR=0.75D0*PYR(0)
40411 KFLSP=1
40412 IF(RAGR.GT.0.125D0) KFLSP=2
40413 IF(RAGR.GT.0.625D0) KFLSP=3
40414 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
40415 KFLCH=-KFLSP
40416 ENDIF
40417
40418C...Subdivide Reggeon or Pomeron.
40419 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
40420 IF(KFLIN.EQ.21) THEN
40421 KFLSP=KFS*21
40422 ELSE
40423 KFLSP=-KFLIN
40424 ENDIF
40425
40426C...Subdivide meson.
40427 ELSEIF(KFL(1).EQ.0) THEN
40428 KFL(2)=KFL(2)*(-1)**KFL(2)
40429 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
40430 IF(KFLR.EQ.KFL(2)) THEN
40431 KFLSP=KFL(3)
40432 ELSEIF(KFLR.EQ.KFL(3)) THEN
40433 KFLSP=KFL(2)
40434 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
40435 KFLSP=KFL(2)
40436 KFLCH=KFL(3)
40437 ELSEIF(KFLR.EQ.21) THEN
40438 KFLSP=KFL(3)
40439 KFLCH=KFL(2)
40440 ELSEIF(KFLR*KFL(2).GT.0) THEN
40441 NTRY=0
40442 100 NTRY=NTRY+1
40443 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
40444 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40445 GOTO 100
40446 ELSEIF(KFLCH.EQ.0) THEN
40447 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40448 MINT(51)=1
40449 RETURN
40450 ENDIF
40451 KFLSP=KFL(3)
40452 ELSE
40453 NTRY=0
40454 110 NTRY=NTRY+1
40455 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
40456 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40457 GOTO 110
40458 ELSEIF(KFLCH.EQ.0) THEN
40459 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40460 MINT(51)=1
40461 RETURN
40462 ENDIF
40463 KFLSP=KFL(2)
40464 ENDIF
40465
40466C...Subdivide baryon.
40467 ELSE
40468 NAGR=0
40469 DO 120 J=1,3
40470 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
40471 120 CONTINUE
40472 IF(NAGR.GE.1) THEN
40473 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
40474 IAGR=0
40475 DO 130 J=1,3
40476 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
40477 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
40478 130 CONTINUE
40479 ELSE
40480 IAGR=1.00001D0+2.99998D0*PYR(0)
40481 ENDIF
40482 ID1=1
40483 IF(IAGR.EQ.1) ID1=2
40484 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
40485 ID2=6-IAGR-ID1
40486 KSP=3
40487 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
40488 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
40489 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
40490 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
40491 ELSEIF(MOD(KFA,10).EQ.2) THEN
40492 IF(IAGR.EQ.1) KSP=1
40493 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
40494 ENDIF
40495 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
40496 IF(KFLR.EQ.21) THEN
40497 KFLCH=KFL(IAGR)
40498 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
40499 NTRY=0
40500 140 NTRY=NTRY+1
40501 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
40502 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40503 GOTO 140
40504 ELSEIF(KFLCH.EQ.0) THEN
40505 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40506 MINT(51)=1
40507 RETURN
40508 ENDIF
40509 ELSEIF(NAGR.EQ.0) THEN
40510 NTRY=0
40511 150 NTRY=NTRY+1
40512 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
40513 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
40514 GOTO 150
40515 ELSEIF(KFLCH.EQ.0) THEN
40516 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
40517 MINT(51)=1
40518 RETURN
40519 ENDIF
40520 KFLSP=KFL(IAGR)
40521 ENDIF
40522 ENDIF
40523
40524C...Add on correct sign for result.
40525 KFLCH=KFLCH*KFS
40526 KFLSP=KFLSP*KFS
40527
40528 RETURN
40529 END
40530
40531C*********************************************************************
40532
40533C...PYGAMM
40534C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
40535C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
40536C...(Dover, 1965) 6.1.36.
40537
40538 FUNCTION PYGAMM(X)
40539
40540C...Double precision and integer declarations.
40541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40542 IMPLICIT INTEGER(I-N)
40543 INTEGER PYK,PYCHGE,PYCOMP
40544C...Local array and data.
40545 DIMENSION B(8)
40546 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
40547 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
40548
40549 NX=INT(X)
40550 DX=X-NX
40551
40552 PYGAMM=1D0
40553 DXP=1D0
40554 DO 100 I=1,8
40555 DXP=DXP*DX
40556 PYGAMM=PYGAMM+B(I)*DXP
40557 100 CONTINUE
40558 IF(X.LT.1D0) THEN
40559 PYGAMM=PYGAMM/X
40560 ELSE
40561 DO 110 IX=1,NX-1
40562 PYGAMM=(X-IX)*PYGAMM
40563 110 CONTINUE
40564 ENDIF
40565
40566 RETURN
40567 END
40568
40569C***********************************************************************
40570
40571C...PYWAUX
40572C...Calculates real and imaginary parts of the auxiliary functions W1
40573C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
40574C...der Bij, Nucl. Phys. B297 (1988) 221.
40575
40576 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
40577
40578C...Double precision and integer declarations.
40579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40580 IMPLICIT INTEGER(I-N)
40581 INTEGER PYK,PYCHGE,PYCOMP
40582C...Commonblocks.
40583 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40584 SAVE /PYDAT1/
40585
40586 ASINH(X)=LOG(X+SQRT(X**2+1D0))
40587 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
40588
40589 IF(EPS.LT.0D0) THEN
40590 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
40591 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
40592 WIM=0D0
40593 ELSEIF(EPS.LT.1D0) THEN
40594 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
40595 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
40596 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
40597 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
40598 ELSE
40599 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
40600 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
40601 WIM=0D0
40602 ENDIF
40603
40604 RETURN
40605 END
40606
40607C***********************************************************************
40608
40609C...PYI3AU
40610C...Calculates real and imaginary parts of the auxiliary function I3;
40611C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
40612C...Nucl. Phys. B297 (1988) 221.
40613
40614 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
40615
40616C...Double precision and integer declarations.
40617 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40618 IMPLICIT INTEGER(I-N)
40619 INTEGER PYK,PYCHGE,PYCOMP
40620C...Commonblocks.
40621 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40622 SAVE /PYDAT1/
40623
40624 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
40625 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
40626
40627 IF(EPS.LT.0D0) THEN
40628 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40629 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
40630 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
40631 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
40632 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
40633 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
40634 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
40635 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
40636 & EPS))
40637 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
40638 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
40639 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
40640 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
40641 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
40642 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
40643 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
40644 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
40645 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40646 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
40647 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
40648 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
40649 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
40650 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
40651 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
40652 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
40653 ELSE
40654 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
40655 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
40656 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
40657 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
40658 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
40659 ENDIF
40660 F3IM=0D0
40661 ELSEIF(EPS.LT.1D0) THEN
40662 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40663 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
40664 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
40665 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
40666 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
40667 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
40668 & (0.25D0*(RAT+1D0)*EPS))
40669 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
40670 & (0.25D0*(RAT+1D0)*EPS))
40671 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
40672 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
40673 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
40674 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
40675 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
40676 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
40677 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
40678 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
40679 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
40680 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
40681 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
40682 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
40683 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
40684 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
40685 & (1D0+0.25D0*RAT*EPS-GA))
40686 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
40687 & (1D0+0.25D0*RAT*EPS-GA))
40688 ELSE
40689 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
40690 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
40691 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
40692 & LOG((GA+BE-1D0)/(BE-GA))
40693 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
40694 ENDIF
40695 ELSE
40696 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
40697 RCTHE=RSQ*(1D0-2D0*BE/EPS)
40698 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
40699 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
40700 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
40701 R=SQRT(RSQ)
40702 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
40703 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
40704 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
40705 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
40706 & (PHI-THE)*(PHI+THE-PARU(1))
40707 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
40708 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
40709 ENDIF
40710
40711 Y3RE=2D0/(2D0*BE-1D0)*F3RE
40712 Y3IM=2D0/(2D0*BE-1D0)*F3IM
40713
40714 RETURN
40715 END
40716
40717C***********************************************************************
40718
40719C...PYSPEN
40720C...Calculates real and imaginary part of Spence function; see
40721C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
40722
40723 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
40724
40725C...Double precision and integer declarations.
40726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40727 IMPLICIT INTEGER(I-N)
40728 INTEGER PYK,PYCHGE,PYCOMP
40729C...Commonblocks.
40730 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40731 SAVE /PYDAT1/
40732C...Local array and data.
40733 DIMENSION B(0:14)
40734 DATA B/
40735 &1.000000D+00, -5.000000D-01, 1.666667D-01,
40736 &0.000000D+00, -3.333333D-02, 0.000000D+00,
40737 &2.380952D-02, 0.000000D+00, -3.333333D-02,
40738 &0.000000D+00, 7.575757D-02, 0.000000D+00,
40739 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
40740
40741 XRE=XREIN
40742 XIM=XIMIN
40743 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
40744 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
40745 IF(IREIM.EQ.2) PYSPEN=0D0
40746 RETURN
40747 ENDIF
40748
40749 XMOD=SQRT(XRE**2+XIM**2)
40750 IF(XMOD.LT.1D-6) THEN
40751 IF(IREIM.EQ.1) PYSPEN=0D0
40752 IF(IREIM.EQ.2) PYSPEN=0D0
40753 RETURN
40754 ENDIF
40755
40756 XARG=SIGN(ACOS(XRE/XMOD),XIM)
40757 SP0RE=0D0
40758 SP0IM=0D0
40759 SGN=1D0
40760 IF(XMOD.GT.1D0) THEN
40761 ALGXRE=LOG(XMOD)
40762 ALGXIM=XARG-SIGN(PARU(1),XARG)
40763 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
40764 SP0IM=-ALGXRE*ALGXIM
40765 SGN=-1D0
40766 XMOD=1D0/XMOD
40767 XARG=-XARG
40768 XRE=XMOD*COS(XARG)
40769 XIM=XMOD*SIN(XARG)
40770 ENDIF
40771 IF(XRE.GT.0.5D0) THEN
40772 ALGXRE=LOG(XMOD)
40773 ALGXIM=XARG
40774 XRE=1D0-XRE
40775 XIM=-XIM
40776 XMOD=SQRT(XRE**2+XIM**2)
40777 XARG=SIGN(ACOS(XRE/XMOD),XIM)
40778 ALGYRE=LOG(XMOD)
40779 ALGYIM=XARG
40780 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
40781 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
40782 SGN=-SGN
40783 ENDIF
40784
40785 XRE=1D0-XRE
40786 XIM=-XIM
40787 XMOD=SQRT(XRE**2+XIM**2)
40788 XARG=SIGN(ACOS(XRE/XMOD),XIM)
40789 ZRE=-LOG(XMOD)
40790 ZIM=-XARG
40791
40792 SPRE=0D0
40793 SPIM=0D0
40794 SAVERE=1D0
40795 SAVEIM=0D0
40796 DO 100 I=0,14
40797 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
40798 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
40799 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
40800 SAVERE=TERMRE
40801 SAVEIM=TERMIM
40802 SPRE=SPRE+B(I)*TERMRE
40803 SPIM=SPIM+B(I)*TERMIM
40804 100 CONTINUE
40805
40806 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
40807 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
40808
40809 RETURN
40810 END
40811
40812C***********************************************************************
40813
40814C...PYQQBH
40815C...Calculates the matrix element for the processes
40816C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
40817C...REDUCE output and part of the rest courtesy Z. Kunszt, see
40818C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
40819
40820 SUBROUTINE PYQQBH(WTQQBH)
40821
40822C...Double precision and integer declarations.
40823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40824 IMPLICIT INTEGER(I-N)
40825 INTEGER PYK,PYCHGE,PYCOMP
40826C...Commonblocks.
40827 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40828 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40829 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40830 COMMON/PYINT1/MINT(400),VINT(400)
40831 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
40832 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
40833C...Local arrays and function.
40834 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
40835 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
40836 &PP(I,3)*PP(J,3)
40837
40838C...Mass parameters.
40839 WTQQBH=0D0
40840 ISUB=MINT(1)
40841 SHPR=SQRT(VINT(26))*VINT(1)
40842 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
40843 PH=SQRT(VINT(21))*VINT(1)
40844 SPQ=PQ**2
40845 SPH=PH**2
40846
40847C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
40848 DO 100 I=1,2
40849 PT=SQRT(MAX(0D0,VINT(197+5*I)))
40850 PP(I,1)=PT*COS(VINT(198+5*I))
40851 PP(I,2)=PT*SIN(VINT(198+5*I))
40852 100 CONTINUE
40853 PP(3,1)=-PP(1,1)-PP(2,1)
40854 PP(3,2)=-PP(1,2)-PP(2,2)
40855 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
40856 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
40857 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
40858 PMT3=SQRT(PMS3)
40859 PP(3,3)=PMT3*SINH(VINT(211))
40860 PP(3,4)=PMT3*COSH(VINT(211))
40861 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
40862 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
40863 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
40864 PP(2,3)=-PP(1,3)-PP(3,3)
40865 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
40866 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
40867
40868C...Set up incoming kinematics and derived momentum combinations.
40869 DO 110 I=4,5
40870 PP(I,1)=0D0
40871 PP(I,2)=0D0
40872 PP(I,3)=-0.5D0*SHPR*(-1)**I
40873 PP(I,4)=-0.5D0*SHPR
40874 110 CONTINUE
40875 DO 120 J=1,4
40876 PP(6,J)=PP(1,J)+PP(2,J)
40877 PP(7,J)=PP(1,J)+PP(3,J)
40878 PP(8,J)=PP(1,J)+PP(4,J)
40879 PP(9,J)=PP(1,J)+PP(5,J)
40880 PP(10,J)=-PP(2,J)-PP(3,J)
40881 PP(11,J)=-PP(2,J)-PP(4,J)
40882 PP(12,J)=-PP(2,J)-PP(5,J)
40883 PP(13,J)=-PP(4,J)-PP(5,J)
40884 120 CONTINUE
40885
40886C...Derived kinematics invariants.
40887 X1=DOT(1,2)
40888 X2=DOT(1,3)
40889 X3=DOT(1,4)
40890 X4=DOT(1,5)
40891 X5=DOT(2,3)
40892 X6=DOT(2,4)
40893 X7=DOT(2,5)
40894 X8=DOT(3,4)
40895 X9=DOT(3,5)
40896 X10=DOT(4,5)
40897
40898C...Propagators.
40899 SS1=DOT(7,7)-SPQ
40900 SS2=DOT(8,8)-SPQ
40901 SS3=DOT(9,9)-SPQ
40902 SS4=DOT(10,10)-SPQ
40903 SS5=DOT(11,11)-SPQ
40904 SS6=DOT(12,12)-SPQ
40905 SS7=DOT(13,13)
40906 DX(1)=SS1*SS6
40907 DX(2)=SS2*SS6
40908 DX(3)=SS2*SS4
40909 DX(4)=SS1*SS5
40910 DX(5)=SS3*SS5
40911 DX(6)=SS3*SS4
40912 DX(7)=SS7*SS1
40913 DX(8)=SS7*SS4
40914
40915C...Define colour coefficients for g + g -> Q + Qbar + H.
40916 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
40917 DO 140 I=1,3
40918 DO 130 J=1,3
40919 CLR(I,J)=16D0/3D0
40920 CLR(I+3,J+3)=16D0/3D0
40921 CLR(I,J+3)=-2D0/3D0
40922 CLR(I+3,J)=-2D0/3D0
40923 130 CONTINUE
40924 140 CONTINUE
40925 DO 160 L=1,2
40926 DO 150 I=1,3
40927 CLR(I,6+L)=-6D0
40928 CLR(I+3,6+L)=6D0
40929 CLR(6+L,I)=-6D0
40930 CLR(6+L,I+3)=6D0
40931 150 CONTINUE
40932 160 CONTINUE
40933 DO 180 K1=1,2
40934 DO 170 K2=1,2
40935 CLR(6+K1,6+K2)=12D0
40936 170 CONTINUE
40937 180 CONTINUE
40938
40939C...Evaluate matrix elements for g + g -> Q + Qbar + H.
40940 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
40941 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
40942 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
40943 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
40944 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
40945 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
40946 & X10)
40947 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
40948 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
40949 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
40950 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
40951 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
40952 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
40953 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
40954 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
40955 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
40956 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
40957 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
40958 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
40959 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
40960 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
40961 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
40962 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
40963 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
40964 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
40965 & X4*X6*X5)
40966 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
40967 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
40968 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
40969 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
40970 & +X4*X9*X5+X4*X5**2)
40971 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
40972 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
40973 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
40974 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
40975 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
40976 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
40977 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
40978 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
40979 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
40980 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
40981 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
40982 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
40983 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
40984 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
40985 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
40986 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
40987 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
40988 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
40989 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
40990 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
40991 & X6)
40992 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
40993 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
40994 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
40995 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
40996 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
40997 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
40998 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
40999 & X5+X4*X6*X5)
41000 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41001 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41002 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41003 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41004 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41005 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41006 & X6**2)
41007 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41008 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41009 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41010 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41011 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41012 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41013 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41014 & X4*X6*X5)
41015 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41016 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41017 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41018 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41019 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41020 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41021 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41022 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41023 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41024 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41025 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41026 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41027 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41028 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41029 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41030 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41031 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41032 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41033 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41034 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41035 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41036 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41037 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41038 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41039 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41040 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41041 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41042 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41043 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41044 & +X3*X8*X5+X3*X5**2)
41045 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41046 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41047 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41048 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41049 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41050 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41051 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41052 & X5+X4*X6*X5)
41053 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41054 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41055 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41056 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41057 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41058 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41059 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41060 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41061 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
41062 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
41063 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
41064 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
41065 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
41066 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
41067 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
41068 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
41069 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
41070 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
41071 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
41072 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
41073 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
41074 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
41075 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
41076 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
41077 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
41078 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
41079 & X10)
41080 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
41081 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
41082 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41083 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
41084 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
41085 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
41086 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
41087 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
41088 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
41089 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
41090 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
41091 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
41092 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
41093 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
41094 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
41095 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
41096 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
41097 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
41098 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
41099 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
41100 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
41101 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
41102 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
41103 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
41104 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
41105 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
41106 & X7)
41107 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
41108 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
41109 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
41110 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
41111 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
41112 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
41113 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
41114 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
41115 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
41116 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
41117 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
41118 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
41119 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
41120 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
41121 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
41122 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
41123 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
41124 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
41125 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
41126 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
41127 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
41128 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
41129 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
41130 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
41131 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
41132 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
41133 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
41134 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
41135 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
41136 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
41137 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
41138 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
41139 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
41140 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
41141 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
41142 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
41143 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
41144 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
41145 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
41146 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
41147 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
41148 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
41149 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
41150 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
41151 & *X6)
41152 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
41153 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
41154 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
41155 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
41156 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
41157 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
41158 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
41159 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
41160 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
41161 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
41162 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
41163 & X8)
41164 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
41165 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
41166 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
41167 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
41168 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
41169 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
41170 & X9*X5)
41171 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
41172 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
41173 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
41174 & X8*X5)
41175 FM(9,10)=0.5D0*(FMXX+FM(9,10))
41176 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
41177 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
41178 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
41179
41180C...Repackage matrix elements.
41181 DO 200 I=1,8
41182 DO 190 J=I,8
41183 RM(I,J)=FM(I,J)
41184 190 CONTINUE
41185 200 CONTINUE
41186 RM(7,7)=FM(7,7)-2D0*FM(9,9)
41187 RM(7,8)=FM(7,8)-2D0*FM(9,10)
41188 RM(8,8)=FM(8,8)-2D0*FM(10,10)
41189
41190C...Produce final result: matrix elements * colours * propagators.
41191 DO 220 I=1,8
41192 DO 210 J=I,8
41193 FAC=8D0
41194 IF(I.EQ.J)FAC=4D0
41195 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
41196 210 CONTINUE
41197 220 CONTINUE
41198 WTQQBH=-WTQQBH/256D0
41199
41200 ELSE
41201C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
41202 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
41203 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
41204 & *X6+X8*X7)
41205 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
41206 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
41207 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
41208 & X5)
41209 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
41210 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
41211 & *X9+X4*X8)
41212
41213C...Produce final result: matrix elements * propagators.
41214 A11=A11/DX(7)**2
41215 A12=A12/(DX(7)*DX(8))
41216 A22=A22/DX(8)**2
41217 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
41218 ENDIF
41219
41220 RETURN
41221 END
41222
41223C*********************************************************************
41224
41225C...PYSTBH (and auxiliaries)
41226C.. Evaluates the matrix elements for t + b + H production.
41227
41228 SUBROUTINE PYSTBH(WTTBH)
41229
41230C...DOUBLE PRECISION AND INTEGER DECLARATIONS
41231 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41232 IMPLICIT INTEGER(I-N)
41233 INTEGER PYK,PYCHGE,PYCOMP
41234
41235C...COMMONBLOCKS
41236 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41237 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41238 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41239 COMMON/PYINT1/MINT(400),VINT(400)
41240 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41241 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
41242 COMMON/PYINT4/MWID(500),WIDS(500,5)
41243 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
41244 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41245 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
41246 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
41247 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
41248 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
41249 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
41250 DOUBLE PRECISION MW2
41251 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
41252 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
41253
41254C...LOCAL ARRAYS AND COMPLEX VARIABLES
41255 DIMENSION QQ(4,2),PP(4,3)
41256 DATA QQ/8*0D0/
41257
41258 WTTBH=0D0
41259
41260C...KINEMATIC PARAMETERS.
41261 SHPR=SQRT(VINT(26))*VINT(1)
41262 PH=SQRT(VINT(21))*VINT(1)
41263 SPH=PH**2
41264
41265C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
41266 DO 100 I=1,2
41267 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41268 PP(1,I)=PT*COS(VINT(198+5*I))
41269 PP(2,I)=PT*SIN(VINT(198+5*I))
41270 100 CONTINUE
41271 PP(1,3)=-PP(1,1)-PP(1,2)
41272 PP(2,3)=-PP(2,1)-PP(2,2)
41273 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
41274 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
41275 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
41276 PMT3=SQRT(PMS3)
41277 PP(3,3)=PMT3*SINH(VINT(211))
41278 PP(4,3)=PMT3*COSH(VINT(211))
41279 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
41280 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41281 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
41282 PP(3,2)=-PP(3,1)-PP(3,3)
41283 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
41284 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
41285
41286C...CM SYSTEM, INGOING QUARKS/GLUONS
41287 QQ(3,1) = SHPR/2.D0
41288 QQ(4,1) = QQ(3,1)
41289 QQ(3,2) = -QQ(3,1)
41290 QQ(4,2) = QQ(4,1)
41291
41292C...PARAMETERS FOR AMPLITUDE METHOD
41293 ALPHA = AEM
41294 ALPHAS = AS
41295 SW2 = PARU(102)
41296 MW2 = PMAS(24,1)**2
41297 TANB = PARU(141)
41298 VTB = VCKM(3,3)
41299 RMB=PYMRUN(5,VINT(52))
41300
41301 ISUB=MINT(1)
41302
41303 IF (ISUB.EQ.401) THEN
41304 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
41305 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
41306 ELSE IF (ISUB.EQ.402) THEN
41307 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
41308 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
41309 END IF
41310
41311 RETURN
41312 END
41313C------------------------------------------------------------------
41314 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
41315C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
41316 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41317 IMPLICIT INTEGER(I-N)
41318 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
41319 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
41320 SAVE /PYCTBH/
41321
41322C TOP WIDTH CALCULATION
41323C VTB = 0.99
41324 MW=DSQRT(MW2)
41325 XB=(MB/MT)**2
41326 XW=(MW/MT)**2
41327 XH =(MHP/MT)**2
41328 GAMTBH = 0D0
41329 IF (MT .LT. (MHP+MB)) THEN
41330C T ->B W ONLY
41331 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
41332 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
41333 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
41334 GAMT = GAMTBW
41335 ELSE
41336C T ->BW +T ->B H^+
41337 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
41338 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
41339 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
41340C
41341 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
41342 & -4.D0*(MHP*MB/MT**2)**2 )
41343 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
41344 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
41345 GAMT = GAMTBW+GAMTBH
41346 ENDIF
41347C THUS BR IS
41348 BR=GAMTBH/GAMT
41349 RETURN
41350 END
41351
41352C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
41353C GG->TBH^+, QQBAR->TBH^+
41354C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
41355C (FOR INSTANCE WITH PYTHIA)
41356C------------------------------------------------------------
41357C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
41358C PHYS REV. D 60 (1999) 115011
41359C (THESE FILES PREPARED BY J.-L. KNEUR)
41360C------------------------------------------------------------
41361C 1) GG->TBH^+
41362 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
41363C
41364C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
41365C
41366C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
41367C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
41368C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
41369C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
41370C "PHYSICAL PARAMETERS" INPUT:
41371C MT,MB TOP AND BOTTOM MASSES;
41372C MHP CHARGED HIGGS MASS
41373C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
41374C
41375C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
41376C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
41377C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
41378C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
41379C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
41380C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
41381C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
41382C
41383 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41384 IMPLICIT INTEGER(I-N)
41385 DOUBLE PRECISION MW2,MT,MB,MHP,MW
41386 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
41387 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41388 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41389 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
41390
41391 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
41392 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
41393C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
41394C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
41395C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
41396C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
41397C (TAN BETA) VALUES
41398C
41399C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
41400C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
41401
41402 PI = 4*DATAN(1.D0)
41403 MW = DSQRT(MW2)
41404C
41405C COLLECTING THE RELEVANT OVERALL FACTORS:
41406C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
41407 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
41408C COUPLING CONSTANT (OVERALL NORMALIZATION)
41409 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
41410C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
41411C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
41412C ALPHAS IS ALPHA_STRONG;
41413C SW2 IS SIN(THETA_W)**2.
41414C
41415C VTB=.998D0
41416C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
41417C
41418 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
41419 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
41420C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
41421C
41422C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
41423C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
41424 DO 100 KK=1,4
41425 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
41426 100 CONTINUE
41427C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
41428 S = 2*PYTBHS(Q1,Q2)
41429 P1Q1=PYTBHS(Q1,P1)
41430 P1Q2=PYTBHS(P1,Q2)
41431 P2Q1=PYTBHS(P2,Q1)
41432 P2Q2=PYTBHS(P2,Q2)
41433 P1P2=PYTBHS(P1,P2)
41434C
41435C TOP WIDTH CALCULATION
41436 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
41437C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
41438C THEN DEFINE TOP (RESONANT) PROPAGATOR:
41439 A1INV= S -2*P1Q1 -2*P1Q2
41440 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
41441C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
41442C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
41443C THE TOP WIDTH
41444 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
41445 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
41446C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
41447C NOW COMES THE AMP**2:
41448C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
41449C THE EXPRESSIONS BELOW
41450 V18=0.D0
41451 A18=0.D0
41452 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
41453 &512*A1*A2*MB*MT/3-
41454 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
41455 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
41456 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
41457 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
41458 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
41459 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
41460 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
41461 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
41462 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
41463 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
41464 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
41465 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
41466 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
41467 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
41468 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
41469 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
41470 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
41471 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
41472 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
41473 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
41474 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
41475 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
41476 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
41477 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
41478 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
41479 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
41480 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
41481 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
41482 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
41483 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
41484 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
41485 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
41486 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
41487 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
41488 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
41489 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
41490 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
41491 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
41492 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
41493 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
41494 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
41495 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
41496 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
41497 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
41498 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
41499 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
41500 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
41501 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
41502 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
41503 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
41504 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
41505 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
41506 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
41507 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
41508 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
41509 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
41510 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
41511 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
41512 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
41513 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
41514 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
41515 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
41516 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
41517 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
41518 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
41519 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
41520 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
41521 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
41522 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
41523 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
41524 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
41525 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
41526 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
41527 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
41528 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
41529 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
41530 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
41531 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
41532 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
41533 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
41534 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
41535 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
41536 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
41537 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
41538 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
41539 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
41540 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
41541 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
41542 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
41543 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
41544 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
41545 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
41546 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
41547 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
41548 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
41549 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
41550 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
41551 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
41552 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
41553 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
41554 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
41555 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
41556 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
41557 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
41558 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
41559 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
41560 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
41561 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
41562 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
41563 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
41564 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
41565 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
41566 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
41567 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
41568 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
41569 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
41570 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
41571 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
41572 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
41573 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
41574 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
41575 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
41576 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
41577 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
41578 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
41579 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
41580 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
41581 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
41582 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
41583 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
41584 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
41585 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
41586 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
41587 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
41588 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
41589 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
41590 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
41591 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
41592 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
41593 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
41594 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
41595 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
41596 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
41597 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
41598 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
41599 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
41600 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
41601 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
41602 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
41603 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
41604 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
41605 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
41606 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
41607 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
41608 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
41609 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
41610 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
41611 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
41612 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
41613 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
41614 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
41615 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
41616 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
41617 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
41618 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
41619 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
41620 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
41621 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
41622 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
41623 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
41624 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
41625 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
41626 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
41627 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
41628 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
41629 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
41630 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
41631 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
41632 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
41633 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
41634 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
41635 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
41636 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
41637 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
41638 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
41639 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
41640 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
41641 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
41642 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
41643 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
41644 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
41645 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
41646 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
41647 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
41648 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
41649 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
41650 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
41651 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
41652 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
41653 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
41654 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
41655 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
41656 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
41657 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
41658 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
41659 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
41660 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
41661 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
41662 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
41663 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
41664 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
41665 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
41666 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
41667 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
41668 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
41669 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
41670 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
41671 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
41672 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
41673 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
41674 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
41675 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
41676 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
41677 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
41678 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
41679 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
41680 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
41681 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
41682 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
41683 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
41684 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
41685 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
41686 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
41687 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
41688 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
41689 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
41690 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
41691 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
41692 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
41693 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
41694 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
41695 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
41696 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
41697 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
41698 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
41699 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
41700 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
41701 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
41702 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
41703 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
41704 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
41705 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
41706 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
41707 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
41708 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
41709 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
41710 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
41711 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
41712 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
41713 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
41714 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
41715 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
41716 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
41717 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
41718 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
41719 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
41720 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
41721 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
41722 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
41723 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
41724 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
41725 &384*A12*MB*MT*P1Q1**2/S**2+
41726 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
41727 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
41728 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
41729 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
41730 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
41731 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
41732 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
41733 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
41734 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
41735 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
41736 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
41737 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
41738 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
41739 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
41740 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
41741 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
41742 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
41743 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
41744 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
41745 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
41746 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
41747 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
41748 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
41749 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
41750 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
41751 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
41752 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
41753 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
41754 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
41755 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
41756 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
41757 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
41758 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
41759 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
41760 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
41761 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
41762 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
41763 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
41764 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
41765 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
41766 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
41767 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
41768 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
41769 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
41770 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
41771 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
41772 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
41773 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
41774 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
41775 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
41776 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
41777 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
41778 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
41779 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
41780 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
41781 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
41782 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
41783 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
41784 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
41785 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
41786 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
41787 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
41788 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
41789 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
41790 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
41791 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
41792 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
41793 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
41794 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
41795 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
41796 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
41797 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
41798 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
41799 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
41800 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
41801 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
41802 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
41803 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
41804 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
41805 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
41806 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
41807 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
41808 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
41809 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
41810 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
41811 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
41812 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
41813 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
41814 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
41815 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
41816 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
41817 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
41818 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
41819 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
41820 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
41821 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
41822 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
41823 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
41824 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
41825 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
41826 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
41827 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
41828 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
41829 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
41830 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
41831 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
41832 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
41833 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
41834 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
41835 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
41836 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
41837 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
41838 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
41839 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
41840 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
41841 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
41842 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
41843 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
41844 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
41845 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
41846 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
41847 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
41848 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
41849 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
41850 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
41851 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
41852 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
41853 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
41854 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
41855 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
41856 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
41857 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
41858 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
41859 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
41860 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
41861 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
41862 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
41863 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
41864 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
41865 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
41866 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
41867 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
41868 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
41869 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
41870 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
41871 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
41872 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
41873 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
41874 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
41875 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
41876 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
41877 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
41878 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
41879 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
41880 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
41881 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
41882 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
41883 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
41884 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
41885 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
41886 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
41887 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
41888 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
41889 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
41890 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
41891 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
41892 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
41893 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
41894 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
41895 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
41896 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
41897 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
41898 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
41899 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
41900 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
41901 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
41902
41903 V18BIS=
41904 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41905 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41906 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41907 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
41908 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
41909 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
41910 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
41911 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
41912 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
41913 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
41914 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
41915 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
41916 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
41917 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
41918 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
41919 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
41920 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
41921 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
41922 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
41923 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
41924 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
41925 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
41926 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
41927 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
41928 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
41929 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
41930 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
41931 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
41932 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
41933 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
41934 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
41935 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
41936 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
41937 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
41938 &272*A1*A2*P1Q1*S/(3*P1Q2)+
41939 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
41940 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
41941 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
41942 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
41943 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
41944 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
41945 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
41946 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
41947 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
41948 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
41949 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
41950 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
41951 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
41952 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
41953 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
41954 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
41955 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
41956 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
41957 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
41958 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
41959 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
41960 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
41961 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
41962 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
41963 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
41964 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
41965 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
41966 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
41967 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
41968 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
41969 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
41970 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
41971 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
41972 &32*A12*P2Q1*S/(3*P1Q1)-
41973 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
41974 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
41975 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
41976 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
41977 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
41978 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
41979 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
41980 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
41981 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
41982 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
41983 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
41984 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
41985 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
41986 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
41987 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
41988 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
41989 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
41990 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
41991 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
41992 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
41993 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
41994 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
41995 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
41996 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
41997 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
41998 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
41999 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42000 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42001 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42002 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42003 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42004 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42005 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42006 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42007 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42008 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42009 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42010 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42011 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42012 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42013 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42014 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42015 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42016 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42017 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42018 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42019 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42020 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42021 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42022 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42023 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42024 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42025 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42026 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42027 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42028 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42029 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42030 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42031 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42032 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42033 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42034 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42035 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42036 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42037 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42038 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42039 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42040 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42041 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42042 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42043 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42044 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42045 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42046 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42047C
42048
42049 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42050 &512*A1*A2*MB*MT/3+
42051 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42052 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42053 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42054 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42055 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42056 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42057 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42058 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42059 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42060 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42061 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
42062 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
42063 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42064 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42065 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
42066 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
42067 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
42068 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
42069 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42070 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
42071 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
42072 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42073 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42074 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42075 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
42076 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42077 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42078 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42079 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42080 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42081 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
42082 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42083 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42084 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
42085 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
42086 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42087 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
42088 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42089 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42090 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
42091 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
42092 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42093 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
42094 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42095 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42096 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42097 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42098 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
42099 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
42100 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42101 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
42102 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42103 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
42104 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
42105 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42106 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42107 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
42108 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
42109 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
42110 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42111 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42112 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42113 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
42114 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42115 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
42116 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42117 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42118 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42119 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
42120 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42121 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
42122 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42123 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42124 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42125 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42126 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42127 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42128 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
42129 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42130 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42131 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
42132 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42133 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42134 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42135 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
42136 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42137 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42138 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
42139 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42140 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42141 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
42142 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42143 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42144 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42145 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
42146 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42147 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42148 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42149 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
42150 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42151 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42152 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42153 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42154 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42155 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
42156 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42157 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
42158 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42159 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
42160 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
42161 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42162 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42163 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42164 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42165 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
42166 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42167 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42168 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42169 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42170 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42171 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
42172 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42173 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42174 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42175 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42176 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42177 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
42178 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
42179 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42180 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42181 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42182 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
42183 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42184 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42185 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42186 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42187 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42188 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
42189 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42190 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
42191 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42192 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42193 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
42194 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42195 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
42196 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
42197 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42198 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42199 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42200 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42201 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42202 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42203 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42204 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
42205 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42206 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42207 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
42208 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42209 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42210 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
42211 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42212 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42213 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
42214 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42215 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42216 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
42217 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42218 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42219 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42220 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
42221 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42222 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
42223 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42224 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42225 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42226 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42227 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42228 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42229 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42230 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42231 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42232 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42233 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42234 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42235 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42236 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42237 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42238 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42239 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42240 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
42241 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42242 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42243 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42244 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
42245 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42246 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42247 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
42248 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42249 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42250 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42251 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42252 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42253 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42254 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42255 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42256 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42257 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42258 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42259 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42260 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42261 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
42262 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42263 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42264 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42265 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42266 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42267 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
42268 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42269 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42270 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42271 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42272 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42273 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42274 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42275 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42276 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
42277 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42278 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42279 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42280 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42281 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42282 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42283 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42284 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42285 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
42286 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42287 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42288 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42289 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42290 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42291 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
42292 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42293 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42294 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
42295 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42296 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42297 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42298 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42299 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42300 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
42301 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42302 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42303 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42304 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42305 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42306 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42307 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42308 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42309 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
42310 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42311 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42312 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42313 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42314 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42315 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42316 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42317 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
42318 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42319 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42320 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42321 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
42322 &384*A12*MB*MT*P1Q1**2/S**2+
42323 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42324 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
42325 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42326 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42327 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42328 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42329 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
42330 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42331 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42332 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42333 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42334 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42335 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42336 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42337 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
42338 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
42339 &384*A2**2*MB*MT*P2Q2**2/S**2+
42340 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42341 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
42342 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
42343 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
42344 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
42345 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
42346 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42347 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
42348 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
42349 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
42350 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
42351 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
42352 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
42353 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42354 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
42355 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42356 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
42357 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42358 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42359 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
42360 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
42361 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
42362 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
42363 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42364 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42365 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42366 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42367 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
42368 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42369 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
42370 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
42371 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
42372 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
42373 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
42374 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42375 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
42376 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42377 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
42378 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42379 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42380 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42381 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
42382 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42383 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42384 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42385 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42386 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
42387 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
42388 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
42389 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
42390 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
42391 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42392 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42393 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42394 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
42395 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42396 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
42397 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42398 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42399 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42400 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42401 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42402 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42403 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
42404 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42405 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
42406 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42407 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
42408 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42409 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42410 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
42411 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
42412 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42413 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42414 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42415 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42416 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
42417 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42418 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
42419 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42420 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
42421 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42422 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
42423 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42424 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
42425 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42426 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
42427 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
42428 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
42429 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42430 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
42431 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
42432 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42433 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42434 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42435 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42436 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
42437 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42438 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42439 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
42440 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
42441 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
42442 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42443 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42444 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42445 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42446 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42447 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42448 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42449 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42450 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42451 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
42452 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42453 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
42454 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42455 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42456 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
42457 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
42458 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42459 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
42460 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42461 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
42462 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
42463 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42464 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42465 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
42466 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42467 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42468 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
42469 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42470 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42471 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42472 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
42473 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
42474 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42475 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
42476 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42477 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42478 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42479 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42480 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42481 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42482 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
42483 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
42484 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
42485 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42486 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42487 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42488 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
42489 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42490 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
42491 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
42492 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42493 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42494 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42495 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42496 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42497 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42498 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42499 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42500 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42501 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42502 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42503 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
42504 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42505 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42506 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42507 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
42508 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42509 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42510 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
42511 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42512 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
42513 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
42514 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42515 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42516 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42517 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42518 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42519 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42520 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
42521 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
42522 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42523 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42524 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
42525 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
42526 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42527 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
42528 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
42529 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
42530 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
42531 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42532 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
42533
42534 A18BIS=
42535 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42536 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42537 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42538 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42539 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42540 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
42541 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42542 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42543 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
42544 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42545 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
42546 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
42547 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42548 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42549 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
42550 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
42551 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
42552 &12*S/(P1Q2*P2Q1)+
42553 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42554 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
42555 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42556 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
42557 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42558 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42559 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42560 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42561 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42562 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
42563 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42564 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
42565 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
42566 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42567 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
42568 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
42569 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
42570 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42571 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42572 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42573 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42574 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42575 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
42576 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42577 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42578 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
42579 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42580 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42581 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
42582 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
42583 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42584 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
42585 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42586 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42587 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
42588 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42589 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
42590 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42591 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
42592 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42593 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42594 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42595 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42596 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42597 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
42598 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
42599 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42600 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
42601 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
42602 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
42603 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
42604 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42605 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42606 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42607 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42608 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42609 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42610 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42611 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42612 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42613 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42614 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
42615 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
42616 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
42617 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42618 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
42619 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42620 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42621 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42622 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42623 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42624 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42625 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42626 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
42627 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42628 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42629 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42630 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
42631 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
42632 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42633 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42634 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
42635 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
42636 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42637 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42638 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42639C
42640 V18=V18+V18BIS
42641 A18=A18+A18BIS
42642 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
42643 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
42644 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
42645 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
42646 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
42647 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
42648 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
42649 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
42650 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
42651 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
42652 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
42653 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
42654 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
42655 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
42656 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
42657 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
42658 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
42659 V910=V910+96*A1*A2*P1P2*P2Q1/S-
42660 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
42661 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
42662 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
42663 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
42664 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
42665C
42666 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
42667 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
42668 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
42669 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
42670 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
42671 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
42672 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
42673 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
42674 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
42675 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
42676 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
42677 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
42678 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
42679 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
42680 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
42681 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
42682 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
42683 A910=A910+96*A1*A2*P1P2*P2Q1/S-
42684 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
42685 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
42686 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
42687 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
42688 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
42689C
42690C FINAL RESULT;
42691C
42692 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
42693
42694 END
42695C---------------------------------------------------------
42696C 2) Q QBAR ->TBH^+
42697 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42698C
42699C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
42700C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
42701 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42702 IMPLICIT INTEGER(I-N)
42703 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42704 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42705 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42706 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42707 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42708 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42709 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42710C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42711C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42712C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42713C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
42714C
42715C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42716C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42717C
42718 DIMENSION YY(2,2)
42719
42720 PI = 4*DATAN(1.D0)
42721 MW = DSQRT(MW2)
42722
42723C COLLECTING THE RELEVANT OVERALL FACTORS:
42724C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
42725 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
42726C COUPLING CONSTANT (OVERALL NORMALIZATION)
42727 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42728C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42729C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42730C ALPHAS IS ALPHA_STRONG;
42731C SW2 IS SIN(THETA_W)**2.
42732C
42733C VTB=.998D0
42734C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42735C
42736 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42737 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42738C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42739C
42740C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42741C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42742 DO 100 KK=1,4
42743 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42744 100 CONTINUE
42745C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42746 S = 2*PYTBHS(Q1,Q2)
42747 P1Q1=PYTBHS(Q1,P1)
42748 P1Q2=PYTBHS(P1,Q2)
42749 P2Q1=PYTBHS(P2,Q1)
42750 P2Q2=PYTBHS(P2,Q2)
42751 P1P2=PYTBHS(P1,P2)
42752C
42753C TOP WIDTH CALCULATION
42754 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42755C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42756C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42757 A1INV= S -2*P1Q1 -2*P1Q2
42758 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42759C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42760C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
42761 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42762 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42763C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42764C NOW COMES THE AMP**2:
42765C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
42766C THE EXPRESSIONS BELOW
42767 YY(1, 1) = -16*A**2*A2**2*MB*MT+
42768 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
42769 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
42770 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
42771 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
42772 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
42773 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
42774 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
42775 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
42776 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
42777 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
42778 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
42779 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
42780 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
42781 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
42782 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
42783 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
42784 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
42785 &32*A2**2*MB**2*P1P2*V**2/S+
42786 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
42787 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
42788 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
42789 YY(1, 1)=2*YY(1, 1)
42790
42791 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
42792 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
42793 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
42794 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
42795 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
42796 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
42797 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
42798 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
42799 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
42800 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
42801 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
42802 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42803 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
42804 &64*A**2*A1*A2*MB*MT*P1P2/S+
42805 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
42806 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
42807 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
42808 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
42809 &64*A**2*A1*A2*P1Q1*P2Q1/S-
42810 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
42811 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
42812 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
42813 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
42814 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
42815 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
42816 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
42817 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
42818 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
42819 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
42820 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
42821 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
42822 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
42823 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
42824 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
42825 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
42826 &32*A1*A2*P1P2*P1Q1*V**2/S+
42827 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
42828 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
42829 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
42830 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
42831
42832
42833 YY(2, 2) =-16*A**2*A12*MB*MT+
42834 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
42835 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
42836 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
42837 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
42838 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
42839 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
42840 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
42841 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
42842 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
42843 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
42844 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
42845 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
42846 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
42847 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
42848 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
42849 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
42850 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
42851 &32*A12*MT**2*P2Q2*V**2/S-
42852 &32*A12*P1Q2*P2Q2*V**2/S
42853 YY(2, 2)=2*YY(2, 2)
42854
42855 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
42856 AMP2= FACT*PS*VTB**2*RES
42857
42858 END
42859C=====================================================================
42860C ************* FUNCTION SCALAR PRODUCTS *************************
42861 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
42862 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42863 IMPLICIT INTEGER(I-N)
42864 DIMENSION A(4),B(4)
42865 DUM=A(4)*B(4)
42866 DO 100 ID=1,3
42867 DUM=DUM-A(ID)*B(ID)
42868 100 CONTINUE
42869 PYTBHS=DUM
42870 RETURN
42871 END
42872
42873C*********************************************************************
42874
42875C...PYMSIN
42876C...Initializes supersymmetry: finds sparticle masses and
42877C...branching ratios and stores this information.
42878C...AUTHOR: STEPHEN MRENNA
42879C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
42880
42881 SUBROUTINE PYMSIN
42882
42883C...Double precision and integer declarations.
42884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42885 IMPLICIT INTEGER(I-N)
42886 INTEGER PYK,PYCHGE,PYCOMP
42887C...Parameter statement to help give large particle numbers.
42888 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
42889 &KEXCIT=4000000,KDIMEN=5000000)
42890C...Commonblocks.
42891 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42893 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
42894 COMMON/PYDAT4/CHAF(500,2)
42895 CHARACTER CHAF*16
42896 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42897 COMMON/PYINT4/MWID(500),WIDS(500,5)
42898 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42899 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
42900 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
42901 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
42902 COMMON/PYHTRI/HHH(7)
42903 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
42904 &/PYMSSM/,/PYMSRV/,/PYSSMT/
42905
42906C...Local variables.
42907 DOUBLE PRECISION ALFA,BETA
42908 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
42909 INTEGER I,J,J1,I1,K1
42910 INTEGER KC,LKNT,IDLAM(400,3)
42911 DOUBLE PRECISION XLAM(0:400)
42912 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
42913 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
42914 DOUBLE PRECISION DELM,XMDIF
42915 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
42916 DOUBLE PRECISION ARG,SGNMU,R
42917 INTEGER IMSSM
42918 INTEGER IRPRTY
42919 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
42920 SAVE MWIDSU,MDCYSU
42921 DATA KFSUSY/
42922 &1000001,2000001,1000002,2000002,1000003,2000003,
42923 &1000004,2000004,1000005,2000005,1000006,2000006,
42924 &1000011,2000011,1000012,2000012,1000013,2000013,
42925 &1000014,2000014,1000015,2000015,1000016,2000016,
42926 &1000021,1000022,1000023,1000025,1000035,1000024,
42927 &1000037,1000039, 25, 35, 36, 37,
42928 & 6, 24, 45, 46,1000045, 9*0/
42929 DATA INIT/0/
42930
42931C...Do nothing if SUSY not requested.
42932 IMSSM=IMSS(1)
42933 IF(IMSSM.EQ.0) RETURN
42934
42935C...Save copy of MWID(KC) and MDCY(KC,1) values before
42936C...they are set to zero for the LSP.
42937 IF(INIT.EQ.0) THEN
42938 INIT=1
42939 DO 100 I=1,36
42940 KF=KFSUSY(I)
42941 KC=PYCOMP(KF)
42942 MWIDSU(I)=MWID(KC)
42943 MDCYSU(I)=MDCY(KC,1)
42944 100 CONTINUE
42945 ENDIF
42946
42947C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
42948 DO 110 I=1,36
42949 KF=KFSUSY(I)
42950 KC=PYCOMP(KF)
42951 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
42952 MWID(KC)=MWIDSU(I)
42953 MDCY(KC,1)=MDCYSU(I)
42954 ENDIF
42955 110 CONTINUE
42956
42957C...First part of routine: set masses and couplings.
42958
42959C...Reset mixing values in sfermion sector to pure left/right.
42960 DO 120 I=1,16
42961 SFMIX(I,1)=1D0
42962 SFMIX(I,4)=1D0
42963 SFMIX(I,2)=0D0
42964 SFMIX(I,3)=0D0
42965 120 CONTINUE
42966
42967C...Add NMSSM states if NMSSM switched on, and change old names.
42968 IF (IMSS(13).NE.0) THEN
42969C... Switch on NMSSM
42970 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
42971
42972 KFN=25
42973 KCN=KFN
42974 CHAF(KCN,1)='H_10'
42975 CHAF(KCN,2)=' '
42976
42977 KFN=35
42978 KCN=KFN
42979 CHAF(KCN,1)='H_20'
42980 CHAF(KCN,2)=' '
42981
42982 KFN=45
42983 KCN=KFN
42984 CHAF(KCN,1)='H_30'
42985 CHAF(KCN,2)=' '
42986
42987 KFN=36
42988 KCN=KFN
42989 CHAF(KCN,1)='A_10'
42990 CHAF(KCN,2)=' '
42991
42992 KFN=46
42993 KCN=KFN
42994 CHAF(KCN,1)='A_20'
42995 CHAF(KCN,2)=' '
42996
42997 KFN=1000045
42998 KCN=PYCOMP(KFN)
42999 IF (KCN.EQ.0) THEN
43000 DO 123 KCT=100,MSTU(6)
43001 IF(KCHG(KCT,4).GT.100) KCN=KCT
43002 123 CONTINUE
43003 KCN=KCN+1
43004 KCHG(KCN,4)=KFN
43005 MSTU(20)=0
43006 ENDIF
43007C... Set stable for now
43008 PMAS(KCN,2)=1D-6
43009 MWID(KCN)=0
43010 MDCY(KCN,1)=0
43011 MDCY(KCN,2)=0
43012 MDCY(KCN,3)=0
43013 CHAF(KCN,1)='~chi_50'
43014 CHAF(KCN,2)=' '
43015 ENDIF
43016
43017C...Read spectrum from SLHA file.
43018 IF (IMSSM.EQ.11.AND.IMSS(21).NE.0) THEN
43019C...First check for new states
43020 CALL PYSLHA(0,0,IFAIL)
43021C...Then read spectrum
43022 CALL PYSLHA(1,0,IFAIL)
43023 ELSEIF (IMSS(21).NE.0) THEN
43024C...Check for new states but don't read spectrum
43025 CALL PYSLHA(0,0,IFAIL)
43026 ENDIF
43027
43028C...Common couplings.
43029 TANB=RMSS(5)
43030 BETA=ATAN(TANB)
43031 COSB=COS(BETA)
43032 SINB=TANB*COSB
43033 COS2B=COS(2D0*BETA)
43034 ALFA=RMSS(18)
43035 XMW2=PMAS(24,1)**2
43036 XMZ2=PMAS(23,1)**2
43037 XW=PARU(102)
43038
43039C...Define sparticle masses for a general MSSM simulation.
43040 IF(IMSSM.EQ.1) THEN
43041 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43042 DO 130 I=1,5,2
43043 KC=PYCOMP(KSUSY1+I)
43044 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43045 KC=PYCOMP(KSUSY2+I)
43046 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43047 KC=PYCOMP(KSUSY1+I+1)
43048 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43049 KC=PYCOMP(KSUSY2+I+1)
43050 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43051 130 CONTINUE
43052 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43053 IF(XARG.LT.0D0) THEN
43054 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43055 & ' FROM THE SUM RULE. '
43056 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
43057 RETURN
43058 ELSE
43059 XARG=SQRT(XARG)
43060 ENDIF
43061 DO 140 I=11,15,2
43062 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
43063 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
43064 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
43065 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
43066 140 CONTINUE
43067 IF(IMSS(8).EQ.1) THEN
43068 RMSS(13)=RMSS(6)
43069 RMSS(14)=RMSS(7)
43070 ENDIF
43071
43072C...Alternatively derive masses from SUGRA relations.
43073 ELSEIF(IMSSM.EQ.2) THEN
43074 RMSS(36)=RMSS(16)
43075 CALL PYAPPS
43076C...Or use ISASUSY
43077 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
43078 RMSS(36)=RMSS(16)
43079 CALL PYSUGI
43080 ALFA=RMSS(18)
43081 GOTO 170
43082 ELSE
43083 GOTO 170
43084 ENDIF
43085
43086C...Add in extra D-term contributions.
43087 IF(IMSS(7).EQ.1) THEN
43088 R=0.43D0
43089 DX=RMSS(23)
43090 DY=RMSS(24)
43091 DS=RMSS(25)
43092 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43093 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
43094 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
43095 WRITE(MSTU(11),*) 'C DX = ',DX
43096 WRITE(MSTU(11),*) 'C DY = ',DY
43097 WRITE(MSTU(11),*) 'C DS = ',DS
43098 WRITE(MSTU(11),*) 'C '
43099 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
43100 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
43101 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43102 DQ2=DY/6D0-DX/3D0-DS/3D0
43103 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
43104 DD2=DY/3D0+DX-2D0*DS/3D0
43105 DL2=-DY/2D0+DX-2D0*DS/3D0
43106 DE2=DY-DX/3D0-DS/3D0
43107 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
43108 DHD2=-DY/2D0-2D0*DX/3D0+DS
43109 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
43110 & /ABS(COS2B)
43111 DMA2 = 2D0*DMU2+DHU2+DHD2
43112 DO 150 I=1,5,2
43113 KC=PYCOMP(KSUSY1+I)
43114 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
43115 KC=PYCOMP(KSUSY2+I)
43116 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
43117 KC=PYCOMP(KSUSY1+I+1)
43118 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
43119 KC=PYCOMP(KSUSY2+I+1)
43120 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
43121 150 CONTINUE
43122 DO 160 I=11,15,2
43123 KC=PYCOMP(KSUSY1+I)
43124 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
43125 KC=PYCOMP(KSUSY2+I)
43126 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
43127 KC=PYCOMP(KSUSY1+I+1)
43128 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
43129 160 CONTINUE
43130 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
43131 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
43132 STOP
43133 ENDIF
43134 SGNMU=SIGN(1D0,RMSS(4))
43135 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
43136 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
43137 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
43138 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
43139 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
43140 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
43141 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
43142 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
43143 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
43144 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
43145 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
43146 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
43147 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
43148 STOP
43149 ENDIF
43150 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
43151 RMSS(6)=SQRT(RMSS(6)**2+DL2)
43152 RMSS(7)=SQRT(RMSS(7)**2+DE2)
43153 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
43154 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
43155 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
43156 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
43157 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
43158 ENDIF
43159
43160C...Fix the third generation sfermions.
43161 CALL PYTHRG
43162
43163C...Fix the neutralino--chargino--gluino sector.
43164 CALL PYINOM
43165
43166C...Fix the Higgs sector.
43167 CALL PYHGGM(ALFA)
43168
43169C...Choose the Gunion-Haber convention.
43170 ALFA=-ALFA
43171 RMSS(18)=ALFA
43172
43173C...Print information on mass parameters.
43174 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
43175 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43176 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
43177 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
43178 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
43179 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
43180 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
43181 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
43182 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
43183 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
43184 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43185 ENDIF
43186 IF(IMSS(20).EQ.1) THEN
43187 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43188 WRITE(MSTU(11),*) ' DEBUG MODE '
43189 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
43190 & UMIX(2,1),UMIX(2,2)
43191 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
43192 & UMIXI(2,1),UMIXI(2,2)
43193 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
43194 & VMIX(2,1),VMIX(2,2)
43195 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
43196 & VMIXI(2,1),VMIXI(2,2)
43197 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
43198 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
43199 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
43200 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
43201 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
43202 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
43203 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
43204 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
43205 WRITE(MSTU(11),*) ' ALFA = ',ALFA
43206 WRITE(MSTU(11),*) ' BETA = ',BETA
43207 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
43208 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
43209 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
43210 ENDIF
43211
43212C...Set up the Higgs couplings - needed here since initialization
43213C...in PYINRE did not yet occur when PYWIDT is called below.
43214 170 AL=ALFA
43215 BE=BETA
43216 SINA=SIN(AL)
43217 COSA=COS(AL)
43218 COSB=COS(BE)
43219 SINB=TANB*COSB
43220 SBMA=SIN(BE-AL)
43221 SAPB=SIN(AL+BE)
43222 CAPB=COS(AL+BE)
43223 CBMA=COS(BE-AL)
43224 C2A=COS(2D0*AL)
43225 C2B=COSB**2-SINB**2
43226C...tanb (used for H+)
43227 PARU(141)=TANB
43228
43229C...Firstly: h
43230C...Coupling to d-type quarks
43231 PARU(161)=SINA/COSB
43232C...Coupling to u-type quarks
43233 PARU(162)=-COSA/SINB
43234C...Coupling to leptons
43235 PARU(163)=PARU(161)
43236C...Coupling to Z
43237 PARU(164)=SBMA
43238C...Coupling to W
43239 PARU(165)=PARU(164)
43240
43241C...Secondly: H
43242C...Coupling to d-type quarks
43243 PARU(171)=-COSA/COSB
43244C...Coupling to u-type quarks
43245 PARU(172)=-SINA/SINB
43246C...Coupling to leptons
43247 PARU(173)=PARU(171)
43248C...Coupling to Z
43249 PARU(174)=CBMA
43250C...Coupling to W
43251 PARU(175)=PARU(174)
43252C...Coupling to h
43253 IF(IMSS(4).GE.2) THEN
43254 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
43255 ELSE
43256 HHH(3)=HHH(3)+HHH(4)+HHH(5)
43257 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
43258 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
43259 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
43260 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
43261 ENDIF
43262C...Coupling to H+
43263C...Define later
43264 IF(IMSS(4).GE.2) THEN
43265 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
43266 ELSE
43267 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
43268 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
43269 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
43270 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
43271 ENDIF
43272C...Coupling to A
43273 IF(IMSS(4).GE.2) THEN
43274 PARU(177)=COS(2D0*BE)*COS(BE+AL)
43275 ELSE
43276 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
43277 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
43278 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
43279 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
43280 ENDIF
43281C...Coupling to H+
43282 IF(IMSS(4).GE.2) THEN
43283 PARU(178)=PARU(177)
43284 ELSE
43285 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
43286 ENDIF
43287C...Thirdly, A
43288C...Coupling to d-type quarks
43289 PARU(181)=TANB
43290C...Coupling to u-type quarks
43291 PARU(182)=1D0/PARU(181)
43292C...Coupling to leptons
43293 PARU(183)=PARU(181)
43294 PARU(184)=0D0
43295 PARU(185)=0D0
43296C...Coupling to Z h
43297 PARU(186)=COS(BE-AL)
43298C...Coupling to Z H
43299 PARU(187)=SIN(BE-AL)
43300 PARU(188)=0D0
43301 PARU(189)=0D0
43302 PARU(190)=0D0
43303
43304C...Finally: H+
43305C...Coupling to W h
43306 PARU(195)=COS(BE-AL)
43307
43308C...Tell that all Higgs couplings have been set.
43309 MSTP(4)=1
43310
43311C...Set R-Violating couplings.
43312C...Set lambda couplings to common value or "natural values".
43313 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
43314 VIR3=1D0/(126D0)**3
43315 DO 200 IRK=1,3
43316 DO 190 IRI=1,3
43317 DO 180 IRJ=1,3
43318 IF (IRI.NE.IRJ) THEN
43319 IF (IRI.LT.IRJ) THEN
43320 RVLAM(IRI,IRJ,IRK)=RMSS(51)
43321 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
43322 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
43323 & PMAS(9+2*IRK,1)*VIR3)
43324 ELSE
43325 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
43326 ENDIF
43327 ELSE
43328 RVLAM(IRI,IRJ,IRK)=0D0
43329 ENDIF
43330 180 CONTINUE
43331 190 CONTINUE
43332 200 CONTINUE
43333 ENDIF
43334C...Set lambda' couplings to common value or "natural values".
43335 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
43336 VIR3=1D0/(126D0)**3
43337 DO 230 IRI=1,3
43338 DO 220 IRJ=1,3
43339 DO 210 IRK=1,3
43340 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
43341 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
43342 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
43343 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
43344 210 CONTINUE
43345 220 CONTINUE
43346 230 CONTINUE
43347 ENDIF
43348C...Set lambda'' couplings to common value or "natural values".
43349 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
43350 VIR3=1D0/(126D0)**3
43351 DO 260 IRI=1,3
43352 DO 250 IRJ=1,3
43353 DO 240 IRK=1,3
43354 IF (IRJ.NE.IRK) THEN
43355 IF (IRJ.LT.IRK) THEN
43356 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
43357 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
43358 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
43359 & PMAS(2*IRK-1,1)*VIR3)
43360 ELSE
43361 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
43362 ENDIF
43363 ELSE
43364 RVLAMB(IRI,IRJ,IRK) = 0D0
43365 ENDIF
43366 240 CONTINUE
43367 250 CONTINUE
43368 260 CONTINUE
43369 ENDIF
43370
43371C...Antisymmetrize couplings set by user
43372 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
43373 DO 290 IRI=1,3
43374 DO 280 IRJ=1,3
43375 DO 270 IRK=1,3
43376 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
43377 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
43378 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
43379 ENDIF
43380 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
43381 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
43382 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
43383 ENDIF
43384 270 CONTINUE
43385 280 CONTINUE
43386 290 CONTINUE
43387 ENDIF
43388
43389C...Write spectrum to SLHA file
43390 IF (IMSS(23).NE.0) THEN
43391 IFAIL=0
43392 CALL PYSLHA(3,0,IFAIL)
43393 ENDIF
43394
43395C...Second part of routine: set decay modes and branching ratios.
43396
43397C...Allow chi10 -> gravitino + gamma or not.
43398 KC=PYCOMP(KSUSY1+39)
43399 IF( IMSS(11) .NE. 0 ) THEN
43400 PMAS(KC,1)=RMSS(21)/1D9
43401 PMAS(KC,2)=0D0
43402 IRPRTY=0
43403 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
43404 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
43405 IRPRTY=0
43406 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
43407 & ' ALLOWING SUSY LLE DECAYS'
43408 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
43409 & ' ALLOWING SUSY LQD DECAYS'
43410 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
43411 & ' ALLOWING SUSY UDD DECAYS'
43412 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
43413 & ' --- Warning: R-Violating couplings possibly',
43414 & ' incompatible with proton decay'
43415 ELSE
43416 PMAS(KC,1)=9999D0
43417 IRPRTY=1
43418 ENDIF
43419
43420C...Loop over sparticle and Higgs species.
43421 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
43422C...Find the LSP or NLSP for a gravitino LSP
43423 ILSP=0
43424 PMLSP=1D20
43425 DO 300 I=1,36
43426 KF=KFSUSY(I)
43427 IF(KF.EQ.1000039) GOTO 300
43428 KC=PYCOMP(KF)
43429 IF(PMAS(KC,1).LT.PMLSP) THEN
43430 ILSP=I
43431 PMLSP=PMAS(KC,1)
43432 ENDIF
43433 300 CONTINUE
43434 DO 370 I=1,50
43435 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
43436 KF=KFSUSY(I)
43437 IF (KF.EQ.0) GOTO 370
43438 KC=PYCOMP(KF)
43439 LKNT=0
43440
43441C...Check if there are any decays listed for this sparticle
43442C...in a file
43443 IF (IMSS(22).NE.0) THEN
43444 IFAIL=0
43445C...First look for MASS entry if not already done
43446 IF (IMSS(1).NE.11.AND.IMSS(21).NE.0) CALL PYSLHA(5,KF,IFAIL)
43447C...Then look for decay info
43448 IFAIL=0
43449 CALL PYSLHA(2,KF,IFAIL)
43450 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
43451 ELSEIF (I.GE.37) THEN
43452 GOTO 370
43453 ENDIF
43454
43455C...Sfermion decays.
43456 IF(I.LE.24) THEN
43457C...First check to see if sneutrino is lighter than chi10.
43458 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
43459 & PMAS(KC,1).LT.PMCHI1) THEN
43460 ELSE
43461 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
43462 ENDIF
43463
43464C...Gluino decays.
43465 ELSEIF(I.EQ.25) THEN
43466 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
43467 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
43468
43469C...Neutralino decays.
43470 ELSEIF(I.GE.26.AND.I.LE.29) THEN
43471 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
43472C...chi10 stable or chi10 -> gravitino + gamma.
43473 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
43474 PMAS(KC,2)=1D-6
43475 MDCY(KC,1)=0
43476 MWID(KC)=0
43477 ENDIF
43478
43479C...Chargino decays.
43480 ELSEIF(I.GE.30.AND.I.LE.31) THEN
43481 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
43482
43483C...Gravitino is stable.
43484 ELSEIF(I.EQ.32) THEN
43485 MDCY(KC,1)=0
43486 MWID(KC)=0
43487
43488C...Higgs decays.
43489 ELSEIF(I.GE.33.AND.I.LE.36) THEN
43490C...Calculate decays to non-SUSY particles.
43491 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
43492 LKNT=0
43493 DO 310 I1=0,100
43494 XLAM(I1)=0D0
43495 310 CONTINUE
43496 DO 330 I1=1,MDCY(KC,3)
43497 K1=MDCY(KC,2)+I1-1
43498 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
43499 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
43500 XLAM(I1)=WDTP(I1)
43501 XLAM(0)=XLAM(0)+XLAM(I1)
43502 DO 320 J1=1,3
43503 IDLAM(I1,J1)=KFDP(K1,J1)
43504 320 CONTINUE
43505 LKNT=LKNT+1
43506 330 CONTINUE
43507C...Add the decays to SUSY particles.
43508 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
43509 ENDIF
43510C...Zero the branching ratios for use in loop mode
43511C...thanks to K. Matchev (FNAL)
43512 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
43513 BRAT(IDC)=0D0
43514 340 CONTINUE
43515
43516C...Set stable particles.
43517 IF(LKNT.EQ.0) THEN
43518 MDCY(KC,1)=0
43519 MWID(KC)=0
43520 PMAS(KC,2)=1D-6
43521 PMAS(KC,3)=1D-5
43522 PMAS(KC,4)=0D0
43523
43524C...Store branching ratios in the standard tables.
43525 ELSE
43526 IDC=MDCY(KC,2)+MDCY(KC,3)-1
43527 DELM=1D6
43528 DO 360 IL=1,LKNT
43529 IDCSV=IDC
43530 350 IDC=IDC+1
43531 BRAT(IDC)=0D0
43532 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
43533 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
43534 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
43535 BRAT(IDC)=XLAM(IL)/XLAM(0)
43536 XMDIF=PMAS(KC,1)
43537 IF(MDME(IDC,1).GE.1) THEN
43538 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
43539 & PMAS(PYCOMP(KFDP(IDC,2)),1)
43540 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
43541 & PMAS(PYCOMP(KFDP(IDC,3)),1)
43542 ENDIF
43543 IF(I.LE.32) THEN
43544 IF(XMDIF.GE.0D0) THEN
43545 DELM=MIN(DELM,XMDIF)
43546 ELSE
43547 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
43548 WRITE(MSTU(11),*) ' KF = ',KF
43549 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
43550 ENDIF
43551 ENDIF
43552 GOTO 360
43553 ELSEIF(IDC.EQ.IDCSV) THEN
43554 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
43555 & 'channel not recognized:'
43556 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
43557 GOTO 360
43558 ELSE
43559 GOTO 350
43560 ENDIF
43561 360 CONTINUE
43562
43563C...Store width, cutoff and lifetime.
43564 PMAS(KC,2)=XLAM(0)
43565 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
43566 PMAS(KC,3)=PMAS(KC,2)*10D0
43567 ELSE
43568 PMAS(KC,3)=0.95D0*DELM
43569 ENDIF
43570 IF(PMAS(KC,2).NE.0D0) THEN
43571 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
43572 ENDIF
43573C...Write decays to SLHA file
43574 IF (IMSS(24).NE.0) THEN
43575 IFAIL=0
43576 CALL PYSLHA(4,KF,IFAIL)
43577 ENDIF
43578
43579 ENDIF
43580 370 CONTINUE
43581
43582 RETURN
43583 END
43584C*********************************************************************
43585
43586C...PYSLHA
43587C...Read/write spectrum or decay data from SLHA standard file(s).
43588C...P. Skands
43589
43590C...MUPDA=1 : READ SPECTRUM ON LUN=IMSS(21)
43591C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
43592C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
43593C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
43594C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY (WITH DECAY TABLE)
43595 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
43596
43597C...Double precision and integer declarations.
43598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43599 IMPLICIT INTEGER(I-N)
43600 INTEGER PYK,PYCHGE,PYCOMP
43601 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43602 &KEXCIT=4000000,KDIMEN=5000000)
43603C...Commonblocks.
43604 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43605 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43606 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43607 COMMON/PYDAT4/CHAF(500,2)
43608 CHARACTER CHAF*16
43609 CHARACTER*40 ISAVER,VISAJE
43610 COMMON/PYINT4/MWID(500),WIDS(500,5)
43611 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
43612C...SUSY blocks
43613 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43614 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43615 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43616 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43617 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
43618
43619C...Local arrays, character variables and data.
43620 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
43621 & AU(3,3),AD(3,3),AE(3,3)
43622 COMMON/PYLH3C/CPRO(2),CVER(2)
43623 SAVE /PYLH3P/,/PYLH3C/
43624 DIMENSION MMOD(100),MSPC(100),MDEC(100)
43625C...MMOD: flags to set for each block read in.
43626C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
43627C...MSPC: Flags to set for each block read in.
43628C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
43629C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
43630C...11: AD 12: AE 13: YU 14: YD 15: YE
43631C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
43632 CHARACTER CPRO*12,CVER*12,CHNLIN*6
43633 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
43634 CHARACTER CHINL*120,CHKF*9,CHTMP*16
43635 INTEGER VERBOS
43636 SAVE VERBOS
43637C...Date of last Change
43638 PARAMETER (DOC='05 Mar 2007')
43639C...MQREAD(0): Number of entries I in MQREAD
43640C... (I): KF code for which a QNUMBERS block has been read.
43641 DIMENSION IDC(5),KFSUSY(50),MQREAD(0:100)
43642 SAVE KFSUSY,MQREAD
43643 DATA VERBOS /1/
43644 DATA NHELLO /0/
43645 DATA KFSUSY/
43646 &1000001,1000002,1000003,1000004,1000005,1000006,
43647 &2000001,2000002,2000003,2000004,2000005,2000006,
43648 &1000011,1000012,1000013,1000014,1000015,1000016,
43649 &2000011,2000012,2000013,2000014,2000015,2000016,
43650 &1000021,1000022,1000023,1000025,1000035,1000024,
43651 &1000037,1000039, 25, 35, 36, 37,
43652 & 6, 24, 45, 46,1000045, 9*0/
43653 RMFUN(IP)=PMAS(PYCOMP(IP),1)
43654
43655C...Hello World
43656 IF (NHELLO.EQ.0) THEN
43657 WRITE(MSTU(11),5000) DOC
43658 NHELLO=1
43659 ENDIF
43660
43661C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
43662C...+MUPDA).
43663 LFN=IMSS(20+MUPDA)
43664 IF (MUPDA.EQ.5) LFN=IMSS(21)
43665 IF (MUPDA.EQ.0) LFN=IMSS(21)
43666C...Flag that we have not yet found whatever we were asked to find.
43667 IRETRN=1
43668
43669C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
43670 IF (LFN.EQ.0) THEN
43671 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
43672 GOTO 9999
43673 ENDIF
43674
43675C...If told to read spectrum, first zero all previous information.
43676 IF (MUPDA.EQ.1) THEN
43677C...Zero all block read flags
43678 DO 100 M=1,100
43679 MMOD(M)=0
43680 MSPC(M)=0
43681 MDEC(M)=0
43682 100 CONTINUE
43683C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
43684 DO 110 ISUSY=1,36
43685 KC=PYCOMP(KFSUSY(ISUSY))
43686 PMAS(KC,1)=0D0
43687 PMAS(KC,2)=0D0
43688 PMAS(KC,3)=0D0
43689 PMAS(KC,4)=0D0
43690 110 CONTINUE
43691C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
43692 DO 130 J=1,4
43693 SFMIX(5,J) =0D0
43694 SFMIX(6,J) =0D0
43695 SFMIX(15,J)=0D0
43696 DO 120 L=1,4
43697 ZMIX(L,J) =0D0
43698 ZMIXI(L,J)=0D0
43699 IF (J.LE.2.AND.L.LE.2) THEN
43700 UMIX(L,J) =0D0
43701 UMIXI(L,J)=0D0
43702 VMIX(L,J) =0D0
43703 VMIXI(L,J)=0D0
43704 ENDIF
43705 120 CONTINUE
43706C...Zero signed masses.
43707 SMZ(J)=0D0
43708 IF (J.LE.2) SMW(J)=0D0
43709 130 CONTINUE
43710C...NB: RMSS array not zeroed.
43711 WRITE(MSTU(11),*)
43712 & '* (PYSLHA:) Reading in SLHA spectrum from unit ', LFN
43713
43714C...If reading decays, reset PYTHIA decay counters.
43715 ELSEIF (MUPDA.EQ.2) THEN
43716 KCC=100
43717 NDC=0
43718 BRSUM=0D0
43719 DO 140 KC=1,MSTU(6)
43720 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
43721 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
43722 140 CONTINUE
43723 ELSEIF (MUPDA.EQ.5) THEN
43724C...Zero block read flags
43725 DO 150 M=1,100
43726 MSPC(M)=0
43727 150 CONTINUE
43728 ENDIF
43729
43730C............READ
43731C...(spectrum or look for decays of KF=KFORIG or MASS of KF=KFORIG
43732 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
43733C...Initialize program and version strings
43734 CPRO(MUPDA)=' '
43735 CVER(MUPDA)=' '
43736
43737C...Initialize read loop
43738 MERR=0
43739 NLINE=0
43740 CHBLCK=' '
43741C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
43742 160 CHINL=' '
43743 READ(LFN,'(A120)',END=300) CHINL
43744C...Count which line number we're at.
43745 NLINE=NLINE+1
43746 WRITE(CHNLIN,'(I6)') NLINE
43747
43748C...Skip comment and empty lines without processing.
43749 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 160
43750
43751C...We assume all upper case below. Rewrite CHINL to all upper case.
43752 INL=0
43753 IGOOD=0
43754 170 INL=INL+1
43755 IF (CHINL(INL:INL).NE.'#') THEN
43756 DO 180 ICH=97,122
43757 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
43758 180 CONTINUE
43759C...Extra safety. Chek for sensible input on line
43760 IF (IGOOD.EQ.0) THEN
43761 DO 190 ICH=48,90
43762 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
43763 190 CONTINUE
43764 ENDIF
43765 IF (INL.LT.120) GOTO 170
43766 ENDIF
43767 IF (IGOOD.EQ.0) GOTO 160
43768
43769C...Check for BLOCK begin statement (spectrum).
43770 IF (CHINL(1:1).EQ.'B') THEN
43771 MERR=0
43772 READ(CHINL,'(A6,A)',ERR=460) CHDUM,CHBLCK
43773C...Check if another of this type of block was already read.
43774C...(logarithmic interpolation not yet implemented, so duplicates always
43775C...give errors)
43776 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
43777 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
43778 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
43779 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
43780 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
43781 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
43782 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
43783 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
43784 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
43785 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
43786 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
43787 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
43788 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
43789 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
43790 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
43791 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
43792 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
43793C...Check for new particles
43794 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
43795 & THEN
43796 MSPC(19)=MSPC(19)+1
43797C...Read PDG code
43798 READ(CHBLCK(9:60),*) KFQ
43799
43800 DO 121 MQ=1,MQREAD(0)
43801 IF (MQREAD(MQ).EQ.KFQ) THEN
43802 MERR=17
43803 GOTO 290
43804 ENDIF
43805 121 CONTINUE
43806 WRITE(MSTU(11),'(A,I9,A,F12.3)')
43807 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
43808 & ' for KF =',KFQ
43809 MQREAD(0)=MQREAD(0)+1
43810 MQREAD(MQREAD(0))=KFQ
43811 MSPC(19)=MSPC(19)+1
43812 KCQ=PYCOMP(KFQ)
43813 IF (KCQ.EQ.0) THEN
43814 DO 123 KCT=100,MSTU(6)
43815 IF(KCHG(KCT,4).GT.100) KCQ=KCT
43816 123 CONTINUE
43817 KCQ=KCQ+1
43818 KCC=KCQ
43819 KCHG(KCQ,4)=KFQ
43820C...First write PDG code as name
43821 WRITE(CHTMP,*) KFQ
43822C...Then look for real name
43823 ICMT=9
43824 90 ICMT=ICMT+1
43825 IF (CHBLCK(ICMT:ICMT).NE.'#'.AND.ICMT.LT.59) GOTO 90
43826 IF (ICMT.LT.59) THEN
43827 READ(CHBLCK(ICMT+1:60),'(A)',ERR=95) CHDUM
43828 IF (CHDUM.NE.' ') CHTMP=CHDUM
43829 ENDIF
43830 95 IF (CHTMP(1:1).EQ.' ') THEN
43831 READ(CHTMP,'(1x,A)') CHAF(KCQ,1)
43832 ELSE
43833 READ(CHTMP,'(A)') CHAF(KCQ,1)
43834 ENDIF
43835 MSTU(20)=0
43836C...Set stable for now
43837 PMAS(KCQ,2)=1D-6
43838 MWID(KCQ)=0
43839 MDCY(KCQ,1)=0
43840 MDCY(KCQ,2)=0
43841 MDCY(KCQ,3)=0
43842 ELSE
43843 WRITE(MSTU(11),*)
43844 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
43845 & CHAF(KCQ,1), '. Entry ignored.'
43846 MERR=7
43847 ENDIF
43848 ENDIF
43849C...Finalize this line and read next.
43850 GOTO 290
43851C...Check for DECAY begin statement (decays).
43852 ELSEIF (CHINL(1:1).EQ.'D') THEN
43853 MERR=0
43854 BRSUM=0D0
43855 CHBLCK='DECAY'
43856C...Read KF code and WIDTH
43857 MPSIGN=1
43858 READ(CHINL(7:INL),*,ERR=470) KF, WIDTH
43859 IF (KF.LE.0) THEN
43860 KF=-KF
43861 MPSIGN=-1
43862 ENDIF
43863C...If this is not the KF we're looking for...
43864 IF (KF.NE.KFORIG.OR.MUPDA.NE.2) THEN
43865C...Set block skip flag and read next line.
43866 MERR=16
43867 GOTO 290
43868 ENDIF
43869
43870C...Determine PYTHIA KC code of particle
43871 KCREP=0
43872 IF(KF.LE.100) THEN
43873 KCREP=KF
43874 ELSE
43875 DO 200 KCR=101,KCC
43876 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
43877 200 CONTINUE
43878 ENDIF
43879 KC=KCREP
43880 IF (KCREP.NE.0) THEN
43881C...Particle is already known. Don't do anything yet.
43882 ELSE
43883C... Add new particle. Actually, this should not happen.
43884C... New particles should be added already when reading the spectrum
43885C... information, so go under previously stable category.
43886 KCC=KCC+1
43887 KC=KCC
43888 ENDIF
43889
43890 IF (WIDTH.LE.0D0) THEN
43891C...Stable (i.e. LSP)
43892 WRITE(MSTU(11),*)
43893 & '* (PYSLHA:) Reading in SLHA stable particle: ',
43894 & CHAF(KCREP,1)
43895 IF (WIDTH.LT.0D0) THEN
43896 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
43897 & ' zero !')
43898 WIDTH=0D0
43899 ENDIF
43900 PMAS(KC,2)=1D-6
43901 MWID(KC)=0
43902 MDCY(KC,1)=0
43903C...Ignore any decay lines that may be present for this KF
43904 MERR=16
43905 MDCY(KC,2)=0
43906 MDCY(KC,3)=0
43907C...Return ok
43908 IRETRN=0
43909 ENDIF
43910C...Finalize and start reading in decay modes.
43911 GOTO 290
43912 ELSEIF (MOD(MERR,10).GE.6) THEN
43913C...If ignore block flag set, skip directly to next line.
43914 GOTO 160
43915 ENDIF
43916
43917C...READ SPECTRUM
43918 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
43919 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
43920 & THEN
43921 READ(CHINL,*) INDX, IVAL
43922 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
43923 IF (INDX.EQ.3) KCHG(KCQ,2)=0
43924 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
43925 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
43926 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
43927 IF (INDX.EQ.4) THEN
43928 KCHG(KCQ,3)=IVAL
43929 IF (IVAL.EQ.1) THEN
43930 CHTMP=CHAF(KCQ,1)
43931 IF (CHTMP.EQ.' ') THEN
43932 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
43933 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
43934 ELSE
43935 ILAST=17
43936 116 ILAST=ILAST-1
43937 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 116
43938 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
43939 CHTMP(ILAST:ILAST)='-'
43940 ELSE
43941 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
43942 ENDIF
43943 CHAF(KCQ,2)=CHTMP
43944 ENDIF
43945 ENDIF
43946 ENDIF
43947 ELSE
43948 MERR=8
43949 ENDIF
43950 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
43951C...MASS: Mass spectrum
43952 IF (CHBLCK(1:4).EQ.'MASS') THEN
43953 READ(CHINL,*) KF, VAL
43954 MERR=1
43955 KC=0
43956 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG) THEN
43957C...Read in masses for anything
43958 MERR=0
43959 KC=PYCOMP(KF)
43960 IF (KC.NE.0) THEN
43961 MSPC(1)=MSPC(1)+1
43962 PMAS(KC,1) = ABS(VAL)
43963 IF (MUPDA.EQ.5) THEN
43964 WRITE(MSTU(11),'(A,I9,A,F12.3)')
43965 & ' * (PYSLHA:) Reading in MASS entry for KF =',
43966 & KF, ', pole mass =', VAL
43967 IRETRN=0
43968 ENDIF
43969C... Signed masses
43970 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
43971 IF (KF.EQ.1000022) SMZ(1)=VAL
43972 IF (KF.EQ.1000023) SMZ(2)=VAL
43973 IF (KF.EQ.1000025) SMZ(3)=VAL
43974 IF (KF.EQ.1000035) SMZ(4)=VAL
43975 IF (KF.EQ.1000024) SMW(1)=VAL
43976 IF (KF.EQ.1000037) SMW(2)=VAL
43977 ENDIF
43978 ELSEIF (MUPDA.EQ.5) THEN
43979 MERR=0
43980 ENDIF
43981 ELSEIF (MUPDA.EQ.5) THEN
43982C...Only read MASS if MUPDA = 5. Skip any other blocks.
43983 MERR=8
43984 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
43985 & CHBLCK(1:8).EQ.'PARTICLE') THEN
43986C...Don't print a warning for QNUMBERS when reading spectrum
43987 MERR=8
43988C... MODSEL: Model selection and global switches
43989 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
43990 READ(CHINL,*) INDX, IVAL
43991 IF (INDX.LE.200.AND.INDX.GT.0) THEN
43992 MODSEL(INDX)=IVAL
43993 MMOD(1)=MMOD(1)+1
43994 IF (INDX.EQ.3.AND.IVAL.EQ.1) THEN
43995C... Switch on NMSSM
43996 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
43997 IMSS(13)=MAX(1,IMSS(13))
43998C... Add NMSSM states if not already done
43999
44000 KFN=25
44001 KCN=KFN
44002 CHAF(KCN,1)='H_10'
44003 CHAF(KCN,2)=' '
44004
44005 KFN=35
44006 KCN=KFN
44007 CHAF(KCN,1)='H_20'
44008 CHAF(KCN,2)=' '
44009
44010 KFN=45
44011 KCN=KFN
44012 CHAF(KCN,1)='H_30'
44013 CHAF(KCN,2)=' '
44014
44015 KFN=36
44016 KCN=KFN
44017 CHAF(KCN,1)='A_10'
44018 CHAF(KCN,2)=' '
44019
44020 KFN=46
44021 KCN=KFN
44022 CHAF(KCN,1)='A_20'
44023 CHAF(KCN,2)=' '
44024
44025 KFN=1000045
44026 KCN=PYCOMP(KFN)
44027 IF (KCN.EQ.0) THEN
44028 DO 234 KCT=100,MSTU(6)
44029 IF(KCHG(KCT,4).GT.100) KCN=KCT
44030 234 CONTINUE
44031 KCN=KCN+1
44032 KCHG(KCN,4)=KFN
44033 MSTU(20)=0
44034 ENDIF
44035C... Set stable for now
44036 PMAS(KCN,2)=1D-6
44037 MWID(KCN)=0
44038 MDCY(KCN,1)=0
44039 MDCY(KCN,2)=0
44040 MDCY(KCN,3)=0
44041 CHAF(KCN,1)='~chi_50'
44042 CHAF(KCN,2)=' '
44043 ENDIF
44044 ELSE
44045 MERR=1
44046 ENDIF
44047C...MINPAR: Minimal model parameters
44048 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
44049 IF (MODSEL(1).NE.0) THEN
44050 READ(CHINL,*) INDX, VAL
44051 IF (INDX.LE.100.AND.INDX.GT.0) THEN
44052 PARMIN(INDX)=VAL
44053 MMOD(2)=MMOD(2)+1
44054 ELSE
44055 MERR=1
44056 ENDIF
44057 ELSEIF (MMOD(3).NE.0) THEN
44058 WRITE(MSTU(11),*)
44059 & '* (PYSLHA:) MINPAR after EXTPAR !'
44060 MERR=1
44061 ELSE
44062 WRITE(MSTU(11),*)
44063 & '* (PYSLHA:) Reading MINPAR, but no MODSEL !'
44064 MERR=1
44065 ENDIF
44066C...tan(beta)
44067 IF (INDX.EQ.3) RMSS(5)=VAL
44068C...EXTPAR: non-minimal model parameters.
44069 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
44070 IF (MMOD(1).NE.0) THEN
44071 READ(CHINL,*) INDX, VAL
44072 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44073 PAREXT(INDX)=VAL
44074 MMOD(3)=MMOD(3)+1
44075 ELSE
44076 MERR=1
44077 ENDIF
44078 ELSE
44079 WRITE(MSTU(11),*)
44080 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
44081 MERR=1
44082 ENDIF
44083C...tan(beta)
44084 IF (INDX.EQ.25) RMSS(5)=VAL
44085 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
44086 READ(CHINL,*) INDX, VAL
44087 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
44088 MERR=1
44089 ELSEIF (INDX.EQ.4) THEN
44090 PMAS(PYCOMP(23),1)=VAL
44091 ELSEIF (INDX.EQ.6) THEN
44092 PMAS(PYCOMP(6),1)=VAL
44093 ENDIF
44094 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
44095 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
44096 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
44097 $ THEN
44098C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
44099 IM=0
44100 IF (CHBLCK(5:6).EQ.'IM') IM=1
44101 250 READ(CHINL,*) INDX1, INDX2, VAL
44102 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
44103 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
44104 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
44105 MSPC(2)=MSPC(2)+1
44106 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
44107 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
44108 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
44109 MSPC(3)=MSPC(3)+1
44110 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
44111 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
44112 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
44113 MSPC(4)=MSPC(4)+1
44114 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
44115 $ .CHBLCK(1:4).EQ.'STAU') THEN
44116 IF (CHBLCK(1:4).EQ.'STOP') THEN
44117 KFSM=6
44118 ISPC=6
44119 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
44120 KFSM=5
44121 ISPC=5
44122 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
44123 KFSM=15
44124 ISPC=7
44125 ENDIF
44126C...Set SFMIX element
44127 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
44128 MSPC(ISPC)=MSPC(ISPC)+1
44129 ENDIF
44130C...Running parameters
44131 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
44132 READ(CHBLCK(8:25),*,ERR=510) Q
44133 READ(CHINL,*) INDX, VAL
44134 MSPC(8)=MSPC(8)+1
44135 IF (INDX.EQ.1) THEN
44136 RMSS(4) = VAL
44137 ELSE
44138 MERR=1
44139 MSPC(8)=MSPC(8)-1
44140 ENDIF
44141 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
44142 READ(CHINL,*,ERR=520) VAL
44143 RMSS(18)= VAL
44144 MSPC(17)=MSPC(17)+1
44145C...Higgs parameters set manually or with FeynHiggs.
44146 IMSS(4)=MAX(2,IMSS(4))
44147 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
44148 & .CHBLCK(1:2).EQ.'AE') THEN
44149 READ(CHBLCK(9:26),*,ERR=510) Q
44150 READ(CHINL,*) INDX1, INDX2, VAL
44151 IF (CHBLCK(2:2).EQ.'U') THEN
44152 AU(INDX1,INDX2)=VAL
44153 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
44154 MSPC(11)=MSPC(11)+1
44155 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
44156 AD(INDX1,INDX2)=VAL
44157 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
44158 MSPC(10)=MSPC(10)+1
44159 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
44160 AE(INDX1,INDX2)=VAL
44161 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
44162 MSPC(12)=MSPC(12)+1
44163 ELSE
44164 MERR=1
44165 ENDIF
44166 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
44167 IF (MSPC(18).EQ.0) THEN
44168 READ(CHBLCK(9:25),*,ERR=510) Q
44169 RMSOFT(0)=Q
44170 ENDIF
44171 READ(CHINL,*) INDX, VAL
44172 RMSOFT(INDX)=VAL
44173 MSPC(18)=MSPC(18)+1
44174 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
44175 MERR=8
44176 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
44177 & .CHBLCK(1:2).EQ.'YE') THEN
44178 MERR=8
44179 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
44180 READ(CHINL(1:6),*) INDX
44181 IT=0
44182 MIRD=0
44183 260 IT=IT+1
44184 IF (CHINL(IT:IT).EQ.' ') GOTO 260
44185C...Don't read index
44186 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
44187 MIRD=1
44188 GOTO 260
44189 ENDIF
44190 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
44191 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
44192 ELSE
44193C... Set unrecognized block flag.
44194 MERR=6
44195 ENDIF
44196
44197C...DECAY TABLES
44198C...Read in decay information
44199 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
44200C...Read new decay chanel
44201 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
44202 NDC=NDC+1
44203C...Read in branching ratio and number of daughters for this mode.
44204 READ(CHINL(4:50),*,ERR=480) BRAT(NDC)
44205 READ(CHINL(4:50),*,ERR=490) DUM, NDA
44206 IF (NDA.LE.5) THEN
44207 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
44208 & '(PYSLHA:) Decay data arrays full by KF ='
44209 $ //CHAF(KC,1))
44210C...If first decay chanel, set decays start point in decay table
44211 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
44212 WRITE(MSTU(11),*)
44213 & '* (PYSLHA:) Reading in SLHA decay table for ',
44214 & CHAF(KCREP,1)
44215C...Set particle parameters (mass set when reading BLOCK MASS above)
44216 PMAS(KC,2)=WIDTH
44217 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
44218 WRITE(MSTU(11),*)
44219 & '* Note: the Pythia gg->h/H/A cross section'//
44220 & ' is proportional to the h/H/A->gg width'
44221 ENDIF
44222 PMAS(KC,3)=0D0
44223 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
44224 MWID(KC)=2
44225 MDCY(KC,1)=1
44226 MDCY(KC,2)=NDC
44227 MDCY(KC,3)=0
44228C...Return ok
44229 IRETRN=0
44230 ENDIF
44231C... Count up number of decay modes for this particle
44232 MDCY(KC,3)=MDCY(KC,3)+1
44233C... Read in decay daughters.
44234 READ(CHINL(4:120),*,ERR=500) DUM,IDM, (IDC(IDA),IDA=1,NDA)
44235C... Flip sign if reading antiparticle decays (if antipartner exists)
44236 DO 270 IDA=1,NDA
44237 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
44238 & IDC(IDA)=MPSIGN*IDC(IDA)
44239 270 CONTINUE
44240C...Switch on decay channel, with products ordered in decreasing ABS(KF)
44241 MDME(NDC,1)=1
44242 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
44243 BRSUM=BRSUM+ABS(BRAT(NDC))
44244 BRAT(NDC)=ABS(BRAT(NDC))
44245 274 IFLIP=0
44246 DO 277 IDA=1,NDA-1
44247 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
44248 ITMP=IDC(IDA)
44249 IDC(IDA)=IDC(IDA+1)
44250 IDC(IDA+1)=ITMP
44251 IFLIP=IFLIP+1
44252 ENDIF
44253 277 CONTINUE
44254 IF (IFLIP.GT.0) GOTO 274
44255C WRITE(MSTU(11),7510) BRAT(NDC), NDA, (IDC(IDA),IDA=1,NDA)
44256C...Treat as ordinary decay, no fancy stuff.
44257 MDME(NDC,2)=0
44258 DO 280 IDA=1,5
44259 IF (IDA.LE.NDA) THEN
44260 KFDP(NDC,IDA)=IDC(IDA)
44261 ELSE
44262 KFDP(NDC,IDA)=0
44263 ENDIF
44264 280 CONTINUE
44265 ELSE
44266 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
44267 & CHNLIN)
44268 MERR=11
44269 NDC=NDC-1
44270 ENDIF
44271 ELSEIF(CHINL(1:1).EQ.'+') THEN
44272 MERR=11
44273 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
44274 MERR=16
44275 ELSE
44276 MERR=16
44277 ENDIF
44278 ENDIF
44279C... Error check.
44280 290 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
44281 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
44282 & //CHINL(1:40)
44283 MERR=0
44284 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
44285 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
44286 & CHBLCK(1:INL)//'... on line'//CHNLIN
44287 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
44288 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
44289 & //CHBLCK(1:INL)//'... on line'//CHNLIN
44290 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS(21).EQ.0.AND.
44291 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
44292 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
44293 & //'... on line'//CHNLIN
44294 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
44295 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
44296 & /CHBLCK(1:INL)//'... on line'//CHNLIN
44297 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
44298 WRITE (CHTMP,*) KF
44299 WRITE(MSTU(11),*)
44300 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
44301 & CHTMP(1:9)//' on line'//CHNLIN
44302 ENDIF
44303C... End of loop
44304 GOTO 160
44305 300 CONTINUE
44306C...Set flag that KC codes have been rearranged.
44307 MSTU(20)=0
44308 VERBOS=0
44309
44310C...Perform possible tests that new information is consistent.
44311 IF (MUPDA.EQ.1) THEN
44312 MSTU23=MSTU(23)
44313 MSTU27=MSTU(27)
44314C...Check Z and top masses
44315 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
44316 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
44317 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
44318 ENDIF
44319 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
44320 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
44321 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
44322 & //CHTMP//'GeV')
44323 ENDIF
44324C...Check masses
44325 DO 310 ISUSY=1,37
44326 KF=KFSUSY(ISUSY)
44327C...Don't complain about right-handed neutrinos
44328 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
44329 & +16) GOTO 310
44330C...Only check gravitino in GMSB scenarios
44331 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 310
44332 KC=PYCOMP(KF)
44333 IF (PMAS(KC,1).EQ.0D0) THEN
44334 WRITE(CHTMP,*) KF
44335 CALL PYERRM(9
44336 & ,'(PYSLHA:) No mass information found for KF = '
44337 & //CHTMP)
44338 ENDIF
44339 310 CONTINUE
44340C...Check mixing matrices (MSSM only)
44341 IF (IMSS(13).EQ.0) THEN
44342 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
44343 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
44344 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
44345 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
44346 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
44347 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
44348 IF (MSPC(5).NE.4) CALL PYERRM(9
44349 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
44350 IF (MSPC(6).NE.4) CALL PYERRM(9
44351 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
44352 IF (MSPC(7).NE.4) CALL PYERRM(9
44353 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
44354 IF (MSPC(8).LT.1) CALL PYERRM(9
44355 & ,'(PYSLHA:) Too few elements in HMIX')
44356 IF (MSPC(10).EQ.0) CALL PYERRM(9
44357 & ,'(PYSLHA:) Missing A_b trilinear coupling')
44358 IF (MSPC(11).EQ.0) CALL PYERRM(9
44359 & ,'(PYSLHA:) Missing A_t trilinear coupling')
44360 IF (MSPC(12).EQ.0) CALL PYERRM(9
44361 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
44362 IF (MSPC(17).LT.1) CALL PYERRM(9
44363 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
44364 ENDIF
44365C...Check wavefunction normalizations.
44366C...Sfermions
44367 DO 320 ISPC=5,7
44368 IF (MSPC(ISPC).EQ.4) THEN
44369 KFSM=ISPC
44370 IF (ISPC.EQ.7) KFSM=15
44371 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
44372 & *SFMIX(KFSM,3))
44373 IF (ABS(1D0-CHECK).GT.1D-3) THEN
44374 KCSM=PYCOMP(KFSM)
44375 CALL PYERRM(17
44376 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
44377 & //CHAF(KCSM,1))
44378 ENDIF
44379 ENDIF
44380 320 CONTINUE
44381C...Neutralinos + charginos
44382 DO 340 J=1,4
44383 CN1=0D0
44384 CN2=0D0
44385 CU1=0D0
44386 CU2=0D0
44387 CV1=0D0
44388 CV2=0D0
44389 DO 330 L=1,4
44390 CN1=CN1+ZMIX(J,L)**2
44391 CN2=CN2+ZMIX(L,J)**2
44392 IF (J.LE.2.AND.L.LE.2) THEN
44393 CU1=CU1+UMIX(J,L)**2
44394 CU2=CU2+UMIX(L,J)**2
44395 CV1=CV1+VMIX(J,L)**2
44396 CV2=CV2+VMIX(L,J)**2
44397 ENDIF
44398 330 CONTINUE
44399C...NMIX normalization
44400 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
44401 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
44402 CALL PYERRM(19,
44403 & '(PYSLHA:) NMIX: Inconsistent normalization.')
44404 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
44405 ENDIF
44406C...UMIX, VMIX normalizations
44407 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
44408 IF (J.LE.2) THEN
44409 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
44410 CALL PYERRM(19
44411 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
44412 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
44413 & CU2
44414 ENDIF
44415 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
44416 CALL PYERRM(19,
44417 & '(PYSLHA:) VMIX: Inconsistent normalization.')
44418 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
44419 & CV2
44420 ENDIF
44421 ENDIF
44422 ENDIF
44423 340 CONTINUE
44424 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
44425 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
44426 & '* PYSLHA: No spectrum inconsistencies were found.'
44427 ELSE
44428 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
44429 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
44430 & ,'Warning: one or more (serious)'//
44431 & ' inconsistencies were found in the spectrum!!!'
44432 & ,'Read the error messages above and check your'//
44433 & ' input file.'
44434 ENDIF
44435C...Increase precision in Higgs sector using FeynHiggs
44436 IF (IMSS(4).EQ.3) THEN
44437C...FeynHiggs needs MSOFT.
44438 IERR=0
44439 IF (MSPC(18).EQ.0) THEN
44440 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
44441 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
44442 & ' Cannot call FeynHiggs.'
44443 IERR=-1
44444 ELSE
44445 WRITE(MSTU(11),'(1x,/1x,A/)')
44446 & '* (PYSLHA:) Now calling FeynHiggs.'
44447 CALL PYFEYN(IERR)
44448 IF (IERR.NE.0) IMSS(4)=2
44449 ENDIF
44450 ENDIF
44451 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0) THEN
44452 KF=KFORIG
44453 KC=PYCOMP(KF)
44454 WRITE(CHKF,8300) KF
44455 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
44456 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
44457 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
44458 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
44459 $ //CHKF)
44460 BRSUM=0D0
44461 BROPN=0D0
44462 DO 360 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44463 IF(MDME(IDA,2).GT.80) GOTO 360
44464 KQ=KCHG(KC,1)
44465 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
44466 MERR=0
44467 DO 350 J=1,5
44468 KP=KFDP(IDA,J)
44469 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
44470 IF(KP.EQ.81) KQ=0
44471 ELSEIF(PYCOMP(KP).EQ.0) THEN
44472 MERR=3
44473 ELSE
44474 KQ=KQ-PYCHGE(KP)
44475 KPC=PYCOMP(KP)
44476 PMS=PMS-PMAS(KPC,1)
44477 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
44478 & PMAS(KPC,3))
44479 ENDIF
44480 350 CONTINUE
44481 IF(KQ.NE.0) MERR=MAX(2,MERR)
44482 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
44483 & MERR=MAX(1,MERR)
44484 IF(MERR.EQ.3) CALL PYERRM(17,
44485 & '(PYSLHA:) Unknown particle code in decay of KF ='
44486 $ //CHKF)
44487 IF(MERR.EQ.2) CALL PYERRM(17,
44488 & '(PYSLHA:) Charge not conserved in decay of KF ='
44489 $ //CHKF)
44490 IF(MERR.EQ.1) CALL PYERRM(7,
44491 & '(PYSLHA:) Kinematically unallowed decay of KF ='
44492 $ //CHKF)
44493 BRSUM=BRSUM+BRAT(IDA)
44494 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
44495 360 CONTINUE
44496C...Check branching ratio sum.
44497 IF (BROPN.LE.0D0) THEN
44498C...If zero, set stable.
44499 WRITE(CHTMP,8500) BROPN
44500 CALL PYERRM(7
44501 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
44502 & CHTMP(9:16)//'. Changed to stable.')
44503 PMAS(KC,2)=1D-6
44504 MWID(KC)=0
44505C...If BR's > 1, rescale.
44506 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
44507 WRITE(CHTMP,8500) BRSUM
44508 CALL PYERRM(7
44509 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
44510 & ' ; sum was'//CHTMP(9:16)//'.')
44511 FAC=1D0/BRSUM
44512 DO 370 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44513 IF(MDME(IDA,2).GT.80) GOTO 370
44514 BRAT(IDA)=FAC*BRAT(IDA)
44515 370 CONTINUE
44516 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
44517C...If BR's < 1, insert dummy mode for proper cross section rescaling.
44518 WRITE(CHTMP,8500) BRSUM
44519 CALL PYERRM(7
44520 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
44521 & CHTMP(9:16)//'. Dummy mode will be inserted.')
44522C... Insert dummy mode
44523 MDCY(KC,3)=MDCY(KC,3)+1
44524 IDA=MDCY(KC,2)+MDCY(KC,3)-1
44525 BRAT(IDA)=1D0-BRSUM
44526 KFDP(IDA,1)=0
44527 KFDP(IDA,2)=0
44528 KFDP(IDA,3)=0
44529 KFDP(IDA,4)=0
44530 KFDP(IDA,5)=0
44531 MDME(IDA,1)=0
44532 BRSUM=1D0
44533 ENDIF
44534 ENDIF
44535
44536C...WRITE SPECTRUM ON SLHA FILE
44537 ELSEIF(MUPDA.EQ.3) THEN
44538C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
44539 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
44540 MODSEL(1)=1
44541 PARMIN(1)=RMSS(8)
44542 PARMIN(2)=RMSS(1)
44543 PARMIN(3)=RMSS(5)
44544 PARMIN(4)=SIGN(1D0,RMSS(4))
44545 PARMIN(5)=RMSS(36)
44546 ENDIF
44547C...Write spectrum
44548 WRITE(LFN,7000) 'SLHA MSSM spectrum'
44549 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
44550 & // ' P. Skands.'
44551 WRITE(LFN,7010) 'MODSEL', 'Model selection'
44552 WRITE(LFN,7110) 1, MODSEL(1)
44553 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
44554 IF (MODSEL(1).EQ.1) THEN
44555 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
44556 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
44557 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
44558 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
44559 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
44560 ELSEIF(MODSEL(2).EQ.2) THEN
44561 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
44562 WRITE(LFN,7210) 2, PARMIN(2), 'M'
44563 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
44564 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
44565 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
44566 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
44567 ENDIF
44568 WRITE(LFN,7000) ' '
44569 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
44570 DO 380 I=1,36
44571 KF=KFSUSY(I)
44572 KC=PYCOMP(KF)
44573 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 380
44574 KFSM=KF-KSUSY1
44575 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
44576 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
44577 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
44578 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
44579 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
44580 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
44581 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
44582 ELSE
44583 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
44584 ENDIF
44585 380 CONTINUE
44586C...SUSY scale
44587 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
44588 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
44589 WRITE(LFN,7210) 1, RMSS(4),'mu'
44590 WRITE(LFN,7010) 'ALPHA',' '
44591 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
44592 WRITE(LFN,7020) 'AU',RMSUSY
44593 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
44594 WRITE(LFN,7020) 'AD',RMSUSY
44595 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
44596 WRITE(LFN,7020) 'AE',RMSUSY
44597 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
44598 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
44599 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
44600 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
44601 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
44602 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
44603 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
44604 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
44605 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
44606 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
44607 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
44608 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
44609 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
44610 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
44611 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
44612 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
44613 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
44614 DO 400 I1=1,4
44615 DO 390 I2=1,4
44616 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
44617 390 CONTINUE
44618 400 CONTINUE
44619 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
44620 DO 420 I1=1,2
44621 DO 410 I2=1,2
44622 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
44623 410 CONTINUE
44624 420 CONTINUE
44625 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
44626 DO 440 I1=1,2
44627 DO 430 I2=1,2
44628 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
44629 430 CONTINUE
44630 440 CONTINUE
44631 WRITE(LFN,7010) 'SPINFO'
44632 IF (IMSS(1).EQ.2) THEN
44633 CPRO(1)='PYTHIA'
44634 CVER(1)='6.4'
44635 ELSEIF (IMSS(1).EQ.12) THEN
44636 ISAVER=VISAJE()
44637 CPRO(1)='ISASUSY'
44638 CVER(1)=ISAVER(1:12)
44639 ENDIF
44640 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
44641 WRITE(LFN,7310) 2, CVER(1), 'Version number'
44642 ENDIF
44643
44644C...Print user information about spectrum
44645 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
44646 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
44647 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
44648 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
44649 IF (MUPDA.EQ.1) THEN
44650 WRITE(MSTU(11),5020) LFN
44651 ELSE
44652 WRITE(MSTU(11),5010) LFN
44653 ENDIF
44654
44655 WRITE(MSTU(11),5400)
44656 WRITE(MSTU(11),5500) 'Pole masses'
44657 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
44658 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
44659 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
44660 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
44661 IF (IMSS(13).EQ.0) THEN
44662 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
44663 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
44664 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
44665 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
44666 & CHAF(37,1), ' ', ' ',' ',' ',
44667 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
44668 ELSEIF (IMSS(13).EQ.1) THEN
44669 KF1=KSUSY1+21
44670 KF2=KSUSY1+22
44671 KF3=KSUSY1+23
44672 KF4=KSUSY1+25
44673 KF5=KSUSY1+35
44674 KF6=KSUSY1+45
44675 KF7=KSUSY1+24
44676 KF8=KSUSY1+37
44677 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
44678 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
44679 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
44680 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
44681 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
44682 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
44683 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
44684 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
44685 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
44686 & RMFUN(37)
44687 ENDIF
44688 WRITE(MSTU(11),5400)
44689 WRITE(MSTU(11),5500) 'Mixing structure'
44690 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
44691 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
44692 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
44693 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
44694 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
44695 & ),(SFMIX(15,J),J=3,4)
44696 WRITE(MSTU(11),5400)
44697 WRITE(MSTU(11),5500) 'Couplings'
44698 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
44699 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
44700 WRITE(MSTU(11),5400)
44701 WRITE(MSTU(11),6500)
44702
44703 ENDIF
44704
44705C...Only rewind when reading
44706 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
44707
44708 9999 RETURN
44709
44710C...Serious error catching
44711 460 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
44712 write(*,*) CHINL(1:80)
44713 STOP
44714 470 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
44715 WRITE(*,*) CHINL(1:72)
44716 STOP
44717 480 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE
44718 WRITE(*,*) CHINL(1:80)
44719 STOP
44720 490 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
44721 WRITE(*,*) CHINL(1:80)
44722 STOP
44723 500 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
44724 WRITE(*,*) CHINL(1:80)
44725 510 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
44726 STOP
44727 520 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
44728 WRITE(*,*) CHINL(1:80)
44729 STOP
44730
44731 8300 FORMAT(I9)
44732 8500 FORMAT(F16.5)
44733
44734C...Formats for user information printout.
44735 5000 FORMAT(1x,15('*'),1x,'PYSLHA v1.09: SUSY/BSM SPECTRUM '
44736 & ,'INTERFACE',1x,15('*')/1x,'*',2x
44737 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
44738 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
44739 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
44740 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
44741 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
44742 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
44743 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
44744 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
44745 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
44746 & ,'----------------')
44747 5400 FORMAT(1x,'*',1x,A)
44748 5500 FORMAT(1x,'*',1x,A,':')
44749 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
44750 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
44751 5700 FORMAT(1x,'*',4x,4x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
44752 & 4x,'~c',2x,1x,1x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
44753 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
44754 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,2x,'~nu_e',2x,1x,3x,'~mu',2x
44755 & ,1x,1x,'~nu_mu',1x,1x,'~tau(12)',1x,1x,'~nu_tau'/1x,'*',2x
44756 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
44757 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
44758 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
44759 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
44760 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
44761 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
44762 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
44763 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
44764 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
44765 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
44766 & ,1x,F6.3,1x),'|')
44767 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
44768 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
44769 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
44770 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
44771 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
44772 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
44773 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
44774 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
44775 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
44776 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
44777 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
44778 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
44779 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
44780 & ,'A_tau = ',F8.2)
44781 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
44782 & ,' mu = ',F8.2)
44783 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
44784
44785C...Format to use for comments
44786 7000 FORMAT('# ',A)
44787C...Format to use for block statements
44788 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
44789 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
44790C...Indexed Int
44791 7110 FORMAT(1x,I4,1x,I4,3x,'#')
44792C...Non-Indexed Double
44793 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
44794C...Indexed Double
44795 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
44796C...Long Indexed Double (PDG + double)
44797 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
44798C...Indexed Char(12)
44799 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
44800C...Single matrix
44801 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
44802C...Double Matrix
44803 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
44804C...Write Decay Table
44805 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
44806 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
44807
44808 END
44809
44810
44811C*********************************************************************
44812
44813C...PYAPPS
44814C...Uses approximate analytical formulae to determine the full set of
44815C...MSSM parameters from SUGRA input.
44816C...See M. Drees and S.P. Martin, hep-ph/9504124
44817
44818 SUBROUTINE PYAPPS
44819
44820C...Double precision and integer declarations.
44821 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44822 IMPLICIT INTEGER(I-N)
44823 INTEGER PYK,PYCHGE,PYCOMP
44824C...Parameter statement to help give large particle numbers.
44825 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44826 &KEXCIT=4000000,KDIMEN=5000000)
44827C...Commonblocks.
44828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44829 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44830 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44831 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
44832
44833 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
44834 &' not intended for serious physics studies'
44835 IMSS(5)=0
44836 IMSS(8)=0
44837 XMT=PMAS(6,1)
44838 XMZ2=PMAS(23,1)**2
44839 XMW2=PMAS(24,1)**2
44840 TANB=RMSS(5)
44841 BETA=ATAN(TANB)
44842 XW=PARU(102)
44843 XMG=RMSS(1)
44844 XMG2=XMG*XMG
44845 XM0=RMSS(8)
44846 XM02=XM0*XM0
44847C...Temporary sign change for AT. Others unchanged.
44848 AT=-RMSS(16)
44849 RMSS(15)=RMSS(16)
44850 RMSS(17)=RMSS(16)
44851 SINB=TANB/SQRT(TANB**2+1D0)
44852 COSB=SINB/TANB
44853
44854 DTERM=XMZ2*COS(2D0*BETA)
44855 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
44856 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
44857 RMSS(6)=XMEL
44858 RMSS(7)=XMER
44859 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
44860 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
44861 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
44862 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
44863 DO 100 I=1,5,2
44864 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
44865 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
44866 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
44867 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
44868 100 CONTINUE
44869 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
44870 IF(XARG.LT.0D0) THEN
44871 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44872 & ' FROM THE SUM RULE. '
44873 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44874 RETURN
44875 ELSE
44876 XARG=SQRT(XARG)
44877 ENDIF
44878 DO 110 I=11,15,2
44879 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
44880 PMAS(PYCOMP(KSUSY2+I),1)=XMER
44881 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44882 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44883 110 CONTINUE
44884 RMT=PYMRUN(6,PMAS(6,1)**2)
44885 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
44886 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
44887 RMB=PYMRUN(5,PMAS(6,1)**2)
44888 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
44889 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
44890 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
44891 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
44892 &SINB)**2)
44893 RMSS(16)=-ATP
44894 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
44895 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
44896 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
44897 XMU=SIGN(SQRT(XMU2),RMSS(4))
44898 RMSS(4)=XMU
44899 IF(XMA2.GT.0D0) THEN
44900 RMSS(19)=SQRT(XMA2)
44901 ELSE
44902 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
44903 STOP
44904 ENDIF
44905 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
44906 IF(ARG.GT.0D0) THEN
44907 RMSS(14)=SQRT(ARG)
44908 ELSE
44909 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
44910 STOP
44911 ENDIF
44912 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
44913 IF(ARG.GT.0D0) THEN
44914 RMSS(13)=SQRT(ARG)
44915 ELSE
44916 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
44917 STOP
44918 ENDIF
44919 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
44920 IF(ARG.GT.0D0) THEN
44921 RMSS(10)=SQRT(ARG)
44922 ELSE
44923 RMSS(10)=-SQRT(-ARG)
44924 ENDIF
44925 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
44926 IF(ARG.GT.0D0) THEN
44927 RMSS(12)=SQRT(ARG)
44928 ELSE
44929 RMSS(12)=-SQRT(-ARG)
44930 ENDIF
44931 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
44932 IF(ARG.GT.0D0) THEN
44933 RMSS(11)=SQRT(ARG)
44934 ELSE
44935 RMSS(11)=-SQRT(-ARG)
44936 ENDIF
44937
44938 RETURN
44939 END
44940
44941C*********************************************************************
44942
44943C...PYSUGI
44944C...Interface to ISASUSY version 7.71.
44945C...Warning: this interface should not be used with earlier versions
44946C...of ISASUSY, since common block incompatibilities may then arise.
44947C...Calls SUGRA (in ISAJET) to perform RGE evolution.
44948C...Then converts to Gunion-Haber conventions.
44949
44950 SUBROUTINE PYSUGI
44951 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44952
44953 INTEGER PYK,PYCHGE,PYCOMP
44954 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44955 &KEXCIT=4000000,KDIMEN=5000000)
44956
44957C...Date of Change
44958 CHARACTER DOC*11
44959 PARAMETER (DOC='01 May 2006')
44960
44961C...ISASUGRA Input:
44962 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
44963C...XISAIN contains the MSSMi inputs in natural order.
44964 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
44965 $XAMIN(7)
44966 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
44967 SAVE /SUGXIN/
44968C...ISASUGRA Output
44969 CHARACTER*40 ISAVER,VISAJE
44970 REAL SUPER
44971 COMMON /SSPAR/ SUPER(72)
44972 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
44973 $FBGUT,FTAGUT,FNGUT
44974 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
44975 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
44976 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
44977 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
44978 $VUMT,VDMT,ASMTP,ASMSS,M3Q
44979 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
44980 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
44981 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
44982 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
44983 INTEGER IALLOW
44984 SAVE /SUGMG/,/SSPAR/
44985C SUPER: Filled by ISASUGRA.
44986C SUPER(1) = mass of ~g
44987C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
44988C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
44989C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
44990C ,~tau_2
44991C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
44992C SUPER(29) = Higgsino mass = - mu
44993C SUPER(30) = ratio v2/v1 of vev's
44994C SUPER(31:34) = Signed neutralino masses
44995C SUPER(35:50) = Neutralino mixing matrix
44996C SUPER(51:52) = Signed chargino masses
44997C SUPER(53:54) = Chargino left, right mixing angles
44998C SUPER(55:58) = mass of h0, H0, A0, H+
44999C SUPER(59) = Higgs mixing angle alpha
45000C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
45001C SUPER(66) = Gravitino mass
45002C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
45003C SUPER(70) = b-Yukawa at mA scale (not used)
45004C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
45005C GSS: Filled by ISASUGRA
45006C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
45007C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
45008C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
45009C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
45010C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
45011C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
45012C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
45013C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
45014C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
45015C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
45016C GSS(31) = log(vuq)
45017C MSS: Filled by ISASUGRA
45018C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
45019C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
45020C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
45021C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
45022C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
45023C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
45024C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
45025C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
45026C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
45027C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
45028C MSS(31) = ha0 MSS(32) = h+
45029C Unification, filled by ISASUGRA if applicable.
45030C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
45031
45032C...SPYTHIA Input/Output
45033 INTEGER IMSS
45034 DOUBLE PRECISION RMSS
45035 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45036 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45037 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45038C...SLHA Input/Output
45039 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45040 & AU(3,3),AD(3,3),AE(3,3)
45041C...PYTHIA common blocks
45042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45043 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45044 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45045
45046 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
45047CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
45048 INTEGER IMODEL
45049 REAL M0,MHF,A0,MT
45050 CHARACTER*20 CHMOD(5)
45051 CHARACTER*32 FNAME
45052
45053 COMMON /SUGNU/ XNUSUG(18)
45054 REAL XNUSUG
45055 SAVE /SUGNU/
45056
45057 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
45058 & 'truly unified SUGRA', 'non-minimal GMSB'/
45059
45060C...Start by checking for incompatibilities/inconsistencies:
45061 DO 100 ICHK=2,9
45062 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
45063 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
45064 & ,' option not used by PYSUGI'
45065 ENDIF
45066 100 CONTINUE
45067C...ISAJET works with REAL numbers.
45068 MZERO=REAL(RMSS(8))
45069 MHLF=REAL(RMSS(1))
45070 AZERO=REAL(RMSS(16))
45071 TANB=REAL(RMSS(5))
45072 SGNMU=REAL(RMSS(4))
45073 MTOP=REAL(PMAS(6,1))
45074 IMODEL=0
45075 IF (IMSS(1).EQ.12) THEN
45076 IMODEL=1
45077 GOTO 130
45078 ELSEIF(IMSS(1).EQ.13) THEN
45079C...Read from isajet par file in IMSS(20)
45080 LFN=IMSS(20)
45081C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45082 IF (LFN.EQ.0) THEN
45083 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
45084 GOTO 9999
45085 ENDIF
45086 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
45087CMrenna change to allow any susy model
45088 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
45089 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
45090 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
45091 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
45092 & ' gauge couplings:'
45093 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
45094 READ(LFN,*) IMODEL
45095 IF (IMODEL.EQ.4) THEN
45096 IAL3UN=1
45097 IMODEL=1
45098 ENDIF
45099 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
45100 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
45101 & //' sgn(mu), M_t:'
45102 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
45103 IF (IMODEL.EQ.3) THEN
45104 IMODEL=1
45105 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
45106 & //' 0 to continue:'
45107 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
45108 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
45109 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
45110 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
45111 & //' generation masses'
45112 WRITE(MSTU(11),*)
45113 & ' NUSUG5 = GUT scale 3rd generation masses'
45114 READ(LFN,*) INUSUG
45115 IF (INUSUG.EQ.0) THEN
45116 GOTO 120
45117 ELSEIF (INUSUG.EQ.1) THEN
45118 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
45119 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
45120 IF (XNUSUG(3).LE.0.) THEN
45121 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
45122 STOP 99
45123 END IF
45124 ELSEIF (INUSUG.EQ.2) THEN
45125 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
45126 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
45127 ELSEIF (INUSUG.EQ.3) THEN
45128 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
45129 READ(LFN,*) XNUSUG(7),XNUSUG(8)
45130 ELSEIF (INUSUG.EQ.4) THEN
45131 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
45132 & //' M(ur), M(el), M(er):'
45133 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
45134 & XNUSUG(10),XNUSUG(9)
45135 ELSEIF (INUSUG.EQ.5) THEN
45136 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
45137 & //' M(Ll), M(Lr):'
45138 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
45139 & XNUSUG(15),XNUSUG(14)
45140 ENDIF
45141 GOTO 110
45142 ENDIF
45143 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
45144 IMSS(11)=1
45145 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
45146 & ,' sgn(mu), M_t, C_gv:'
45147 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
45148 XGMIN(7)=XCMGV
45149 XGMIN(8)=1.
45150C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
45151 AMPL=2.4D18
45152 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
45153 IF (IMODEL.EQ.5) THEN
45154 IMODEL=2
45155 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
45156 & ,' masses at M_mes'
45157 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
45158 & ,' shifts at M_mes'
45159 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
45160 & ' Y at M_mes'
45161 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
45162 & ,'SU(2),SU(3)'
45163 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
45164 & ,' n5_2, n5_3'
45165 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
45166 $ XGMIN(13),XGMIN(14)
45167 ENDIF
45168 ELSE
45169 WRITE(MSTU(11),*) 'Invalid model choice.'
45170 GOTO 9999
45171 ENDIF
45172 ENDIF
45173
45174 120 MZERO=M0
45175 MHLF=MHF
45176 AZERO=A0
45177C TANB=REAL(RMSS(5))
45178C SGNMU=REAL(RMSS(4))
45179 MTOP=MT
45180
45181C...Initialize MSSM parameter array
45182 130 DO 140 IPAR=1,72
45183 SUPER(IPAR)=0.0
45184 140 CONTINUE
45185C...Call ISASUGRA
45186 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
45187C...Check whether ISASUSY thought the model was OK.
45188 IF (NOGOOD.NE.0) THEN
45189 IF (NOGOOD.EQ.1) CALL PYERRM(26
45190 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
45191 IF (NOGOOD.EQ.2) CALL PYERRM(26
45192 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
45193 IF (NOGOOD.EQ.3) CALL PYERRM(26
45194 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
45195 IF (NOGOOD.EQ.4) CALL PYERRM(26
45196 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
45197 IF (NOGOOD.EQ.7) CALL PYERRM(26
45198 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
45199 IF (NOGOOD.EQ.8) CALL PYERRM(26
45200 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
45201C...Give warning, but don't stop, if LSP not ~chi_10.
45202 IF (NOGOOD.EQ.5) CALL PYERRM(16
45203 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
45204 ENDIF
45205C...Warn about possible GUT scale tachyons.
45206 IF (ITACHY.NE.0) CALL PYERRM(16,
45207 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
45208C...Finalize spectrum (last iteration)
45209C...(Thanks to A. Raklev for pointing this out.)
45210C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
45211 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
45212 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
45213 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
45214 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
45215 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
45216 $ MTOP,IALLOW,1)
45217
45218C...M1, M2, M3.
45219 RMSS(1)=dble(GSS(7))
45220 RMSS(2)=dble(GSS(8))
45221 RMSS(3)=dble(GSS(9))
45222 RMSOFT(1)=dble(GSS(7))
45223 RMSOFT(2)=dble(GSS(8))
45224 RMSOFT(3)=dble(GSS(9))
45225C...Mu = - Higgsino mass.
45226 RMSS(4)=-SUPER(29)
45227 RMSS(5)=TANB
45228C...Slepton and squark masses. 2 first generations.
45229 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
45230 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
45231 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
45232 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
45233C...Third generation.
45234 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
45235 RMSS(11)=SUPER(11)
45236 RMSS(12)=SUPER(15)
45237 RMSS(13)=SUPER(22)
45238 RMSS(14)=SUPER(23)
45239C...SLHA: store exact soft spectrum in RMSOFT
45240 RMSOFT(31)=SUPER(18)
45241 RMSOFT(32)=SUPER(20)
45242 RMSOFT(33)=SUPER(22)
45243 RMSOFT(34)=SUPER(19)
45244 RMSOFT(35)=SUPER(21)
45245 RMSOFT(36)=SUPER(23)
45246 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
45247 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
45248 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
45249 RMSOFT(44)=SUPER(3)
45250 RMSOFT(45)=SUPER(9)
45251 RMSOFT(46)=SUPER(15)
45252 RMSOFT(47)=SUPER(5)
45253 RMSOFT(48)=SUPER(7)
45254 RMSOFT(49)=SUPER(11)
45255
45256C...~b, ~t, and ~tau trilinear couplings and mixing angles.
45257 RMSS(15)=SUPER(62)
45258 RMSS(16)=SUPER(60)
45259 RMSS(17)=SUPER(64)
45260 RMSS(26)=SUPER(63)
45261 RMSS(27)=SUPER(61)
45262 RMSS(28)=SUPER(65)
45263C...SLHA trilinears
45264 DO 142 K1=1,3
45265 DO 141 K2=1,3
45266 AE(K1,K2)=0D0
45267 AU(K1,K2)=0D0
45268 AD(K1,K2)=0D0
45269 141 CONTINUE
45270 142 CONTINUE
45271 AE(3,3)=SUPER(64)
45272 AU(3,3)=SUPER(60)
45273 AD(3,3)=SUPER(62)
45274C...Higgs mixing angle alpha (Gunion-Haber convention).
45275 RMSS(18)=-SUPER(59)
45276C...A0 mass.
45277 RMSS(19)=SUPER(57)
45278C...GUT scale coupling
45279 RMSS(20)=AGUTSS
45280C...Gravitino mass (for future compatibility)
45281 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
45282
45283C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
45284C...Higgs sector.
45285 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
45286 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
45287 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
45288 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
45289C...Gluino.
45290 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
45291C...Squarks and Sleptons.
45292 DO 150 ILR=1,2
45293 ILRM=ILR-1
45294 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
45295 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
45296 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
45297 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
45298 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
45299 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
45300 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
45301 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
45302 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
45303 150 CONTINUE
45304 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
45305 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
45306 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
45307C...Neutralinos.
45308 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
45309 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
45310 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
45311 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
45312C...Signed masses (extra minus from going to G-H convention).
45313 SMZ(1)=-SUPER(31)
45314 SMZ(2)=-SUPER(32)
45315 SMZ(3)=-SUPER(33)
45316 SMZ(4)=-SUPER(34)
45317C...Charginos
45318 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
45319 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
45320C...Signed masses (extra minus from going to G-H convention).
45321 SMW(1)=-SUPER(51)
45322 SMW(2)=-SUPER(52)
45323
45324C... Neutralino Mixing.
45325 DO 160 IN=1,4
45326 ZMIX(IN,1)= SUPER(38+4*(IN-1))
45327 ZMIX(IN,2)= SUPER(37+4*(IN-1))
45328 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
45329 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
45330 160 CONTINUE
45331C...Chargino Mixing (PYTHIA same angle as HERWIG).
45332 THX=1D0
45333 THY=1D0
45334 IF (SUPER(53).GT.0) THX=-1D0
45335 IF (SUPER(54).GT.0) THY=-1D0
45336 UMIX(1,1) = -SIN(SUPER(53))
45337 UMIX(1,2) = -COS(SUPER(53))
45338 UMIX(2,1) = -THX*COS(SUPER(53))
45339 UMIX(2,2) = THX*SIN(SUPER(53))
45340 VMIX(1,1) = -SIN(SUPER(54))
45341 VMIX(1,2) = -COS(SUPER(54))
45342 VMIX(2,1) = -THY*COS(SUPER(54))
45343 VMIX(2,2) = THY*SIN(SUPER(54))
45344C...Sfermion mixing (PYTHIA same angle as ISAJET)
45345 SFMIX(5,1)=COS(SUPER(63))
45346 SFMIX(5,2)=SIN(SUPER(63))
45347 SFMIX(5,3)=-SIN(SUPER(63))
45348 SFMIX(5,4)=COS(SUPER(63))
45349 SFMIX(6,1)=COS(SUPER(61))
45350 SFMIX(6,2)=SIN(SUPER(61))
45351 SFMIX(6,3)=-SIN(SUPER(61))
45352 SFMIX(6,4)=COS(SUPER(61))
45353 SFMIX(15,1)=COS(SUPER(65))
45354 SFMIX(15,2)=SIN(SUPER(65))
45355 SFMIX(15,3)=-SIN(SUPER(65))
45356 SFMIX(15,4)=COS(SUPER(65))
45357
45358 IF (MSTP(122).NE.0) THEN
45359C...Print a few lines to make the user know what's happening
45360 ISAVER=VISAJE()
45361 WRITE(MSTU(11),5000) DOC, ISAVER
45362 WRITE(MSTU(11),5100)
45363 IF (IMODEL.EQ.1) THEN
45364 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
45365 & MTOP
45366 WRITE(MSTU(11),5300)
45367 ENDIF
45368 WRITE(MSTU(11),5500) 'Pole masses'
45369 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
45370 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
45371 & ,(SUPER(IP),IP=19,25,2)
45372 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
45373 & ,IP=1,2)
45374 WRITE(MSTU(11),5400)
45375 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
45376 WRITE(MSTU(11),5400)
45377 WRITE(MSTU(11),5500) 'EW scale mixing structure'
45378 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45379 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45380 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45381 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45382 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45383 & ),(SFMIX(15,J),J=3,4)
45384 WRITE(MSTU(11),5400)
45385 WRITE(MSTU(11),6450) RMSS(18)
45386 WRITE(MSTU(11),5400)
45387 WRITE(MSTU(11),5500) 'Couplings'
45388 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
45389 WRITE(MSTU(11),5400)
45390 ENDIF
45391
45392C...Call FeynHiggs to improve Higgs sector if requested
45393 IF (IMSS(4).EQ.3) THEN
45394 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
45395 & ' (PYSUGI:) Now calling FeynHiggs.'
45396 CALL PYFEYN(IERR)
45397 IF (IERR.EQ.0) THEN
45398 IMSS(4)=2
45399 IF (MSTP(122).NE.0) THEN
45400 WRITE(MSTU(11),5400)
45401 WRITE(MSTU(11),5500)
45402 & 'Corrected Higgs masses and mixing'
45403 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
45404 & PMAS(37,1)
45405 WRITE(MSTU(11),6450) RMSS(18)
45406 WRITE(MSTU(11),5400)
45407 ENDIF
45408 ENDIF
45409 ENDIF
45410
45411 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
45412
45413C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
45414C...output by ISASUSY.
45415 IMSS(4)=MAX(2,IMSS(4))
45416
45417 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
45418 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
45419 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
45420 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
45421 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45422 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45423 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
45424 & ,'----------------')
45425 5400 FORMAT(1x,'*',1x,A)
45426 5500 FORMAT(1x,'*',1x,A,':')
45427 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45428 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45429 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
45430 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
45431 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
45432 & ,1x))
45433 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
45434 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
45435 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
45436 & .2,1x))
45437 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45438 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45439 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45440 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
45441 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
45442 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
45443 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
45444 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45445 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45446 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45447 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45448 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45449 & ,1x,F6.3,1x),'|')
45450 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45451 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45452 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45453 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45454 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45455 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45456 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45457 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45458 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45459 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45460 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45461 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45462 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
45463 & ,4x,'Alpha_GUT = ',F8.2)
45464 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
45465 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
45466
45467 9999 RETURN
45468 END
45469
45470C*********************************************************************
45471
45472C...PYFEYN
45473C...Interface to FeynHiggs for MSSM Higgs sector.
45474C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
45475C...P. Skands
45476
45477 SUBROUTINE PYFEYN(IERR)
45478
45479C...Double precision and integer declarations.
45480 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45481 IMPLICIT INTEGER(I-N)
45482 INTEGER PYK,PYCHGE,PYCOMP
45483C...Commonblocks.
45484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45486C...SUSY blocks
45487 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45488C...FeynHiggs variables
45489 DOUBLE PRECISION RMHIGG(4)
45490 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
45491 DOUBLE COMPLEX DMU,
45492 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
45493 & DM1, DM2, DM3
45494C...SLHA Common Block
45495 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45496 & AU(3,3),AD(3,3),AE(3,3)
45497 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
45498
45499 IERR=0
45500 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
45501 IF (IERR.NE.0) THEN
45502 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
45503 & //'Will not use FeynHiggs for this run.')
45504 RETURN
45505 ENDIF
45506 Q=RMSOFT(0)
45507 DMB=PMAS(5,1)
45508 DMT=PMAS(6,1)
45509 DMZ=PMAS(23,1)
45510 DMW=PMAS(24,1)
45511 DMA=PMAS(36,1)
45512 DM1=RMSOFT(1)
45513 DM2=RMSOFT(2)
45514 DM3=RMSOFT(3)
45515 DTANB=RMSS(5)
45516 DMU=RMSS(4)
45517 DM3SL=RMSOFT(33)
45518 DM3SE=RMSOFT(36)
45519 DM3SQ=RMSOFT(43)
45520 DM3SU=RMSOFT(46)
45521 DM3SD=RMSOFT(49)
45522 DM2SL=RMSOFT(32)
45523 DM2SE=RMSOFT(35)
45524 DM2SQ=RMSOFT(42)
45525 DM2SU=RMSOFT(45)
45526 DM2SD=RMSOFT(48)
45527 DM1SL=RMSOFT(31)
45528 DM1SE=RMSOFT(34)
45529 DM1SQ=RMSOFT(41)
45530 DM1SU=RMSOFT(44)
45531 DM1SD=RMSOFT(47)
45532 AE33=AE(3,3)
45533 AE22=AE(2,2)
45534 AE11=AE(1,1)
45535 AU33=AU(3,3)
45536 AU22=AU(2,2)
45537 AU11=AU(1,1)
45538 AD33=AD(3,3)
45539 AD22=AD(2,2)
45540 AD11=AD(1,1)
45541 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
45542 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
45543 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
45544 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
45545 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
45546 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
45547 IF (IERR.NE.0) THEN
45548 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
45549 & //' Will not use FeynHiggs for this run.')
45550 RETURN
45551 ENDIF
45552C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
45553 SAEFF=0D0
45554 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
45555 IF (IERR.NE.0) THEN
45556 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
45557 & 'GSCORR. Will not use FeynHiggs for this run.')
45558 RETURN
45559 ENDIF
45560 ALPHA = ASIN(DBLE(SAEFF))
45561 R=RMSS(18)/ALPHA
45562 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
45563 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
45564 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
45565 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
45566 ENDIF
45567 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
45568 & 1.15D0*PMAS(25,1)) THEN
45569 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
45570 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
45571 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
45572 ENDIF
45573 RMSS(18)=ALPHA
45574 PMAS(25,1)=RMHIGG(1)
45575 PMAS(35,1)=RMHIGG(2)
45576 PMAS(36,1)=RMHIGG(3)
45577 PMAS(37,1)=RMHIGG(4)
45578
45579 RETURN
45580 END
45581
45582C*********************************************************************
45583
45584C...PYRNMQ
45585C...Determines the running mass of Squarks.
45586
45587 FUNCTION PYRNMQ(ID,DTERM)
45588
45589C...Double precision and integer declarations.
45590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45591 IMPLICIT INTEGER(I-N)
45592 INTEGER PYK,PYCHGE,PYCOMP
45593C...Commonblock.
45594 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45595 SAVE /PYMSSM/
45596
45597C...Local variables.
45598 DOUBLE PRECISION PI,R
45599 DOUBLE PRECISION TOL
45600 DOUBLE PRECISION CI(3)
45601 EXTERNAL PYALPS
45602 DOUBLE PRECISION PYALPS
45603 DATA TOL/0.001D0/
45604 DATA PI,R/3.141592654D0,.61803399D0/
45605 DATA CI/0.47D0,0.07D0,0.02D0/
45606
45607 C=1D0-R
45608 CA=CI(ID)
45609 AG=(0.71D0)**2/4D0/PI
45610 AG=RMSS(20)
45611 XM0=RMSS(8)
45612 XMG=RMSS(1)
45613 XM02=XM0*XM0
45614 XMG2=XMG*XMG
45615
45616 AS=PYALPS(XM02+6D0*XMG2)
45617 CG=8D0/9D0*((AS/AG)**2-1D0)
45618 BX=XM02+(CA+CG)*XMG2+DTERM
45619 AX=MIN(50D0**2,0.5D0*BX)
45620 CX=MAX(2000D0**2,2D0*BX)
45621
45622 X0=AX
45623 X3=CX
45624 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
45625 X1=BX
45626 X2=BX+C*(CX-BX)
45627 ELSE
45628 X2=BX
45629 X1=BX-C*(BX-AX)
45630 ENDIF
45631 AS1=PYALPS(X1)
45632 CG=8D0/9D0*((AS1/AG)**2-1D0)
45633 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
45634 AS2=PYALPS(X2)
45635 CG=8D0/9D0*((AS2/AG)**2-1D0)
45636 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
45637 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
45638 IF(F2.LT.F1) THEN
45639 X0=X1
45640 X1=X2
45641 X2=R*X1+C*X3
45642 F1=F2
45643 AS2=PYALPS(X2)
45644 CG=8D0/9D0*((AS2/AG)**2-1D0)
45645 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
45646 ELSE
45647 X3=X2
45648 X2=X1
45649 X1=R*X2+C*X0
45650 F2=F1
45651 AS1=PYALPS(X1)
45652 CG=8D0/9D0*((AS1/AG)**2-1D0)
45653 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
45654 ENDIF
45655 GOTO 100
45656 ENDIF
45657 IF(F1.LT.F2) THEN
45658 PYRNMQ=X1
45659 XMIN=X1
45660 ELSE
45661 PYRNMQ=X2
45662 XMIN=X2
45663 ENDIF
45664
45665 RETURN
45666 END
45667
45668C*********************************************************************
45669
45670C...PYTHRG
45671C...Calculates the mass eigenstates of the third generation sfermions.
45672C...Created: 5-31-96
45673
45674 SUBROUTINE PYTHRG
45675
45676C...Double precision and integer declarations.
45677 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45678 IMPLICIT INTEGER(I-N)
45679 INTEGER PYK,PYCHGE,PYCOMP
45680C...Parameter statement to help give large particle numbers.
45681 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45682 &KEXCIT=4000000,KDIMEN=5000000)
45683C...Commonblocks.
45684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45685 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45686 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45687 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45688 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45689 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
45690
45691C...Local variables.
45692 DOUBLE PRECISION BETA
45693 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
45694 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
45695 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
45696 DOUBLE PRECISION ATR,AMQR,AMQL
45697 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
45698 INTEGER IF,I,J,II,JJ,IT,L
45699 LOGICAL DTERM
45700 DATA SMALL/1D-3/
45701 DATA ID1/10,10,13/
45702 DATA ID2/5,6,15/
45703 DATA ID3/15,16,17/
45704 DATA ID4/11,12,14/
45705 DATA DTERM/.TRUE./
45706
45707 XMZ2=PMAS(23,1)**2
45708 XMW2=PMAS(24,1)**2
45709 TANB=RMSS(5)
45710 XMU=-RMSS(4)
45711 BETA=ATAN(TANB)
45712 COS2B=COS(2D0*BETA)
45713
45714C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
45715
45716 IOPT=IMSS(5)
45717 IF(IOPT.EQ.1) THEN
45718 CTT=DCOS(RMSS(27))
45719 CTT2=CTT**2
45720 STT=DSIN(RMSS(27))
45721 STT2=STT**2
45722 XM12=RMSS(10)**2
45723 XM22=RMSS(12)**2
45724 XMQL2=CTT2*XM12+STT2*XM22
45725 XMQR2=STT2*XM12+CTT2*XM22
45726 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
45727 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
45728 RMSS(16)=ATOP
45729C......SUBTRACT OUT D-TERM AND FERMION MASS
45730 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
45731 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
45732 IF(XMQL2.GE.0D0) THEN
45733 RMSS(10)=SQRT(XMQL2)
45734 ELSE
45735 RMSS(10)=-SQRT(-XMQL2)
45736 ENDIF
45737 IF(XMQR2.GE.0D0) THEN
45738 RMSS(12)=SQRT(XMQR2)
45739 ELSE
45740 RMSS(12)=-SQRT(-XMQR2)
45741 ENDIF
45742
45743C SAME FOR BOTTOM SQUARK
45744 CTT=DCOS(RMSS(26))
45745 CTT2=CTT**2
45746 STT=DSIN(RMSS(26))
45747 STT2=STT**2
45748 XM22=RMSS(11)**2
45749 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
45750 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
45751 IF(ABS(CTT).GE..9999D0) THEN
45752 ABOT=-XMU*TANB
45753 XMQR2=RMSS(11)**2
45754 ELSEIF(ABS(CTT).LE.1D-4) THEN
45755 ABOT=-XMU*TANB
45756 XMQR2=RMSS(11)**2
45757 ELSE
45758 XM12=(XMQL2-STT2*XM22)/CTT2
45759 XMQR2=STT2*XM12+CTT2*XM22
45760 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
45761 ENDIF
45762 RMSS(15)=ABOT
45763C......SUBTRACT OUT D-TERM AND FERMION MASS
45764 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
45765 IF(XMQR2.GE.0D0) THEN
45766 RMSS(11)=SQRT(XMQR2)
45767 ELSE
45768 RMSS(11)=-SQRT(-XMQR2)
45769 ENDIF
45770C SAME FOR TAU SLEPTON
45771 CTT=DCOS(RMSS(28))
45772 CTT2=CTT**2
45773 STT=DSIN(RMSS(28))
45774 STT2=STT**2
45775 XM12=RMSS(13)**2
45776 XM22=RMSS(14)**2
45777 XMQL2=CTT2*XM12+STT2*XM22
45778 XMQR2=STT2*XM12+CTT2*XM22
45779 XMFR=PMAS(15,1)
45780 XMF2=XMFR**2
45781 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
45782 RMSS(17)=ATAU
45783C......SUBTRACT OUT D-TERM AND FERMION MASS
45784 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
45785 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
45786 IF(XMQL2.GE.0D0) THEN
45787 RMSS(13)=SQRT(XMQL2)
45788 ELSE
45789 RMSS(13)=-SQRT(-XMQL2)
45790 ENDIF
45791 IF(XMQR2.GE.0D0) THEN
45792 RMSS(14)=SQRT(XMQR2)
45793 ELSE
45794 RMSS(14)=-SQRT(-XMQR2)
45795 ENDIF
45796 ENDIF
45797 DO 170 L=1,3
45798 AMQL=RMSS(ID1(L))
45799 IF(AMQL.LT.0D0) THEN
45800 XMQL2=-AMQL**2
45801 ELSE
45802 XMQL2=AMQL**2
45803 ENDIF
45804 ATR=RMSS(ID3(L))
45805 AMQR=RMSS(ID4(L))
45806 IF(AMQR.LT.0D0) THEN
45807 XMQR2=-AMQR**2
45808 ELSE
45809 XMQR2=AMQR**2
45810 ENDIF
45811 IF=ID2(L)
45812 XMF=PYMRUN(IF,PMAS(6,1)**2)
45813 XMF2=XMF**2
45814 AM2(1,1)=XMQL2+XMF2
45815 AM2(2,2)=XMQR2+XMF2
45816 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
45817 IF(DTERM) THEN
45818 IF(L.EQ.1) THEN
45819 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
45820 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
45821 AM2(1,2)=XMF*(ATR+XMU*TANB)
45822 ELSEIF(L.EQ.2) THEN
45823 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
45824 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
45825 AM2(1,2)=XMF*(ATR+XMU/TANB)
45826 ELSEIF(L.EQ.3) THEN
45827 IF(IMSS(8).EQ.1) THEN
45828 AM2(1,1)=RMSS(6)**2
45829 AM2(2,2)=RMSS(7)**2
45830 AM2(1,2)=0D0
45831 RMSS(13)=RMSS(6)
45832 RMSS(14)=RMSS(7)
45833 ELSE
45834 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
45835 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
45836 AM2(1,2)=XMF*(ATR+XMU*TANB)
45837 ENDIF
45838 ENDIF
45839 ENDIF
45840 AM2(2,1)=AM2(1,2)
45841 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
45842 IF(DETM.LT.0D0) THEN
45843 WRITE(MSTU(11),*) ID2(L),DETM,AM2
45844 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
45845 ENDIF
45846 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
45847 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
45848 XMF12=SAME-DIFF
45849 XMF22=SAME+DIFF
45850 IT=0
45851 IF(XMF22-XMF12.GT.0D0) THEN
45852 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
45853 RT(2,2) = RT(1,1)
45854 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
45855 & AM2(1,2)/(XMF22-XMF12))
45856 RT(2,1) = -RT(1,2)
45857 ELSE
45858 RT(1,1) = 1D0
45859 RT(2,2) = RT(1,1)
45860 RT(1,2) = 0D0
45861 RT(2,1) = -RT(1,2)
45862 ENDIF
45863 100 CONTINUE
45864 IT=IT+1
45865
45866 DO 140 I=1,2
45867 DO 130 JJ=1,2
45868 DI(I,JJ)=0D0
45869 DO 120 II=1,2
45870 DO 110 J=1,2
45871 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
45872 110 CONTINUE
45873 120 CONTINUE
45874 130 CONTINUE
45875 140 CONTINUE
45876
45877 IF(DI(1,1).GT.DI(2,2)) THEN
45878 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
45879 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
45880 WRITE(MSTU(11),*) AM2
45881 WRITE(MSTU(11),*) DI
45882 WRITE(MSTU(11),*) RT
45883 DI(1,1)=-RT(2,1)
45884 DI(2,2)=RT(1,2)
45885 DI(1,2)=-RT(2,2)
45886 DI(2,1)=RT(1,1)
45887 DO 160 I=1,2
45888 DO 150 J=1,2
45889 RT(I,J)=DI(I,J)
45890 150 CONTINUE
45891 160 CONTINUE
45892 GOTO 100
45893 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
45894 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
45895 & ' OFF DIAGONAL ELEMENTS '
45896 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
45897 WRITE(MSTU(11),*) DI
45898 WRITE(MSTU(11),*) ' ROTATION = ',RT
45899C...STOP
45900 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
45901 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
45902 & ' NEGATIVE MASSES '
45903 STOP
45904 ENDIF
45905 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
45906 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
45907 SFMIX(IF,1)=RT(1,1)
45908 SFMIX(IF,2)=RT(1,2)
45909 SFMIX(IF,3)=RT(2,1)
45910 SFMIX(IF,4)=RT(2,2)
45911 170 CONTINUE
45912
45913C.....TAU SNEUTRINO MASS...L=3
45914
45915 XARG=AM2(1,1)+XMW2*COS2B
45916 IF(XARG.LT.0D0) THEN
45917 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
45918 & ' FROM THE SUM RULE. '
45919 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45920 RETURN
45921 ELSE
45922 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
45923 ENDIF
45924
45925 RETURN
45926 END
45927
45928C*********************************************************************
45929
45930C...PYINOM
45931C...Finds the mass eigenstates and mixing matrices for neutralinos
45932C...and charginos.
45933
45934 SUBROUTINE PYINOM
45935
45936C...Double precision and integer declarations.
45937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45938 IMPLICIT INTEGER(I-N)
45939 INTEGER PYCOMP
45940C...Parameter statement to help give large particle numbers.
45941 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45942 &KEXCIT=4000000,KDIMEN=5000000)
45943C...Commonblocks.
45944 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45945 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45946 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45947 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45948 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45949 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
45950
45951C...Local variables.
45952 DOUBLE PRECISION XMW,XMZ,XM(4)
45953 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
45954 DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
45955 DOUBLE PRECISION COSW,SINW
45956 DOUBLE PRECISION XMU
45957 DOUBLE PRECISION TANB,COSB,SINB
45958 DOUBLE PRECISION XM1,XM2,XM3,BETA
45959 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
45960 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
45961 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
45962 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
45963 DOUBLE PRECISION PYALPS,PYALEM
45964 DOUBLE PRECISION PYRNM3
45965 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
45966 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
45967 DATA KFNCHI/1000022,1000023,1000025,1000035/
45968
45969 IOPT=IMSS(2)
45970 IF(IMSS(1).EQ.2) THEN
45971 IOPT=1
45972 ENDIF
45973C...M1, M2, AND M3 ARE INDEPENDENT
45974 IF(IOPT.EQ.0) THEN
45975 XM1=RMSS(1)
45976 XM2=RMSS(2)
45977 XM3=RMSS(3)
45978 ELSEIF(IOPT.GE.1) THEN
45979 Q2=PMAS(23,1)**2
45980 AEM=PYALEM(Q2)
45981 A2=AEM/PARU(102)
45982 A1=AEM/(1D0-PARU(102))
45983 XM1=RMSS(1)
45984 XM2=RMSS(2)
45985 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
45986 IF(IOPT.EQ.1) THEN
45987 XM2=XM1*A2/A1*3D0/5D0
45988 RMSS(2)=XM2
45989 ELSEIF(IOPT.EQ.3) THEN
45990 XM1=XM2*5D0/3D0*A1/A2
45991 RMSS(1)=XM1
45992 ENDIF
45993 XM3=PYRNM3(XM2/A2)
45994 RMSS(3)=XM3
45995 IF(XM3.LE.0D0) THEN
45996 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
45997 STOP
45998 ENDIF
45999 ENDIF
46000
46001C...GLUINO MASS
46002 IF(IMSS(3).EQ.1) THEN
46003 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
46004 ELSE
46005 AQ=0D0
46006 DO 110 I=1,4
46007 DO 100 ILR=1,2
46008 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
46009 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
46010 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
46011 100 CONTINUE
46012 110 CONTINUE
46013
46014 DO 130 I=5,6
46015 DO 120 ILR=1,2
46016 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
46017 RM2=PMAS(I,1)**2/XM3**2
46018 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
46019 IF(ARG.GE.0D0) THEN
46020 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
46021 AX0=ABS(X0)
46022 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
46023 AX1=ABS(X1)
46024 IF(X0.EQ.1D0) THEN
46025 AT=-1D0
46026 BT=0.25D0
46027 ELSEIF(X0.EQ.0D0) THEN
46028 AT=0D0
46029 BT=-0.25D0
46030 ELSE
46031 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
46032 & 0.5D0*X0**2*LOG(AX0)
46033 BT=(-1D0-2D0*X0)/4D0
46034 ENDIF
46035 IF(X1.EQ.1D0) THEN
46036 AT=-1D0+AT
46037 BT=0.25D0+BT
46038 ELSEIF(X1.EQ.0D0) THEN
46039 AT=0D0+AT
46040 BT=-0.25D0+BT
46041 ELSE
46042 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
46043 & X1**2*LOG(AX1)+AT
46044 BT=(-1D0-2D0*X1)/4D0+BT
46045 ENDIF
46046 AQ=AQ+AT+BT
46047 ELSE
46048 X0=0.5D0*(1D0+RM2-RM1)
46049 Y0=-0.5D0*SQRT(-ARG)
46050 AMGX0=SQRT(X0**2+Y0**2)
46051 AM1X0=SQRT((1D0-X0)**2+Y0**2)
46052 ARGX0=ATAN2(-X0,-Y0)
46053 AR1X0=ATAN2(1D0-X0,Y0)
46054 X1=X0
46055 Y1=-Y0
46056 AMGX1=AMGX0
46057 AM1X1=AM1X0
46058 ARGX1=ATAN2(-X1,-Y1)
46059 AR1X1=ATAN2(1D0-X1,Y1)
46060 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
46061 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
46062 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
46063 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
46064 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
46065 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
46066 AQ=AQ+AT+BT
46067 ENDIF
46068 120 CONTINUE
46069 130 CONTINUE
46070 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
46071 & /(2D0*PARU(2))*(15D0+AQ))
46072 ENDIF
46073
46074C...NEUTRALINO MASSES
46075 DO 150 I=1,4
46076 DO 140 J=1,4
46077 AI(I,J)=0D0
46078 140 CONTINUE
46079 150 CONTINUE
46080 XMZ=PMAS(23,1)
46081 XMW=PMAS(24,1)
46082 XMU=RMSS(4)
46083 SINW=SQRT(PARU(102))
46084 COSW=SQRT(1D0-PARU(102))
46085 TANB=RMSS(5)
46086 BETA=ATAN(TANB)
46087 COSB=COS(BETA)
46088 SINB=TANB*COSB
46089
46090C... Definitions:
46091C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
46092C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
46093 AR(1,1) = XM1*COS(RMSS(30))
46094 AI(1,1) = XM1*SIN(RMSS(30))
46095 AR(2,2) = XM2*COS(RMSS(31))
46096 AI(2,2) = XM2*SIN(RMSS(31))
46097 AR(3,3) = 0D0
46098 AR(4,4) = 0D0
46099 AR(1,2) = 0D0
46100 AR(2,1) = 0D0
46101 AR(1,3) = -XMZ*SINW*COSB
46102 AR(3,1) = AR(1,3)
46103 AR(1,4) = XMZ*SINW*SINB
46104 AR(4,1) = AR(1,4)
46105 AR(2,3) = XMZ*COSW*COSB
46106 AR(3,2) = AR(2,3)
46107 AR(2,4) = -XMZ*COSW*SINB
46108 AR(4,2) = AR(2,4)
46109 AR(3,4) = -XMU*COS(RMSS(33))
46110 AI(3,4) = -XMU*SIN(RMSS(33))
46111 AR(4,3) = -XMU*COS(RMSS(33))
46112 AI(4,3) = -XMU*SIN(RMSS(33))
46113C CALL PYEIG4(AR,WR,ZR)
46114 CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
46115 IF(IERR.NE.0) THEN
46116 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
46117 ENDIF
46118 DO 160 I=1,4
46119 INDEX(I)=I
46120 XM(I)=ABS(WR(I))
46121 160 CONTINUE
46122 DO 180 I=2,4
46123 K=I
46124 DO 170 J=I-1,1,-1
46125 IF(XM(K).LT.XM(J)) THEN
46126 ITMP=INDEX(J)
46127 XTMP=XM(J)
46128 INDEX(J)=INDEX(K)
46129 XM(J)=XM(K)
46130 INDEX(K)=ITMP
46131 XM(K)=XTMP
46132 K=K-1
46133 ELSE
46134 GOTO 180
46135 ENDIF
46136 170 CONTINUE
46137 180 CONTINUE
46138
46139
46140 DO 210 I=1,4
46141 K=INDEX(I)
46142 SMZ(I)=WR(K)
46143 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
46144 S=0D0
46145 DO 190 J=1,4
46146 S=S+ZR(J,K)**2+ZI(J,K)**2
46147 190 CONTINUE
46148 DO 200 J=1,4
46149 ZMIX(I,J)=ZR(J,K)/SQRT(S)
46150 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
46151 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
46152 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
46153 200 CONTINUE
46154 210 CONTINUE
46155
46156C...CHARGINO MASSES
46157C.....Find eigenvectors of X X^*
46158 AI(1,1) = 0D0
46159 AI(2,2) = 0D0
46160 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
46161 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
46162 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
46163 &XMU*COS(RMSS(33))*SINB)
46164 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
46165 &XMU*SIN(RMSS(33))*SINB)
46166 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
46167 &XMU*COS(RMSS(33))*SINB)
46168 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
46169 &XMU*SIN(RMSS(33))*SINB)
46170 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
46171 IF(IERR.NE.0) THEN
46172 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
46173 ENDIF
46174 INDEX(1)=1
46175 INDEX(2)=2
46176 IF(WR(2).LT.WR(1)) THEN
46177 INDEX(1)=2
46178 INDEX(2)=1
46179 ENDIF
46180
46181 DO 240 I=1,2
46182 K=INDEX(I)
46183 SMW(I)=SQRT(WR(K))
46184 S=0D0
46185 DO 220 J=1,2
46186 S=S+ZR(J,K)**2+ZI(J,K)**2
46187 220 CONTINUE
46188 DO 230 J=1,2
46189 UMIX(I,J)=ZR(J,K)/SQRT(S)
46190 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
46191 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
46192 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
46193 230 CONTINUE
46194 240 CONTINUE
46195C...Force chargino mass > neutralino mass
46196 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
46197 CALL PYERRM(18,'(PYINOM:) '//
46198 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
46199 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
46200 ENDIF
46201 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
46202 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
46203
46204C.....Find eigenvectors of X^* X
46205 AI(1,1) = 0D0
46206 AI(2,2) = 0D0
46207 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
46208 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
46209 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
46210 &XMU*COS(RMSS(33))*COSB)
46211 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
46212 &XMU*SIN(RMSS(33))*COSB)
46213 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
46214 &XMU*COS(RMSS(33))*COSB)
46215 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
46216 &XMU*SIN(RMSS(33))*COSB)
46217 CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
46218 IF(IERR.NE.0) THEN
46219 WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
46220 ENDIF
46221 INDEX(1)=1
46222 INDEX(2)=2
46223 IF(WR(2).LT.WR(1)) THEN
46224 INDEX(1)=2
46225 INDEX(2)=1
46226 ENDIF
46227
46228 DO 270 I=1,2
46229 K=INDEX(I)
46230 S=0D0
46231 DO 250 J=1,2
46232 S=S+ZR(J,K)**2+ZI(J,K)**2
46233 250 CONTINUE
46234 DO 260 J=1,2
46235 VMIX(I,J)=ZR(J,K)/SQRT(S)
46236 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
46237 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
46238 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
46239 260 CONTINUE
46240 270 CONTINUE
46241
46242
46243 RETURN
46244 END
46245
46246C*********************************************************************
46247
46248C...PYRNM3
46249C...Calculates the running of M3, the SU(3) gluino mass parameter.
46250
46251 FUNCTION PYRNM3(RGUT)
46252
46253C...Double precision and integer declarations.
46254 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46255 IMPLICIT INTEGER(I-N)
46256 INTEGER PYK,PYCHGE,PYCOMP
46257
46258C...Local variables.
46259 DOUBLE PRECISION R
46260 DOUBLE PRECISION TOL
46261 EXTERNAL PYALPS
46262 DOUBLE PRECISION PYALPS
46263 DATA TOL/0.001D0/
46264 DATA R/0.61803399D0/
46265
46266 C=1D0-R
46267
46268 BX=RGUT*PYALPS(RGUT**2)
46269 AX=MIN(50D0,BX*0.5D0)
46270 CX=MAX(2000D0,2D0*BX)
46271
46272 X0=AX
46273 X3=CX
46274 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46275 X1=BX
46276 X2=BX+C*(CX-BX)
46277 ELSE
46278 X2=BX
46279 X1=BX-C*(BX-AX)
46280 ENDIF
46281 AS1=PYALPS(X1**2)
46282 F1=ABS(X1-RGUT*AS1)
46283 AS2=PYALPS(X2**2)
46284 F2=ABS(X2-RGUT*AS2)
46285 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46286 IF(F2.LT.F1) THEN
46287 X0=X1
46288 X1=X2
46289 X2=R*X1+C*X3
46290 F1=F2
46291 AS2=PYALPS(X2**2)
46292 F2=ABS(X2-RGUT*AS2)
46293 ELSE
46294 X3=X2
46295 X2=X1
46296 X1=R*X2+C*X0
46297 F2=F1
46298 AS1=PYALPS(X1**2)
46299 F1=ABS(X1-RGUT*AS1)
46300 ENDIF
46301 GOTO 100
46302 ENDIF
46303 IF(F1.LT.F2) THEN
46304 PYRNM3=X1
46305 XMIN=X1
46306 ELSE
46307 PYRNM3=X2
46308 XMIN=X2
46309 ENDIF
46310
46311 RETURN
46312 END
46313
46314C*********************************************************************
46315
46316C...PYEIG4
46317C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
46318C...Specific application: mixing in neutralino sector.
46319
46320 SUBROUTINE PYEIG4(A,W,Z)
46321
46322C...Double precision and integer declarations.
46323 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46324 IMPLICIT INTEGER(I-N)
46325 INTEGER PYK,PYCHGE,PYCOMP
46326
46327C...Arrays: in call and local.
46328 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
46329
46330C...Coefficients of fourth-degree equation from matrix.
46331C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
46332 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
46333 B2=0D0
46334 DO 110 I=1,3
46335 DO 100 J=I+1,4
46336 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
46337 100 CONTINUE
46338 110 CONTINUE
46339 B1=0D0
46340 B0=0D0
46341 DO 120 I=1,4
46342 I1=MOD(I,4)+1
46343 I2=MOD(I+1,4)+1
46344 I3=MOD(I+2,4)+1
46345 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
46346 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
46347 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
46348 B0=B0+(-1D0)**(I+1)*A(1,I)*(
46349 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
46350 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
46351 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
46352 120 CONTINUE
46353
46354C...Coefficients of third-degree equation needed for
46355C...separation into two second-degree equations.
46356C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
46357 C2=-B2
46358 C1=B1*B3-4D0*B0
46359 C0=-B1**2-B0*B3**2+4D0*B0*B2
46360 CQ=C1/3D0-C2**2/9D0
46361 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
46362 CQR=CQ**3+CR**2
46363
46364C...Cases with one or three real roots.
46365 IF(CQR.GE.0D0) THEN
46366 S1=(CR+SQRT(CQR))**(1D0/3D0)
46367 S2=(CR-SQRT(CQR))**(1D0/3D0)
46368 U=S1+S2-C2/3D0
46369 ELSE
46370 SABS=SQRT(-CQ)
46371 THE=ACOS(CR/SABS**3)/3D0
46372 SRE=SABS*COS(THE)
46373 U=2D0*SRE-C2/3D0
46374 ENDIF
46375
46376C...Find and solve two second-degree equations.
46377 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
46378 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
46379 Q1=U/2D0+SQRT(U**2/4D0-B0)
46380 Q2=U/2D0-SQRT(U**2/4D0-B0)
46381 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
46382 QSAV=Q1
46383 Q1=Q2
46384 Q2=QSAV
46385 ENDIF
46386 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
46387 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
46388 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
46389 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
46390
46391C...Order eigenvalues in asceding mass.
46392 W(1)=X(1)
46393 DO 150 I1=2,4
46394 DO 130 I2=I1-1,1,-1
46395 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
46396 W(I2+1)=W(I2)
46397 130 CONTINUE
46398 140 W(I2+1)=X(I1)
46399 150 CONTINUE
46400
46401C...Find equation system for eigenvectors.
46402 DO 250 I=1,4
46403 DO 170 J1=1,4
46404 D(J1,J1)=A(J1,J1)-W(I)
46405 DO 160 J2=J1+1,4
46406 D(J1,J2)=A(J1,J2)
46407 D(J2,J1)=A(J2,J1)
46408 160 CONTINUE
46409 170 CONTINUE
46410
46411C...Find largest element in matrix.
46412 DAMAX=0D0
46413 DO 190 J1=1,4
46414 DO 180 J2=1,4
46415 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
46416 JA=J1
46417 JB=J2
46418 DAMAX=ABS(D(J1,J2))
46419 180 CONTINUE
46420 190 CONTINUE
46421
46422C...Subtract others by multiple of row selected above.
46423 DAMAX=0D0
46424 DO 210 J3=JA+1,JA+3
46425 J1=J3-4*((J3-1)/4)
46426 RL=D(J1,JB)/D(JA,JB)
46427 DO 200 J2=1,4
46428 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
46429 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
46430 JC=J1
46431 JD=J2
46432 DAMAX=ABS(D(J1,J2))
46433 200 CONTINUE
46434 210 CONTINUE
46435
46436C...Do one more subtraction of a row.
46437 DAMAX=0D0
46438 DO 230 J3=JC+1,JC+3
46439 J1=J3-4*((J3-1)/4)
46440 IF(J1.EQ.JA) GOTO 230
46441 RL=D(J1,JD)/D(JC,JD)
46442 DO 220 J2=1,4
46443 IF(J2.EQ.JB) GOTO 220
46444 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
46445 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
46446 JE=J1
46447 DAMAX=ABS(D(J1,J2))
46448 220 CONTINUE
46449 230 CONTINUE
46450
46451C...Construct unnormalized eigenvector.
46452 JF1=JD+1-4*(JD/4)
46453 JF2=JD+2-4*((JD+1)/4)
46454 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
46455 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
46456 E(JF1)=-D(JE,JF2)
46457 E(JF2)=D(JE,JF1)
46458 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
46459 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
46460 & D(JA,JB)
46461
46462C...Normalize and fill in final array.
46463 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
46464 SGN=(-1D0)**INT(PYR(0)+0.5D0)
46465 DO 240 J=1,4
46466 Z(I,J)=SGN*E(J)/EA
46467 240 CONTINUE
46468 250 CONTINUE
46469
46470 RETURN
46471 END
46472
46473C*********************************************************************
46474
46475C...PYHGGM
46476C...Determines the Higgs boson mass spectrum using several inputs.
46477
46478 SUBROUTINE PYHGGM(ALPHA)
46479
46480C...Double precision and integer declarations.
46481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46482 IMPLICIT INTEGER(I-N)
46483 INTEGER PYK,PYCHGE,PYCOMP
46484C...Parameter statement to help give large particle numbers.
46485 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46486 &KEXCIT=4000000,KDIMEN=5000000)
46487C...Commonblocks.
46488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46490 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46491 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46492 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
46493
46494C...Local variables.
46495 DOUBLE PRECISION AT,AB,XMU,TANB
46496 DOUBLE PRECISION ALPHA
46497 INTEGER IHOPT
46498 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
46499 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
46500 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
46501 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
46502
46503 IHOPT=IMSS(4)
46504 IF(IHOPT.EQ.2) THEN
46505 ALPHA=RMSS(18)
46506 RETURN
46507 ENDIF
46508 AT=RMSS(16)
46509 AB=RMSS(15)
46510 DMGL=RMSS(3)
46511 XMU=RMSS(4)
46512 TANB=RMSS(5)
46513
46514 DMA=RMSS(19)
46515 DTANB=TANB
46516 DMQ=RMSS(10)
46517 DMUR=RMSS(12)
46518 DMDR=RMSS(11)
46519 DMTOP=PMAS(6,1)
46520 DMC=PMAS(PYCOMP(KSUSY1+37),1)
46521 DAU=AT
46522 DAD=AB
46523 DMU=XMU
46524 RMSS(40)=0D0
46525 RMSS(41)=0D0
46526
46527 IF(IHOPT.EQ.0) THEN
46528 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
46529 & DMHCH,DSA,DCA,DTANBA)
46530 ELSEIF(IHOPT.EQ.1) THEN
46531 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
46532 & DMHCH,DSA,DCA,DTANBA)
46533 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
46534 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
46535 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
46536 RMSS(40)=DDT
46537 RMSS(41)=DDB
46538 DMH=DMHP
46539 DHM=DHMP
46540 DMA=DAMP
46541 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
46542 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
46543 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
46544 & PMAS(PYCOMP(1000006),1),DSTOP2
46545 ENDIF
46546 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
46547 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
46548 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
46549 & PMAS(PYCOMP(2000006),1),DSTOP1
46550 ENDIF
46551 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
46552 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
46553 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
46554 & PMAS(PYCOMP(1000005),1),DSBOT2
46555 ENDIF
46556 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
46557 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
46558 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
46559 & PMAS(PYCOMP(2000005),1),DSBOT1
46560 ENDIF
46561
46562 ELSEIF (IHOPT.EQ.3) THEN
46563c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
46564C...Currently only available for SLHA spectrum read-in.
46565 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
46566 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
46567 & //' spectrum, change IMSS(1) or IMSS(4) option.')
46568 ENDIF
46569 ALPHA=RMSS(18)
46570 RETURN
46571 ENDIF
46572
46573 ALPHA=ACOS(DCA)
46574
46575 PMAS(25,1)=DMH
46576 PMAS(35,1)=DHM
46577 PMAS(36,1)=DMA
46578 PMAS(37,1)=DMHCH
46579
46580 RETURN
46581 END
46582
46583C*********************************************************************
46584
46585C...PYSUBH
46586C...This routine computes the renormalization group improved
46587C...values of Higgs masses and couplings in the MSSM.
46588
46589C...Program based on the work by M. Carena, J.R. Espinosa,
46590c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
46591
46592C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
46593C...All masses in GeV units. MA is the CP-odd Higgs mass,
46594C...MTOP is the physical top mass, MQ and MUR are the soft
46595C...supersymmetry breaking mass parameters of left handed
46596C...and right handed stops respectively, AU and AD are the
46597C...stop and sbottom trilinear soft breaking terms,
46598C...respectively, and MU is the supersymmetric
46599C...Higgs mass parameter. We use the conventions from
46600C...the physics report of Haber and Kane: left right
46601C...stop mixing term proportional to (AU - MU/TANB)
46602C...We use as input TANB defined at the scale MTOP
46603
46604C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
46605C...where MH and HM are the lightest and heaviest CP-even
46606C...Higgs masses, MHCH is the charged Higgs mass and
46607C...ALPHA is the Higgs mixing angle
46608C...TANBA is the angle TANB at the CP-odd Higgs mass scale
46609
46610C...Range of validity:
46611C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
46612C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
46613C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
46614C...are the sbottom mass eigenvalues, respectively. This
46615C...range automatically excludes the existence of tachyons.
46616C...For the charged Higgs mass computation, the method is
46617C...valid if
46618C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
46619C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
46620C...where M_SUSY**2 is the average of the squared stop mass
46621C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
46622C...masses have been assumed to be of order of the stop ones
46623C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
46624
46625 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
46626 &XMHCH,SA,CA,TANBA)
46627
46628C...Double precision and integer declarations.
46629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46630 IMPLICIT INTEGER(I-N)
46631 INTEGER PYK,PYCHGE,PYCOMP
46632C...Parameter statement to help give large particle numbers.
46633 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46634 &KEXCIT=4000000,KDIMEN=5000000)
46635C...Commonblocks.
46636 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46637 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46638 COMMON/PYHTRI/HHH(7)
46639 SAVE /PYDAT1/,/PYDAT2/
46640
46641C...Local variables.
46642 DOUBLE PRECISION PYALEM,PYALPS
46643 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
46644 DOUBLE PRECISION XMHCH,SA,CA
46645 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
46646 DOUBLE PRECISION Q02
46647 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
46648 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
46649 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
46650 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
46651 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
46652 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
46653 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
46654 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
46655
46656 XMZ = PMAS(23,1)
46657 Q02=XMZ**2
46658 AEM=PYALEM(Q02)
46659 ALP1=AEM/(1D0-PARU(102))
46660 ALP2=AEM/PARU(102)
46661 ALPH3Z=PYALPS(Q02)
46662
46663 ALP1 = 0.0101D0
46664 ALP2 = 0.0337D0
46665 ALPH3Z = 0.12D0
46666
46667 V = 174.1D0
46668 PI = PARU(1)
46669 TANBA = TANB
46670 TANBT = TANB
46671
46672C...MBOTTOM(MTOP) = 3. GEV
46673 XMB = PYMRUN(5,XMTOP**2)
46674 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
46675 &LOG(XMTOP**2/XMZ**2))
46676
46677C...RMTOP= RUNNING TOP QUARK MASS
46678 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
46679 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
46680 T = LOG(XMS**2/XMTOP**2)
46681 SINB = TANB/((1D0 + TANB**2)**0.5D0)
46682 COSB = SINB/TANB
46683C...IF(MA.LE.XMTOP) TANBA = TANBT
46684 IF(XMA.GT.XMTOP)
46685 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
46686 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
46687 &LOG(XMA**2/XMTOP**2))
46688
46689 SINBT = TANBT/SQRT(1D0 + TANBT**2)
46690 COSBT = 1D0/SQRT(1D0 + TANBT**2)
46691C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
46692 G1 = SQRT(ALP1*4D0*PI)
46693 G2 = SQRT(ALP2*4D0*PI)
46694 G3 = SQRT(ALP3*4D0*PI)
46695 HU = RMTOP/V/SINBT
46696 HD = XMB/V/COSBT
46697 HU2=HU*HU
46698 HD2=HD*HD
46699 HU4=HU2*HU2
46700 HD4=HD2*HD2
46701 AU2=AU**2
46702 AD2=AD**2
46703 XMS2=XMS**2
46704 XMS3=XMS**3
46705 XMS4=XMS2*XMS2
46706 XMU2=XMU*XMU
46707 PI2=PI*PI
46708
46709 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
46710 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
46711 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
46712 &+ 3D0*(AU + AD)**2/XMS2)/6D0
46713 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
46714 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
46715 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
46716 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
46717 &- 16D0*G3**2) *T/16D0/PI2)
46718 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
46719 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
46720 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
46721 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
46722 &- 16D0*G3**2) *T/16D0/PI2)
46723 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
46724 &(HU2 + HD2)*T/16D0/PI2)
46725 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
46726 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
46727 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
46728 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
46729 &- 16D0*G3**2) *T/16D0/PI2)
46730 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
46731 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
46732 &- 16D0*G3**2) *T/16D0/PI2)
46733 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
46734 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
46735 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
46736 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
46737 &XMS4)*
46738 &(1+ (6D0*HU2 -2D0* HD2
46739 &- 16D0*G3**2) *T/16D0/PI2)
46740 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
46741 &XMS4)*
46742 &(1+ (6D0*HD2 -2D0* HU2/2D0
46743 &- 16D0*G3**2) *T/16D0/PI2)
46744 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
46745 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
46746 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
46747 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
46748 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
46749 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46750 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
46751 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46752 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
46753 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46754 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
46755 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
46756 HHH(1)=XLAM1
46757 HHH(2)=XLAM2
46758 HHH(3)=XLAM3
46759 HHH(4)=XLAM4
46760 HHH(5)=XLAM5
46761 HHH(6)=XLAM6
46762 HHH(7)=XLAM7
46763 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
46764 &2D0* XLAM6*SINBT*COSBT
46765 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
46766 &+ XLAM5*COSBT**2)
46767 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
46768 &XLAM6*COSBT**2
46769 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
46770 &2D0* XLAM6* COSBT*SINBT
46771 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
46772 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
46773 &((XLAM1* COSBT**2 +2D0*
46774 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
46775 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
46776 &*SINBT**2
46777 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
46778 &+ XLAM4) + XLAM6*COSBT**2
46779 &+ XLAM7* SINBT**2))
46780
46781 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
46782 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
46783 XHM = SQRT(XHM2)
46784 XMH = SQRT(XMH2)
46785 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
46786 XMHCH = SQRT(XMHCH2)
46787
46788 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
46789 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
46790 &XLAM6* COSBT*SINBT
46791 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
46792 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
46793 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
46794 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
46795
46796 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
46797 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
46798 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
46799 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
46800 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
46801 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
46802 &XLAM6* COSBT*SINBT
46803 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
46804 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
46805 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
46806
46807 SA = -SINALP
46808 CA = -COSALP
46809
46810 100 CONTINUE
46811
46812 RETURN
46813 END
46814
46815C*********************************************************************
46816
46817C...PYPOLE
46818C...This subroutine computes the CP-even higgs and CP-odd pole
46819c...Higgs masses and mixing angles.
46820
46821C...Program based on the work by M. Carena, M. Quiros
46822C...and C.E.M. Wagner, "Effective potential methods and
46823C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
46824
46825C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
46826C...AT,AB,MU
46827C...where MCHI is the largest chargino mass, MA is the running
46828C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
46829C...expectaion values at the scale MTOP, MQ is the third generation
46830C...left handed squark mass parameter, MUR is the third generation
46831C...right handed stop mass parameter, MDR is the third generation
46832C...right handed sbottom mass parameter, MTOP is the pole top quark
46833C...mass; AT,AB are the soft supersymmetry breaking trilinear
46834C...couplings of the stop and sbottoms, respectively, and MU is the
46835C...supersymmetric mass parameter
46836
46837C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
46838C...Higgses whose pole mass is computed. If IHIGGS=0 only running
46839C...masses are given, what makes the running of the program
46840c...much faster and it is quite generally a good approximation
46841c...(for a theoretical discussion see ref. above). If IHIGGS=1,
46842C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
46843c...and if IHIGGS=3, then h,H,A polarizations are computed
46844
46845C...Output: MH and MHP which are the lightest CP-even Higgs running
46846C...and pole masses, respectively; HM and HMP are the heaviest CP-even
46847C...Higgs running and pole masses, repectively; SA and CA are the
46848C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
46849C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
46850C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
46851C...the value of TANB at the CP-odd Higgs mass scale
46852
46853C...This subroutine makes use of CERN library subroutine
46854C...integration package, which makes the computation of the
46855C...pole Higgs masses somewhat faster. We thank P. Janot for this
46856C...improvement. Those who are not able to call the CERN
46857C...libraries, please use the subroutine SUBHPOLE2.F, which
46858C...although somewhat slower, gives identical results
46859
46860 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
46861 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
46862
46863C...Double precision and integer declarations.
46864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46865 IMPLICIT INTEGER(I-N)
46866
46867C...Parameters.
46868 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46869 SAVE /PYDAT1/
46870 INTEGER PYK,PYCHGE,PYCOMP
46871
46872C...Local variables.
46873 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
46874 &SSBOT2(2),B(2,2),COUPB(2,2),
46875 &HCOUPT(2,2),HCOUPB(2,2),
46876 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
46877
46878 DELTA(1,1) = 1D0
46879 DELTA(2,2) = 1D0
46880 DELTA(1,2) = 0D0
46881 DELTA(2,1) = 0D0
46882 V = 174.1D0
46883 XMZ=91.18D0
46884 PI=PARU(1)
46885 RXMT=PYMRUN(6,XMT**2)
46886 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
46887 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
46888
46889 SINB = TANB/(TANB**2+1D0)**0.5D0
46890 COSB = 1D0/(TANB**2+1D0)**0.5D0
46891 COS2B = SINB**2 - COSB**2
46892 SINBPA = SINB*CA + COSB*SA
46893 COSBPA = COSB*CA - SINB*SA
46894 RMBOT = PYMRUN(5,XMT**2)
46895 XMQ2 = XMQ**2
46896 XMUR2 = XMUR**2
46897 IF(XMUR.LT.0D0) XMUR2=-XMUR2
46898 XMDR2 = XMDR**2
46899 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
46900 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
46901 IF(XMST11.LT.0D0) GOTO 500
46902 IF(XMST22.LT.0D0) GOTO 500
46903 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
46904 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
46905 IF(XMSB11.LT.0D0) GOTO 500
46906 IF(XMSB22.LT.0D0) GOTO 500
46907C WMST11 = RXMT**2 + XMQ2
46908C WMST22 = RXMT**2 + XMUR2
46909 XMST12 = RXMT*(AT - XMU/TANB)
46910 XMSB12 = RMBOT*(AB - XMU*TANB)
46911
46912CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46913C...STOP EIGENVALUES CALCULATION
46914CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46915
46916 STOP12 = 0.5D0*(XMST11+XMST22) +
46917 &0.5D0*((XMST11+XMST22)**2 -
46918 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
46919 STOP22 = 0.5D0*(XMST11+XMST22) -
46920 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
46921 &XMST12**2))**0.5D0
46922
46923 IF(STOP22.LT.0D0) GOTO 500
46924 SSTOP2(1) = STOP12
46925 SSTOP2(2) = STOP22
46926 STOP1 = STOP12**0.5D0
46927 STOP2 = STOP22**0.5D0
46928C STOP1W = STOP1
46929C STOP2W = STOP2
46930
46931 IF(XMST12.EQ.0D0) XST11 = 1D0
46932 IF(XMST12.EQ.0D0) XST12 = 0D0
46933 IF(XMST12.EQ.0D0) XST21 = 0D0
46934 IF(XMST12.EQ.0D0) XST22 = 1D0
46935
46936 IF(XMST12.EQ.0D0) GOTO 110
46937
46938 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
46939 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
46940 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
46941 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
46942
46943 110 T(1,1) = XST11
46944 T(2,2) = XST22
46945 T(1,2) = XST12
46946 T(2,1) = XST21
46947
46948 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
46949 &0.5D0*((XMSB11+XMSB22)**2 -
46950 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
46951 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
46952 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
46953 &XMSB12**2))**0.5D0
46954 IF(SBOT22.LT.0D0) GOTO 500
46955 SBOT1 = SBOT12**0.5D0
46956 SBOT2 = SBOT22**0.5D0
46957
46958 SSBOT2(1) = SBOT12
46959 SSBOT2(2) = SBOT22
46960
46961 IF(XMSB12.EQ.0D0) XSB11 = 1D0
46962 IF(XMSB12.EQ.0D0) XSB12 = 0D0
46963 IF(XMSB12.EQ.0D0) XSB21 = 0D0
46964 IF(XMSB12.EQ.0D0) XSB22 = 1D0
46965
46966 IF(XMSB12.EQ.0D0) GOTO 130
46967
46968 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
46969 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
46970 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
46971 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
46972
46973 130 B(1,1) = XSB11
46974 B(2,2) = XSB22
46975 B(1,2) = XSB12
46976 B(2,1) = XSB21
46977
46978
46979 SINT = 0.2320D0
46980 SQR = DSQRT(2D0)
46981 VP = 174.1D0*SQR
46982
46983CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46984C...STARTING OF LIGHT HIGGS
46985CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46986
46987 IF(IHIGGS.EQ.0) GOTO 490
46988
46989 DO 150 I = 1,2
46990 DO 140 J = 1,2
46991 COUPT(I,J) =
46992 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
46993 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
46994 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
46995 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
46996 & T(1,J)*T(2,I))
46997 140 CONTINUE
46998 150 CONTINUE
46999
47000
47001 DO 170 I = 1,2
47002 DO 160 J = 1,2
47003 COUPB(I,J) =
47004 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
47005 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
47006 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
47007 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
47008 & B(1,J)*B(2,I))
47009 160 CONTINUE
47010 170 CONTINUE
47011
47012 PRUN = XMH
47013 EPS = 1D-4*PRUN
47014 ITER = 0
47015 180 ITER = ITER + 1
47016 DO 230 I3 = 1,3
47017
47018 PR(I3)=PRUN+(I3-2)*EPS/2
47019 P2=PR(I3)**2
47020 POLT = 0D0
47021 DO 200 I = 1,2
47022 DO 190 J = 1,2
47023 POLT = POLT + COUPT(I,J)**2*3D0*
47024 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
47025 190 CONTINUE
47026 200 CONTINUE
47027
47028 POLB = 0D0
47029 DO 220 I = 1,2
47030 DO 210 J = 1,2
47031 POLB = POLB + COUPB(I,J)**2*3D0*
47032 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
47033 210 CONTINUE
47034 220 CONTINUE
47035C RXMT2 = RXMT**2
47036 XMT2=XMT**2
47037
47038 POLTT =
47039 & 3D0*RXMT**2/8D0/PI**2/ V **2*
47040 & CA**2/SINB**2 *
47041 & (-2D0*XMT**2+0.5D0*P2)*
47042 & PYFINT(P2,XMT2,XMT2)
47043
47044 POL = POLT + POLB + POLTT
47045 POLAR(I3) = P2 - XMH**2 - POL
47046 230 CONTINUE
47047 DERIV = (POLAR(3)-POLAR(1))/EPS
47048 DRUN = - POLAR(2)/DERIV
47049 PRUN = PRUN + DRUN
47050 P2 = PRUN**2
47051 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
47052 GOTO 180
47053 240 CONTINUE
47054
47055 XMHP = DSQRT(P2)
47056
47057CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47058C...END OF LIGHT HIGGS
47059CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47060
47061 250 IF(IHIGGS.EQ.1) GOTO 490
47062
47063CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47064C... STARTING OF HEAVY HIGGS
47065CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47066
47067 DO 270 I = 1,2
47068 DO 260 J = 1,2
47069 HCOUPT(I,J) =
47070 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
47071 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
47072 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
47073 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
47074 & T(1,J)*T(2,I))
47075 260 CONTINUE
47076 270 CONTINUE
47077
47078 DO 290 I = 1,2
47079 DO 280 J = 1,2
47080 HCOUPB(I,J) =
47081 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
47082 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
47083 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
47084 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
47085 & B(1,J)*B(2,I))
47086 HCOUPB(I,J)=0D0
47087 280 CONTINUE
47088 290 CONTINUE
47089
47090 PRUN = HM
47091 EPS = 1D-4*PRUN
47092 ITER = 0
47093 300 ITER = ITER + 1
47094 DO 350 I3 = 1,3
47095 PR(I3)=PRUN+(I3-2)*EPS/2
47096 HP2=PR(I3)**2
47097
47098 HPOLT = 0D0
47099 DO 320 I = 1,2
47100 DO 310 J = 1,2
47101 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
47102 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
47103 310 CONTINUE
47104 320 CONTINUE
47105
47106 HPOLB = 0D0
47107 DO 340 I = 1,2
47108 DO 330 J = 1,2
47109 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
47110 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
47111 330 CONTINUE
47112 340 CONTINUE
47113
47114C RXMT2 = RXMT**2
47115 XMT2 = XMT**2
47116
47117 HPOLTT =
47118 & 3D0*RXMT**2/8D0/PI**2/ V **2*
47119 & SA**2/SINB**2 *
47120 & (-2D0*XMT**2+0.5D0*HP2)*
47121 & PYFINT(HP2,XMT2,XMT2)
47122
47123 HPOL = HPOLT + HPOLB + HPOLTT
47124 POLAR(I3) =HP2-HM**2-HPOL
47125 350 CONTINUE
47126 DERIV = (POLAR(3)-POLAR(1))/EPS
47127 DRUN = - POLAR(2)/DERIV
47128 PRUN = PRUN + DRUN
47129 HP2 = PRUN**2
47130 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
47131 GOTO 300
47132 360 CONTINUE
47133
47134
47135 370 CONTINUE
47136 HMP = HP2**0.5D0
47137
47138CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47139C... END OF HEAVY HIGGS
47140CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47141
47142 IF(IHIGGS.EQ.2) GOTO 490
47143
47144CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47145C...BEGINNING OF PSEUDOSCALAR HIGGS
47146CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47147
47148 DO 390 I = 1,2
47149 DO 380 J = 1,2
47150 ACOUPT(I,J) =
47151 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
47152 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
47153 380 CONTINUE
47154 390 CONTINUE
47155 DO 410 I = 1,2
47156 DO 400 J = 1,2
47157 ACOUPB(I,J) =
47158 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
47159 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
47160 400 CONTINUE
47161 410 CONTINUE
47162
47163 PRUN = XMA
47164 EPS = 1D-4*PRUN
47165 ITER = 0
47166 420 ITER = ITER + 1
47167 DO 470 I3 = 1,3
47168 PR(I3)=PRUN+(I3-2)*EPS/2
47169 AP2=PR(I3)**2
47170 APOLT = 0D0
47171 DO 440 I = 1,2
47172 DO 430 J = 1,2
47173 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
47174 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
47175 430 CONTINUE
47176 440 CONTINUE
47177 APOLB = 0D0
47178 DO 460 I = 1,2
47179 DO 450 J = 1,2
47180 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
47181 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
47182 450 CONTINUE
47183 460 CONTINUE
47184C RXMT2 = RXMT**2
47185 XMT2=XMT**2
47186 APOLTT =
47187 & 3D0*RXMT**2/8D0/PI**2/ V **2*
47188 & COSB**2/SINB**2 *
47189 & (-0.5D0*AP2)*
47190 & PYFINT(AP2,XMT2,XMT2)
47191 APOL = APOLT + APOLB + APOLTT
47192 POLAR(I3) = AP2 - XMA**2 -APOL
47193 470 CONTINUE
47194 DERIV = (POLAR(3)-POLAR(1))/EPS
47195 DRUN = - POLAR(2)/DERIV
47196 PRUN = PRUN + DRUN
47197 AP2 = PRUN**2
47198 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
47199 GOTO 420
47200 480 CONTINUE
47201
47202 AMP = DSQRT(AP2)
47203
47204CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47205C...END OF PSEUDOSCALAR HIGGS
47206CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47207
47208 IF(IHIGGS.EQ.3) GOTO 490
47209
47210 490 CONTINUE
47211 RETURN
47212 500 CONTINUE
47213 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
47214 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
47215 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
47216 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
47217 STOP
47218 END
47219
47220C*********************************************************************
47221
47222C...PYRGHM
47223C...Auxiliary to PYPOLE.
47224
47225 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
47226 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
47227 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
47228 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
47229C...Parameters.
47230 INTEGER MSTU,MSTJ
47231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47232 SAVE /PYDAT1/
47233
47234 MZ = 91.18D0
47235 PI = PARU(1)
47236 V = 174.1D0
47237 ALPHA1 = 0.0101D0
47238 ALPHA2 = 0.0337D0
47239 ALPHA3Z = 0.12D0
47240 TANBA = TANB
47241 TANBT = TANB
47242C MBOTTOM(MTOP) = 3. GEV
47243 MB = PYMRUN(5,MTOP**2)
47244 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
47245 *LOG(MTOP**2/MZ**2))
47246C RMTOP= RUNNING TOP QUARK MASS
47247 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
47248 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
47249 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
47250 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
47251CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47252C
47253C NEW DEFINITION, TGLU.
47254C
47255CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47256 TGLU = LOG(MGLU**2/MTOP**2)
47257 SINB = TANB/DSQRT(1D0 + TANB**2)
47258 COSB = SINB/TANB
47259 IF(MA.GT.MTOP)
47260 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
47261 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
47262 *LOG(MA**2/MTOP**2))
47263 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
47264 SINB = TANBT/SQRT(1D0 + TANBT**2)
47265 COSB = 1D0/DSQRT(1D0 + TANBT**2)
47266 G1 = SQRT(ALPHA1*4D0*PI)
47267 G2 = SQRT(ALPHA2*4D0*PI)
47268 G3 = SQRT(ALPHA3*4D0*PI)
47269 HU = RMTOP/V/SINB
47270 HD = MB/V/COSB
47271 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
47272 *SBOT1,SBOT2,DELTAMT,DELTAMB)
47273 IF(MQ.GT.MUR) TP = TQ - TU
47274 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
47275 IF(MQ.GT.MUR) TDP = TU
47276 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
47277 IF(MQ.GT.MD) TPD = TQ - TD
47278 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
47279 IF(MQ.GT.MD) TDPD = TD
47280 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
47281
47282 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
47283 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
47284 * HD**2*(G1**2/3D0+G2**2)*TPD
47285
47286 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
47287 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
47288 * HU**2*(-G1**2/3D0+G2**2)*TP
47289
47290CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47291C
47292C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
47293C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
47294C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
47295C TWO STOPS.
47296C
47297C
47298CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47299
47300 DLAMBDAP2 = 0D0
47301 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
47302 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
47303 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
47304 ENDIF
47305
47306 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
47307 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
47308 ENDIF
47309
47310 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
47311 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
47312 ENDIF
47313
47314 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
47315 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
47316 ENDIF
47317
47318 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
47319 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
47320 ENDIF
47321
47322 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
47323 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
47324 ENDIF
47325 ENDIF
47326 DLAMBDA3 = 0D0
47327 DLAMBDA4 = 0D0
47328 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
47329 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
47330 *(G2**2-G1**2/3D0)*TPD
47331 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
47332 *1D0/16D0/PI**2*G1**2*HU**2*TP
47333 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
47334 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
47335 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
47336 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
47337 *HD**2*TPD
47338 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
47339 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
47340 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
47341 *+ (3D0*HD**2/2D0 + HU**2/2D0
47342 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
47343 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
47344 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
47345 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
47346 *(TP + TDP)/8D0/PI**2)
47347 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
47348 *+ (3D0*HU**2/2D0 + HD**2/2D0
47349 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
47350 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
47351 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
47352 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47353 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
47354 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
47355 LAMBDA4 = (- G2**2/2D0)*(1D0
47356 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
47357 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
47358
47359 LAMBDA5 = 0D0
47360 LAMBDA6 = 0D0
47361 LAMBDA7 = 0D0
47362
47363 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
47364 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
47365
47366 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
47367 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
47368 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
47369 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
47370
47371 M2(2,1) = M2(1,2)
47372CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47373CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
47374CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47375
47376 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
47377
47378 IF(MCHI.GT.MSSUSY) GOTO 100
47379 IF(MCHI.LT.MTOP) MCHI=MTOP
47380
47381 TCHAR=LOG(MSSUSY**2/MCHI**2)
47382
47383 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
47384 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
47385 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
47386
47387 DELTAM112=2D0*DELTAL12*V**2*COSB**2
47388 DELTAM222=2D0*DELTAL12*V**2*SINB**2
47389 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
47390
47391 M2(1,1)=M2(1,1)+DELTAM112
47392 M2(2,2)=M2(2,2)+DELTAM222
47393 M2(1,2)=M2(1,2)+DELTAM122
47394 M2(2,1)=M2(2,1)+DELTAM122
47395
47396 100 CONTINUE
47397
47398CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47399CCC END OF CHARGINOS/NEUTRALINOS
47400CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47401
47402 DO 120 I = 1,2
47403 DO 110 J = 1,2
47404 M2P(I,J) = M2(I,J) + VH(I,J)
47405 110 CONTINUE
47406 120 CONTINUE
47407 TRM2P = M2P(1,1) + M2P(2,2)
47408 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
47409 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
47410 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
47411 HMP = DSQRT(HM2P)
47412 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
47413 MCH=DSQRT(MCH2)
47414 IF(MH2P.LT.0.) GOTO 130
47415 MHP = SQRT(MH2P)
47416 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
47417 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
47418 IF(COS2ALPHA.GE.0.) THEN
47419 ALPHA = ASIN(SIN2ALPHA)/2D0
47420 ELSE
47421 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
47422 ENDIF
47423 SA = SIN(ALPHA)
47424 CA = COS(ALPHA)
47425CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47426C
47427C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
47428C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
47429C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
47430C
47431C
47432CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47433 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
47434 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
47435 130 CONTINUE
47436 RETURN
47437 END
47438
47439C*********************************************************************
47440
47441C...PYGFXX
47442C...Auxiliary to PYRGHM.
47443
47444 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
47445 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
47446 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
47447 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
47448C...Commonblocks.
47449 INTEGER MSTU,MSTJ,KCHG
47450 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47451 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47452 SAVE /PYDAT1/,/PYDAT2/
47453
47454 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
47455
47456 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
47457 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
47458
47459 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
47460 MQ2 = MQ**2
47461 MUR2 = MUR**2
47462 MD2 = MD**2
47463 TANBA = TANB
47464 SINBA = TANBA/DSQRT(TANBA**2+1D0)
47465 COSBA = SINBA/TANBA
47466
47467 SINB = TANB/DSQRT(TANB**2+1D0)
47468 COSB = SINB/TANB
47469
47470 PI = PARU(1)
47471 MZ = PMAS(23,1)
47472 MW = PMAS(24,1)
47473 SW = 1D0-MW**2/MZ**2
47474 V = 174.1D0
47475
47476 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
47477 G2 = DSQRT(0.0336D0*4D0*PI)
47478 G1 = DSQRT(0.0101D0*4D0*PI)
47479
47480 IF(MQ.GT.MUR) MST = MQ
47481 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
47482
47483 MSUSYT = DSQRT(MST**2 + MTOP**2)
47484
47485 IF(MQ.GT.MD) MSB = MQ
47486 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
47487
47488 MB = PYMRUN(5,MSB**2)
47489 MSUSYB = DSQRT(MSB**2 + MB**2)
47490 TT = LOG(MSUSYT**2/MTOP**2)
47491 TB = LOG(MSUSYB**2/MTOP**2)
47492
47493 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
47494 HT = RMTOP/(V*SINB)
47495 HTST = RMTOP/V
47496 HB = MB/V/COSB
47497 G32 = ALPHA3*4D0*PI
47498 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
47499 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
47500 AL2 = 3D0/8D0/PI**2*HT**2
47501C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
47502C ALST = 3./8./PI**2*HTST**2
47503 AL1 = 3D0/8D0/PI**2*HB**2
47504
47505 AL(1,1) = AL1
47506 AL(1,2) = (AL2+AL1)/2D0
47507 AL(2,1) = (AL2+AL1)/2D0
47508 AL(2,2) = AL2
47509
47510 IF(MA.GT.MTOP) THEN
47511 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
47512 * LOG(MTOP**2/MA**2))
47513 H1I = VI* COSBA
47514 H2I = VI*SINBA
47515 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
47516 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
47517 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
47518 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
47519 ELSE
47520 VI = V
47521 H1I = VI*COSB
47522 H2I = VI*SINB
47523 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
47524 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
47525 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
47526 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
47527 ENDIF
47528
47529 TANBST = H2T/H1T
47530 SINBT = TANBST/DSQRT(1D0+TANBST**2)
47531
47532 TANBSB = H2B/H1B
47533 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
47534 COSBB = SINBB/TANBSB
47535
47536 DELTAMT = 0D0
47537 DELTAMB = 0D0
47538
47539 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
47540 MTOP2 = DSQRT(MTOP4)
47541 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
47542 * /(1D0+DELTAMB)**4
47543 MBOT2 = DSQRT(MBOT4)
47544
47545 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
47546 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47547 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47548 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
47549 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
47550 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47551 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47552 * MQ2 - MUR2)**2*0.25D0
47553 * + MTOP2*(AT-XMU/TANBST)**2)
47554 IF(STOP22.LT.0.) GOTO 120
47555 SBOT12 = (MQ2 + MD2)*.5D0
47556 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47557 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47558 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47559 SBOT22 = (MQ2 + MD2)*.5D0
47560 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47561 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47562 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47563 IF(SBOT22.LT.0.) SBOT22 = 10000D0
47564
47565 STOP1 = DSQRT(STOP12)
47566 STOP2 = DSQRT(STOP22)
47567 SBOT1 = DSQRT(SBOT12)
47568 SBOT2 = DSQRT(SBOT22)
47569
47570CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47571C
47572C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
47573C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
47574C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
47575C INDUCED CORRECTIONS.
47576C
47577CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47578
47579 X=SBOT1
47580 Y=SBOT2
47581 Z=XMGL
47582 IF(X.EQ.Y) X = X - 0.00001D0
47583 IF(X.EQ.Z) X = X - 0.00002D0
47584 IF(Y.EQ.Z) Y = Y - 0.00003D0
47585
47586 T1=T(X,Y,Z)
47587 X=STOP1
47588 Y=STOP2
47589 Z=XMU
47590 IF(X.EQ.Y) X = X - 0.00001D0
47591 IF(X.EQ.Z) X = X - 0.00002D0
47592 IF(Y.EQ.Z) Y = Y - 0.00003D0
47593 T2=T(X,Y,Z)
47594 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
47595 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
47596 X=STOP1
47597 Y=STOP2
47598 Z=XMGL
47599 IF(X.EQ.Y) X = X - 0.00001D0
47600 IF(X.EQ.Z) X = X - 0.00002D0
47601 IF(Y.EQ.Z) Y = Y - 0.00003D0
47602 T3=T(X,Y,Z)
47603 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
47604
47605CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47606C
47607C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
47608C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
47609C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
47610C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
47611C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
47612C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
47613C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
47614C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
47615C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
47616C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
47617C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
47618C
47619C
47620CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47621
47622 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
47623 MTOP2 = DSQRT(MTOP4)
47624 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
47625 * /(1D0+DELTAMB)**4
47626 MBOT2 = DSQRT(MBOT4)
47627
47628 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
47629 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47630 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47631 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
47632 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
47633 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
47634 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
47635 * MQ2 - MUR2)**2*0.25D0
47636 * + MTOP2*(AT-XMU/TANBST)**2)
47637
47638 IF(STOP22.LT.0.) GOTO 120
47639 SBOT12 = (MQ2 + MD2)*.5D0
47640 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47641 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47642 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47643 SBOT22 = (MQ2 + MD2)*.5D0
47644 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
47645 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
47646 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
47647 IF(SBOT22.LT.0.) GOTO 120
47648
47649
47650 STOP1 = DSQRT(STOP12)
47651 STOP2 = DSQRT(STOP22)
47652 SBOT1 = DSQRT(SBOT12)
47653 SBOT2 = DSQRT(SBOT22)
47654
47655CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47656CCC D-TERMS
47657CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47658 STW=SW
47659
47660 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
47661 * LOG(STOP1/STOP2)
47662 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
47663 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
47664
47665 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
47666 * LOG(SBOT1/SBOT2)
47667 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
47668 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
47669
47670 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
47671 * (-.5D0*LOG(STOP12/STOP22)
47672 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
47673 * G(STOP12,STOP22))
47674
47675 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
47676 * (.5D0*LOG(SBOT12/SBOT22)
47677 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
47678 * G(SBOT12,SBOT22))
47679
47680 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
47681 * (MQ2+MBOT2)/(MD2+MBOT2))
47682 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
47683 * LOG(SBOT1**2/SBOT2**2)) +
47684 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
47685 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
47686
47687 VH3T(1,1) =
47688 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
47689 * -STOP2**2))**2*G(STOP12,STOP22)
47690
47691 VH3B(1,1)=VH3B(1,1)+
47692 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
47693
47694 VH3T(1,1) = VH3T(1,1) +
47695 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
47696
47697 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
47698 * (MQ2+MTOP2)/(MUR2+MTOP2))
47699 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
47700 * LOG(STOP1**2/STOP2**2)) +
47701 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
47702 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
47703
47704 VH3B(2,2) =
47705 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
47706 * -SBOT2**2))**2*G(SBOT12,SBOT22)
47707
47708 VH3T(2,2)=VH3T(2,2)+
47709 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
47710 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
47711 VH3T(1,2) = -
47712 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
47713 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
47714 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
47715
47716 VH3B(1,2) =
47717 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
47718 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
47719 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
47720
47721
47722 VH3T(1,2)=VH3T(1,2) +
47723 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
47724
47725 VH3B(1,2)=VH3B(1,2) +
47726 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
47727
47728 VH3T(2,1) = VH3T(1,2)
47729 VH3B(2,1) = VH3B(1,2)
47730
47731C TQ = LOG((MQ2 + MTOP2)/MTOP2)
47732C TU = LOG((MUR2+MTOP2)/MTOP2)
47733C TQD = LOG((MQ2 + MB**2)/MB**2)
47734C TD = LOG((MD2+MB**2)/MB**2)
47735
47736 DO 110 I = 1,2
47737 DO 100 J = 1,2
47738 VH(I,J) =
47739 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
47740 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
47741 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
47742 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
47743 100 CONTINUE
47744 110 CONTINUE
47745
47746 GOTO 150
47747 120 DO 140 I =1,2
47748 DO 130 J = 1,2
47749 VH(I,J) = -1D15
47750 130 CONTINUE
47751 140 CONTINUE
47752
47753
47754 150 RETURN
47755 END
47756
47757
47758
47759
47760
47761C*********************************************************************
47762
47763C...PYFINT
47764C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
47765
47766 FUNCTION PYFINT(A,B,C)
47767
47768C...Double precision and integer declarations.
47769 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47770 IMPLICIT INTEGER(I-N)
47771 INTEGER PYK,PYCHGE,PYCOMP
47772C...Commonblock.
47773 COMMON/PYINTS/XXM(20)
47774 SAVE/PYINTS/
47775
47776C...Local variables.
47777 EXTERNAL PYFISB
47778 DOUBLE PRECISION PYFISB
47779
47780 XXM(1)=A
47781 XXM(2)=B
47782 XXM(3)=C
47783 XLO=0D0
47784 XHI=1D0
47785 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
47786
47787 RETURN
47788 END
47789
47790C*********************************************************************
47791
47792C...PYFISB
47793C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
47794
47795 FUNCTION PYFISB(X)
47796
47797C...Double precision and integer declarations.
47798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47799 IMPLICIT INTEGER(I-N)
47800 INTEGER PYK,PYCHGE,PYCOMP
47801C...Commonblock.
47802 COMMON/PYINTS/XXM(20)
47803 SAVE/PYINTS/
47804
47805 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
47806 &(X*(XXM(2)-XXM(3))+XXM(3)))
47807
47808 RETURN
47809 END
47810
47811C*********************************************************************
47812
47813C...PYSFDC
47814C...Calculates decays of sfermions.
47815
47816 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
47817
47818C...Double precision and integer declarations.
47819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47820 IMPLICIT INTEGER(I-N)
47821 INTEGER PYK,PYCHGE,PYCOMP
47822C...Parameter statement to help give large particle numbers.
47823 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47824 &KEXCIT=4000000,KDIMEN=5000000)
47825C...Commonblocks.
47826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47827 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47828 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47829 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47830 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47831 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47832
47833C...Local variables.
47834 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
47835 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
47836 INTEGER KFIN,KCIN
47837 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
47838 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
47839 DOUBLE PRECISION PYLAMF,XL
47840 DOUBLE PRECISION TANW,XW,AEM,C1,AS
47841 DOUBLE PRECISION AL,AR,BL,BR
47842 DOUBLE PRECISION CH1,CH2,CH3,CH4
47843 DOUBLE PRECISION XMBOT,XMTOP
47844 DOUBLE PRECISION XLAM(0:400)
47845 INTEGER IDLAM(400,3)
47846 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
47847 DOUBLE PRECISION SR2
47848 DOUBLE PRECISION CBETA,SBETA
47849 DOUBLE PRECISION CW
47850 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
47851 DOUBLE PRECISION COSA,SINA,TANB
47852 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
47853 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
47854 INTEGER IG,KF1,KF2
47855 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
47856 DATA IGG/23,25,35,36/
47857 DATA PI/3.141592654D0/
47858 DATA SR2/1.4142136D0/
47859 DATA KFNCHI/1000022,1000023,1000025,1000035/
47860 DATA KFCCHI/1000024,1000037/
47861
47862C...COUNT THE NUMBER OF DECAY MODES
47863 LKNT=0
47864
47865C...NO NU_R DECAYS
47866 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
47867 &KFIN.EQ.KSUSY2+16) RETURN
47868
47869 XMW=PMAS(24,1)
47870 XMW2=XMW**2
47871 XMZ=PMAS(23,1)
47872 XW=PARU(102)
47873 TANW = SQRT(XW/(1D0-XW))
47874 CW=SQRT(1D0-XW)
47875
47876 DO 110 I=1,4
47877 DO 100 J=1,4
47878 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
47879 100 CONTINUE
47880 110 CONTINUE
47881 DO 130 I=1,2
47882 DO 120 J=1,2
47883 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
47884 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
47885 120 CONTINUE
47886 130 CONTINUE
47887
47888C...KCIN
47889 KCIN=PYCOMP(KFIN)
47890C...ILR is 1 for left and 2 for right.
47891 ILR=KFIN/KSUSY1
47892C...IFL is matching non-SUSY flavour.
47893 IFL=MOD(KFIN,KSUSY1)
47894C...IDU is weak isospin, 1 for down and 2 for up.
47895 IDU=2-MOD(IFL,2)
47896
47897 XMI=PMAS(KCIN,1)
47898 XMI2=XMI**2
47899 AEM=PYALEM(XMI2)
47900 AS =PYALPS(XMI2)
47901 C1=AEM/XW
47902 XMI3=XMI**3
47903 EI=KCHG(IFL,1)/3D0
47904
47905 XMBOT=PYMRUN(5,XMI2)
47906 XMTOP=PYMRUN(6,XMI2)
47907
47908 TANB=RMSS(5)
47909 BETA=ATAN(TANB)
47910 ALFA=RMSS(18)
47911 CBETA=COS(BETA)
47912 SBETA=TANB*CBETA
47913 SINA=SIN(ALFA)
47914 COSA=COS(ALFA)
47915 XMU=-RMSS(4)
47916 ATRIT=RMSS(16)
47917 ATRIB=RMSS(15)
47918 ATRIL=RMSS(17)
47919
47920C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
47921
47922 IF(IMSS(11).EQ.1) THEN
47923 XMP=RMSS(29)
47924 IDG=39+KSUSY1
47925 XMGR=PMAS(PYCOMP(IDG),1)
47926 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
47927 IF(IFL.EQ.5) THEN
47928 XMF=XMBOT
47929 ELSEIF(IFL.EQ.6) THEN
47930 XMF=XMTOP
47931 ELSE
47932 XMF=PMAS(IFL,1)
47933 ENDIF
47934 IF(XMI.GT.XMGR+XMF) THEN
47935 LKNT=LKNT+1
47936 IDLAM(LKNT,1)=IDG
47937 IDLAM(LKNT,2)=IFL
47938 IDLAM(LKNT,3)=0
47939 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
47940 ENDIF
47941 ENDIF
47942
47943C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
47944
47945C...CHARGED DECAYS:
47946 DO 140 IX=1,2
47947C...DI -> U CHI1-,CHI2-
47948 IF(IDU.EQ.1) THEN
47949 XMFP=PMAS(IFL+1,1)
47950 XMF =PMAS(IFL,1)
47951C...UI -> D CHI1+,CHI2+
47952 ELSE
47953 XMFP=PMAS(IFL-1,1)
47954 XMF =PMAS(IFL,1)
47955 ENDIF
47956 XMJ=SMW(IX)
47957 AXMJ=ABS(XMJ)
47958 IF(XMI.GE.AXMJ+XMFP) THEN
47959 XMA2=XMJ**2
47960 XMB2=XMFP**2
47961 IF(IDU.EQ.2) THEN
47962 IF(IFL.EQ.6) THEN
47963 XMFP=XMBOT
47964 XMF =XMTOP
47965 ELSEIF(IFL.LT.6) THEN
47966 XMF=0D0
47967 XMFP=0D0
47968 ENDIF
47969 CBL=VMIXC(IX,1)
47970 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
47971 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
47972 CAR=0D0
47973 ELSE
47974 IF(IFL.EQ.5) THEN
47975 XMF =XMBOT
47976 XMFP=XMTOP
47977 ELSEIF(IFL.LT.5) THEN
47978 XMF=0D0
47979 XMFP=0D0
47980 ENDIF
47981 CBL=UMIXC(IX,1)
47982 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
47983 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
47984 CAR=0D0
47985 ENDIF
47986
47987 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
47988 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
47989 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
47990 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
47991 CAL=CALP
47992 CBL=CBLP
47993 CAR=CARP
47994 CBR=CBRP
47995
47996C...F1 -> F` CHI
47997 IF(ILR.EQ.1) THEN
47998 CA=CAL
47999 CB=CBL
48000C...F2 -> F` CHI
48001 ELSE
48002 CA=CAR
48003 CB=CBR
48004 ENDIF
48005 LKNT=LKNT+1
48006 XL=PYLAMF(XMI2,XMA2,XMB2)
48007C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
48008 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
48009 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
48010 IDLAM(LKNT,3)=0
48011 IF(IDU.EQ.1) THEN
48012 IDLAM(LKNT,1)=-KFCCHI(IX)
48013 IDLAM(LKNT,2)=IFL+1
48014 ELSE
48015 IDLAM(LKNT,1)=KFCCHI(IX)
48016 IDLAM(LKNT,2)=IFL-1
48017 ENDIF
48018 ENDIF
48019 140 CONTINUE
48020
48021C...NEUTRAL DECAYS
48022 DO 150 IX=1,4
48023C...DI -> D CHI10
48024 XMF=PMAS(IFL,1)
48025 XMJ=SMZ(IX)
48026 AXMJ=ABS(XMJ)
48027 IF(XMI.GE.AXMJ+XMF) THEN
48028 XMA2=XMJ**2
48029 XMB2=XMF**2
48030 IF(IDU.EQ.1) THEN
48031 IF(IFL.EQ.5) THEN
48032 XMF=XMBOT
48033 ELSEIF(IFL.LT.5) THEN
48034 XMF=0D0
48035 ENDIF
48036 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
48037 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
48038 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
48039 CBR=CAL
48040 ELSE
48041 IF(IFL.EQ.6) THEN
48042 XMF=XMTOP
48043 ELSEIF(IFL.LT.5) THEN
48044 XMF=0D0
48045 ENDIF
48046 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
48047 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
48048 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
48049 CBR=CAL
48050 ENDIF
48051
48052 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
48053 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
48054 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
48055 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
48056 CAL=CALP
48057 CBL=CBLP
48058 CAR=CARP
48059 CBR=CBRP
48060
48061C...F1 -> F CHI
48062 IF(ILR.EQ.1) THEN
48063 CA=CAL
48064 CB=CBL
48065C...F2 -> F CHI
48066 ELSE
48067 CA=CAR
48068 CB=CBR
48069 ENDIF
48070 LKNT=LKNT+1
48071 XL=PYLAMF(XMI2,XMA2,XMB2)
48072C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
48073 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
48074 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
48075 IDLAM(LKNT,1)=KFNCHI(IX)
48076 IDLAM(LKNT,2)=IFL
48077 IDLAM(LKNT,3)=0
48078 ENDIF
48079 150 CONTINUE
48080
48081C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
48082C...IG=23,25,35,36
48083 DO 160 II=1,4
48084 IG=IGG(II)
48085 IF(ILR.EQ.1) GOTO 160
48086 XMB=PMAS(IG,1)
48087 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
48088 IF(XMI.LT.XMSF1+XMB) GOTO 160
48089 IF(IG.EQ.23) THEN
48090 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
48091 BR=EI*XW/CW
48092 BLR=0D0
48093 ELSEIF(IG.EQ.25) THEN
48094 IF(IFL.EQ.5) THEN
48095 XMF=XMBOT
48096 ELSEIF(IFL.EQ.6) THEN
48097 XMF=XMTOP
48098 ELSEIF(IFL.LT.5) THEN
48099 XMF=0D0
48100 ELSE
48101 XMF=PMAS(IFL,1)
48102 ENDIF
48103 IF(IDU.EQ.2) THEN
48104 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
48105 & XMF**2/XMW*COSA/SBETA
48106 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
48107 & XMF**2/XMW*COSA/SBETA
48108 ELSE
48109 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
48110 & XMF**2/XMW*(-SINA)/CBETA
48111 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
48112 & XMF**2/XMW*(-SINA)/CBETA
48113 ENDIF
48114 IF(IFL.EQ.5) THEN
48115 AT=ATRIB
48116 ELSEIF(IFL.EQ.6) THEN
48117 AT=ATRIT
48118 ELSEIF(IFL.EQ.15) THEN
48119 AT=ATRIL
48120 ELSE
48121 AT=0D0
48122 ENDIF
48123C.........need to complexify
48124 IF(IDU.EQ.2) THEN
48125 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
48126 & AT*COSA)
48127 ELSE
48128 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
48129 & AT*SINA)
48130 ENDIF
48131 BL=GHLL
48132 BR=GHRR
48133 BLR=-GHLR
48134 ELSEIF(IG.EQ.35) THEN
48135 IF(IFL.EQ.5) THEN
48136 XMF=XMBOT
48137 ELSEIF(IFL.EQ.6) THEN
48138 XMF=XMTOP
48139 ELSEIF(IFL.LT.5) THEN
48140 XMF=0D0
48141 ELSE
48142 XMF=PMAS(IFL,1)
48143 ENDIF
48144 IF(IDU.EQ.2) THEN
48145 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
48146 & XMF**2/XMW*SINA/SBETA
48147 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
48148 & XMF**2/XMW*SINA/SBETA
48149 ELSE
48150 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
48151 & XMF**2/XMW*COSA/CBETA
48152 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
48153 & XMF**2/XMW*COSA/CBETA
48154 ENDIF
48155 IF(IFL.EQ.5) THEN
48156 AT=ATRIB
48157 ELSEIF(IFL.EQ.6) THEN
48158 AT=ATRIT
48159 ELSEIF(IFL.EQ.15) THEN
48160 AT=ATRIL
48161 ELSE
48162 AT=0D0
48163 ENDIF
48164C.........Need to complexify
48165 IF(IDU.EQ.2) THEN
48166 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
48167 & AT*SINA)
48168 ELSE
48169 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
48170 & AT*COSA)
48171 ENDIF
48172 BL=GHLL
48173 BR=GHRR
48174 BLR=GHLR
48175 ELSEIF(IG.EQ.36) THEN
48176 GHLL=0D0
48177 GHRR=0D0
48178 IF(IFL.EQ.5) THEN
48179 XMF=XMBOT
48180 ELSEIF(IFL.EQ.6) THEN
48181 XMF=XMTOP
48182 ELSEIF(IFL.LT.5) THEN
48183 XMF=0D0
48184 ELSE
48185 XMF=PMAS(IFL,1)
48186 ENDIF
48187 IF(IFL.EQ.5) THEN
48188 AT=ATRIB
48189 ELSEIF(IFL.EQ.6) THEN
48190 AT=ATRIT
48191 ELSEIF(IFL.EQ.15) THEN
48192 AT=ATRIL
48193 ELSE
48194 AT=0D0
48195 ENDIF
48196C.........Need to complexify
48197 IF(IDU.EQ.2) THEN
48198 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
48199 ELSE
48200 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
48201 ENDIF
48202 BL=GHLL
48203 BR=GHRR
48204 BLR=GHLR
48205 ENDIF
48206 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
48207 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
48208 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
48209 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48210 LKNT=LKNT+1
48211 IF(IG.EQ.23) THEN
48212 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
48213 ELSE
48214 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
48215 ENDIF
48216 IDLAM(LKNT,3)=0
48217 IDLAM(LKNT,1)=KFIN-KSUSY1
48218 IDLAM(LKNT,2)=IG
48219 160 CONTINUE
48220
48221C...SF -> SF' + W
48222 XMB=PMAS(24,1)
48223 IF(MOD(IFL,2).EQ.0) THEN
48224 KF1=KSUSY1+IFL-1
48225 ELSE
48226 KF1=KSUSY1+IFL+1
48227 ENDIF
48228 KF2=KF1+KSUSY1
48229 XMSF1=PMAS(PYCOMP(KF1),1)
48230 XMSF2=PMAS(PYCOMP(KF2),1)
48231 IF(XMI.GT.XMB+XMSF1) THEN
48232 IF(MOD(IFL,2).EQ.0) THEN
48233 IF(ILR.EQ.1) THEN
48234 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
48235 ELSE
48236 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
48237 ENDIF
48238 ELSE
48239 IF(ILR.EQ.1) THEN
48240 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
48241 ELSE
48242 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
48243 ENDIF
48244 ENDIF
48245 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48246 LKNT=LKNT+1
48247 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
48248 IDLAM(LKNT,3)=0
48249 IDLAM(LKNT,1)=KF1
48250 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
48251 ENDIF
48252 IF(XMI.GT.XMB+XMSF2) THEN
48253 IF(MOD(IFL,2).EQ.0) THEN
48254 IF(ILR.EQ.1) THEN
48255 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
48256 ELSE
48257 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
48258 ENDIF
48259 ELSE
48260 IF(ILR.EQ.1) THEN
48261 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
48262 ELSE
48263 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
48264 ENDIF
48265 ENDIF
48266 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
48267 LKNT=LKNT+1
48268 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
48269 IDLAM(LKNT,3)=0
48270 IDLAM(LKNT,1)=KF2
48271 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
48272 ENDIF
48273
48274C...SF -> SF' + HC
48275 XMB=PMAS(37,1)
48276 IF(MOD(IFL,2).EQ.0) THEN
48277 KF1=KSUSY1+IFL-1
48278 ELSE
48279 KF1=KSUSY1+IFL+1
48280 ENDIF
48281 KF2=KF1+KSUSY1
48282 XMSF1=PMAS(PYCOMP(KF1),1)
48283 XMSF2=PMAS(PYCOMP(KF2),1)
48284 IF(XMI.GT.XMB+XMSF1) THEN
48285 XMF=0D0
48286 XMFP=0D0
48287 AT=0D0
48288 AB=0D0
48289 IF(MOD(IFL,2).EQ.0) THEN
48290C...T1-> B1 HC
48291 IF(ILR.EQ.1) THEN
48292 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
48293 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
48294 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
48295 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
48296C...T2-> B1 HC
48297 ELSE
48298 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
48299 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
48300 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
48301 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
48302 ENDIF
48303 IF(IFL.EQ.6) THEN
48304 XMF=XMTOP
48305 XMFP=XMBOT
48306 AT=ATRIT
48307 AB=ATRIB
48308 ENDIF
48309 ELSE
48310C...B1 -> T1 HC
48311 IF(ILR.EQ.1) THEN
48312 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
48313 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
48314 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
48315 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
48316C...B2-> T1 HC
48317 ELSE
48318 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
48319 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
48320 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
48321 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
48322 ENDIF
48323 IF(IFL.EQ.5) THEN
48324 XMF=XMTOP
48325 XMFP=XMBOT
48326 AT=ATRIT
48327 AB=ATRIB
48328 ENDIF
48329 ENDIF
48330 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48331 LKNT=LKNT+1
48332C.......Need to complexify
48333 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
48334 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
48335 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
48336 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
48337 IDLAM(LKNT,3)=0
48338 IDLAM(LKNT,1)=KF1
48339 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
48340 ENDIF
48341 IF(XMI.GT.XMB+XMSF2) THEN
48342 XMF=0D0
48343 XMFP=0D0
48344 AT=0D0
48345 AB=0D0
48346 IF(MOD(IFL,2).EQ.0) THEN
48347C...T1-> B2 HC
48348 IF(ILR.EQ.1) THEN
48349 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
48350 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
48351 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
48352 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
48353C...T2-> B2 HC
48354 ELSE
48355 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
48356 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
48357 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
48358 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
48359 ENDIF
48360 IF(IFL.EQ.6) THEN
48361 XMF=XMTOP
48362 XMFP=XMBOT
48363 AT=ATRIT
48364 AB=ATRIB
48365 ENDIF
48366 ELSE
48367C...B1 -> T2 HC
48368 IF(ILR.EQ.1) THEN
48369 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
48370 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
48371 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
48372 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
48373C...B2-> T2 HC
48374 ELSE
48375 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
48376 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
48377 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
48378 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
48379 ENDIF
48380 IF(IFL.EQ.5) THEN
48381 XMF=XMTOP
48382 XMFP=XMBOT
48383 AT=ATRIT
48384 AB=ATRIB
48385 ENDIF
48386 ENDIF
48387 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
48388 LKNT=LKNT+1
48389C.......Need to complexify
48390 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
48391 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
48392 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
48393 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
48394 IDLAM(LKNT,3)=0
48395 IDLAM(LKNT,1)=KF2
48396 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
48397 ENDIF
48398
48399C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
48400
48401 IF(IFL.LE.6) THEN
48402 XMFP=0D0
48403 XMF=0D0
48404 IF(IFL.EQ.6) XMF=PMAS(6,1)
48405 IF(IFL.EQ.5) XMF=PMAS(5,1)
48406 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
48407 AXMJ=ABS(XMJ)
48408 IF(XMI.GE.AXMJ+XMF) THEN
48409 AL=-SFMIX(IFL,3)
48410 BL=SFMIX(IFL,1)
48411 AR=-SFMIX(IFL,4)
48412 BR=SFMIX(IFL,2)
48413C...F1 -> F CHI
48414 IF(ILR.EQ.1) THEN
48415 XCA=AL
48416 XCB=BL
48417C...F2 -> F CHI
48418 ELSE
48419 XCA=AR
48420 XCB=BR
48421 ENDIF
48422 LKNT=LKNT+1
48423 XMA2=XMJ**2
48424 XMB2=XMF**2
48425 XL=PYLAMF(XMI2,XMA2,XMB2)
48426 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
48427 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
48428 IDLAM(LKNT,1)=KSUSY1+21
48429 IDLAM(LKNT,2)=IFL
48430 IDLAM(LKNT,3)=0
48431 ENDIF
48432 ENDIF
48433
48434C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
48435 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
48436 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
48437C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
48438C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
48439C...M*M = C1**2 * G**2/(16PI**2)
48440C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
48441 LKNT=LKNT+1
48442 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
48443 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
48444 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
48445 IDLAM(LKNT,1)=KSUSY1+22
48446 IDLAM(LKNT,2)=4
48447 IDLAM(LKNT,3)=0
48448 ENDIF
48449
48450C...R-violating sfermion decays (SKANDS).
48451 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
48452
48453 IKNT=LKNT
48454 XLAM(0)=0D0
48455 DO 170 I=1,IKNT
48456 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
48457 XLAM(0)=XLAM(0)+XLAM(I)
48458 170 CONTINUE
48459 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
48460
48461 RETURN
48462 END
48463
48464C*********************************************************************
48465
48466C...PYGLUI
48467C...Calculates gluino decay modes.
48468
48469 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
48470
48471C...Double precision and integer declarations.
48472 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48473 IMPLICIT INTEGER(I-N)
48474 INTEGER PYK,PYCHGE,PYCOMP
48475C...Parameter statement to help give large particle numbers.
48476 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48477 &KEXCIT=4000000,KDIMEN=5000000)
48478C...Commonblocks.
48479 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48480 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48481 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48482 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48483 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48484CC &SFMIX(16,4),
48485C COMMON/PYINTS/XXM(20)
48486 COMPLEX*16 CXC
48487 COMMON/PYINTC/XXC(10),CXC(8)
48488 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
48489
48490C...Local variables
48491 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
48492 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
48493 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48494 DOUBLE PRECISION PYLAMF,XL
48495 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
48496 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
48497 DOUBLE PRECISION XLAM(0:400)
48498 INTEGER IDLAM(400,3)
48499 INTEGER LKNT,IX,ILR,I,IKNT,IFL
48500 DOUBLE PRECISION SR2
48501 DOUBLE PRECISION GAM
48502 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
48503 EXTERNAL PYGAUS,PYXXZ6
48504 DOUBLE PRECISION PYGAUS,PYXXZ6
48505 DOUBLE PRECISION PREC
48506 INTEGER KFNCHI(4),KFCCHI(2)
48507 DATA PI/3.141592654D0/
48508 DATA SR2/1.4142136D0/
48509 DATA PREC/1D-2/
48510 DATA KFNCHI/1000022,1000023,1000025,1000035/
48511 DATA KFCCHI/1000024,1000037/
48512
48513C...COUNT THE NUMBER OF DECAY MODES
48514 LKNT=0
48515 IF(KFIN.NE.KSUSY1+21) RETURN
48516 KCIN=PYCOMP(KFIN)
48517
48518 XW=PARU(102)
48519 TANW = SQRT(XW/(1D0-XW))
48520
48521 XMI=PMAS(KCIN,1)
48522 AXMI=ABS(XMI)
48523 XMI2=XMI**2
48524 AEM=PYALEM(XMI2)
48525 AS =PYALPS(XMI2)
48526 C1=AEM/XW
48527 XMI3=AXMI**3
48528
48529 XMI=SIGN(XMI,RMSS(3))
48530
48531C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
48532
48533 IF(IMSS(11).EQ.1) THEN
48534 XMP=RMSS(29)
48535 IDG=39+KSUSY1
48536 XMGR=PMAS(PYCOMP(IDG),1)
48537 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
48538 IF(AXMI.GT.XMGR) THEN
48539 LKNT=LKNT+1
48540 IDLAM(LKNT,1)=IDG
48541 IDLAM(LKNT,2)=21
48542 IDLAM(LKNT,3)=0
48543 XLAM(LKNT)=XFAC
48544 ENDIF
48545 ENDIF
48546
48547C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
48548
48549 DO 110 IFL=1,6
48550 DO 100 ILR=1,2
48551 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
48552 AXMJ=ABS(XMJ)
48553 XMF=PMAS(IFL,1)
48554 IF(AXMI.GE.AXMJ+XMF) THEN
48555C...Minus sign difference from gluino-quark-squark feynman rules
48556 AL=SFMIX(IFL,1)
48557 BL=-SFMIX(IFL,3)
48558 AR=SFMIX(IFL,2)
48559 BR=-SFMIX(IFL,4)
48560C...F1 -> F CHI
48561 IF(ILR.EQ.1) THEN
48562 CA=AL
48563 CB=BL
48564C...F2 -> F CHI
48565 ELSE
48566 CA=AR
48567 CB=BR
48568 ENDIF
48569 LKNT=LKNT+1
48570 XMA2=XMJ**2
48571 XMB2=XMF**2
48572 XL=PYLAMF(XMI2,XMA2,XMB2)
48573 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
48574 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
48575 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
48576 IDLAM(LKNT,2)=-IFL
48577 IDLAM(LKNT,3)=0
48578 LKNT=LKNT+1
48579 XLAM(LKNT)=XLAM(LKNT-1)
48580 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48581 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48582 IDLAM(LKNT,3)=0
48583 ENDIF
48584 100 CONTINUE
48585 110 CONTINUE
48586
48587C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
48588C...GLUINO -> NI Q QBAR
48589 DO 170 IX=1,4
48590 XMJ=SMZ(IX)
48591 AXMJ=ABS(XMJ)
48592 IF(AXMI.GE.AXMJ) THEN
48593 DO 120 I=1,4
48594 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
48595 120 CONTINUE
48596 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
48597 ORPP=DCONJG(OLPP)
48598 XXC(1)=0D0
48599 XXC(2)=XMJ
48600 XXC(3)=0D0
48601 XXC(4)=XMI
48602 IA=1
48603 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
48604 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
48605 XXC(7)=XXC(5)
48606 XXC(8)=XXC(6)
48607 XXC(9)=1D6
48608 XXC(10)=0D0
48609 EI=KCHG(IA,1)/3D0
48610 T3I=SIGN(1D0,EI+1D-6)/2D0
48611 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
48612 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
48613 CXC(1)=0D0
48614 CXC(2)=-GLIJ
48615 CXC(3)=0D0
48616 CXC(4)=DCONJG(GLIJ)
48617 CXC(5)=0D0
48618 CXC(6)=GRIJ
48619 CXC(7)=0D0
48620 CXC(8)=-DCONJG(GRIJ)
48621 S12MIN=0D0
48622 S12MAX=(AXMI-AXMJ)**2
48623 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
48624 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
48625 LKNT=LKNT+1
48626 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
48627 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
48628 IDLAM(LKNT,1)=KFNCHI(IX)
48629 IDLAM(LKNT,2)=1
48630 IDLAM(LKNT,3)=-1
48631 ENDIF
48632 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
48633 LKNT=LKNT+1
48634 XLAM(LKNT)=XLAM(LKNT-1)
48635 IDLAM(LKNT,1)=KFNCHI(IX)
48636 IDLAM(LKNT,2)=3
48637 IDLAM(LKNT,3)=-3
48638 ENDIF
48639 130 CONTINUE
48640 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
48641 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
48642 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
48643 GOTO 140
48644 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
48645 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
48646 ENDIF
48647 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
48648 LKNT=LKNT+1
48649 XLAM(LKNT)=GAM
48650 IDLAM(LKNT,1)=KFNCHI(IX)
48651 IDLAM(LKNT,2)=5
48652 IDLAM(LKNT,3)=-5
48653 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
48654 ENDIF
48655C...U-TYPE QUARKS
48656 140 CONTINUE
48657 IA=2
48658 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
48659 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
48660C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
48661 XXC(7)=XXC(5)
48662 XXC(8)=XXC(6)
48663 EI=KCHG(IA,1)/3D0
48664 T3I=SIGN(1D0,EI+1D-6)/2D0
48665 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
48666 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
48667 CXC(2)=-GLIJ
48668 CXC(4)=DCONJG(GLIJ)
48669 CXC(6)=GRIJ
48670 CXC(8)=-DCONJG(GRIJ)
48671 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
48672 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
48673 LKNT=LKNT+1
48674 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
48675 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
48676 IDLAM(LKNT,1)=KFNCHI(IX)
48677 IDLAM(LKNT,2)=2
48678 IDLAM(LKNT,3)=-2
48679 ENDIF
48680 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
48681 LKNT=LKNT+1
48682 XLAM(LKNT)=XLAM(LKNT-1)
48683 IDLAM(LKNT,1)=KFNCHI(IX)
48684 IDLAM(LKNT,2)=4
48685 IDLAM(LKNT,3)=-4
48686 ENDIF
48687 150 CONTINUE
48688C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
48689C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
48690 XMF=PMAS(6,1)
48691 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
48692 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
48693 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
48694 GOTO 160
48695 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
48696 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
48697 ENDIF
48698 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
48699 LKNT=LKNT+1
48700 XLAM(LKNT)=GAM
48701 IDLAM(LKNT,1)=KFNCHI(IX)
48702 IDLAM(LKNT,2)=6
48703 IDLAM(LKNT,3)=-6
48704 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
48705 ENDIF
48706 160 CONTINUE
48707 ENDIF
48708 170 CONTINUE
48709
48710C...GLUINO -> CI Q QBAR'
48711 DO 210 IX=1,2
48712 XMJ=SMW(IX)
48713 AXMJ=ABS(XMJ)
48714 IF(AXMI.GE.AXMJ) THEN
48715 DO 180 I=1,2
48716 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
48717 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
48718 180 CONTINUE
48719 S12MIN=0D0
48720 S12MAX=(AXMI-AXMJ)**2
48721 XXC(1)=0D0
48722 XXC(2)=XMJ
48723 XXC(3)=0D0
48724 XXC(4)=XMI
48725 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
48726 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
48727 XXC(9)=1D6
48728 XXC(10)=0D0
48729 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
48730 ORPP=DCONJG(OLPP)
48731 CXC(1)=DCMPLX(0D0,0D0)
48732 CXC(3)=DCMPLX(0D0,0D0)
48733 CXC(5)=DCMPLX(0D0,0D0)
48734 CXC(7)=DCMPLX(0D0,0D0)
48735 CXC(2)=UMIXC(IX,1)*OLPP/SR2
48736 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
48737 CXC(6)=DCMPLX(0D0,0D0)
48738 CXC(8)=DCMPLX(0D0,0D0)
48739 IF(XXC(5).LT.AXMI) THEN
48740 XXC(5)=1D6
48741 ELSEIF(XXC(6).LT.AXMI) THEN
48742 XXC(6)=1D6
48743 ENDIF
48744 XXC(7)=XXC(6)
48745 XXC(8)=XXC(5)
48746 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
48747 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
48748 LKNT=LKNT+1
48749 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
48750 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
48751 IDLAM(LKNT,1)=KFCCHI(IX)
48752 IDLAM(LKNT,2)=1
48753 IDLAM(LKNT,3)=-2
48754 LKNT=LKNT+1
48755 XLAM(LKNT)=XLAM(LKNT-1)
48756 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48757 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48758 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
48759 ENDIF
48760 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
48761 LKNT=LKNT+1
48762 XLAM(LKNT)=XLAM(LKNT-1)
48763 IDLAM(LKNT,1)=KFCCHI(IX)
48764 IDLAM(LKNT,2)=3
48765 IDLAM(LKNT,3)=-4
48766 LKNT=LKNT+1
48767 XLAM(LKNT)=XLAM(LKNT-1)
48768 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48769 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48770 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
48771 ENDIF
48772 190 CONTINUE
48773
48774 XMF=PMAS(6,1)
48775 XMFP=PMAS(5,1)
48776 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
48777 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
48778 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
48779 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
48780 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
48781 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
48782 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
48783 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
48784 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
48785 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
48786 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
48787 CALL PYTBBC(IX,100,XMI,GAM)
48788 LKNT=LKNT+1
48789 XLAM(LKNT)=GAM
48790 IDLAM(LKNT,1)=KFCCHI(IX)
48791 IDLAM(LKNT,2)=5
48792 IDLAM(LKNT,3)=-6
48793 LKNT=LKNT+1
48794 XLAM(LKNT)=XLAM(LKNT-1)
48795 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
48796 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
48797 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
48798 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
48799 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
48800 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
48801 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
48802 ENDIF
48803 200 CONTINUE
48804 ENDIF
48805 210 CONTINUE
48806
48807C...R-parity violating (3-body) decays.
48808 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
48809
48810 IKNT=LKNT
48811 XLAM(0)=0D0
48812 DO 220 I=1,IKNT
48813 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
48814 XLAM(0)=XLAM(0)+XLAM(I)
48815 220 CONTINUE
48816 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
48817
48818 RETURN
48819 END
48820
48821
48822C*********************************************************************
48823
48824C...PYTBBN
48825C...Calculates the three-body decay of gluinos into
48826C...neutralinos and third generation fermions.
48827
48828 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
48829
48830C...Double precision and integer declarations.
48831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48832 IMPLICIT INTEGER(I-N)
48833 INTEGER PYK,PYCHGE,PYCOMP
48834C...Parameter statement to help give large particle numbers.
48835 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48836 &KEXCIT=4000000,KDIMEN=5000000)
48837C...Commonblocks.
48838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48840 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48841 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48842 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48843 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48844
48845C...Local variables.
48846 EXTERNAL PYSIMP,PYLAMF
48847 DOUBLE PRECISION PYSIMP,PYLAMF
48848 INTEGER LIN,NN
48849 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
48850 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
48851 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
48852 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
48853 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
48854 DOUBLE PRECISION XLN1,XLN2,B1,B2
48855 DOUBLE PRECISION E,XMGLU,GAM
48856 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
48857 SAVE HRB,HLB,FLB,FRB
48858 DOUBLE PRECISION ALPHAW,ALPHAS
48859 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
48860 SAVE HLT,HRT,FLT,FRT
48861 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
48862 SAVE AMN,AN,ZN
48863 DOUBLE PRECISION AMBOT,SINC,COSC
48864 DOUBLE PRECISION AMTOP,SINA,COSA
48865 DOUBLE PRECISION SINW,COSW,TANW
48866 DOUBLE PRECISION ROT1(4,4)
48867 LOGICAL IFIRST
48868 SAVE IFIRST
48869 DATA IFIRST/.TRUE./
48870
48871 TANB=RMSS(5)
48872 SINB=TANB/SQRT(1D0+TANB**2)
48873 COSB=SINB/TANB
48874 XW=PARU(102)
48875 SINW=SQRT(XW)
48876 COSW=SQRT(1D0-XW)
48877 TANW=SINW/COSW
48878 AMW=PMAS(24,1)
48879 COSC=SFMIX(5,1)
48880 SINC=SFMIX(5,3)
48881 COSA=SFMIX(6,1)
48882 SINA=SFMIX(6,3)
48883 AMBOT=PYMRUN(5,XMGLU**2)
48884 AMTOP=PYMRUN(6,XMGLU**2)
48885 W2=SQRT(2D0)
48886 FAKT1=AMBOT/W2/AMW/COSB
48887 FAKT2=AMTOP/W2/AMW/SINB
48888 IF(IFIRST) THEN
48889 DO 110 II=1,4
48890 AMN(II)=SMZ(II)
48891 DO 100 J=1,4
48892 ROT1(II,J)=0D0
48893 AN(II,J)=0D0
48894 100 CONTINUE
48895 110 CONTINUE
48896 ROT1(1,1)=COSW
48897 ROT1(1,2)=-SINW
48898 ROT1(2,1)=-ROT1(1,2)
48899 ROT1(2,2)=ROT1(1,1)
48900 ROT1(3,3)=COSB
48901 ROT1(3,4)=SINB
48902 ROT1(4,3)=-ROT1(3,4)
48903 ROT1(4,4)=ROT1(3,3)
48904 DO 140 II=1,4
48905 DO 130 J=1,4
48906 DO 120 JJ=1,4
48907 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
48908 120 CONTINUE
48909 130 CONTINUE
48910 140 CONTINUE
48911 DO 150 J=1,4
48912 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
48913 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
48914 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
48915 & XW)*AN(J,2)/COSW
48916 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
48917 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
48918 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
48919 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
48920C FLU(J)=ZN(3)
48921C FRU(J)=ZN(2)
48922 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
48923 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
48924 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
48925 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
48926 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
48927 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
48928 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
48929C FLD(J)=ZN(3)
48930C FRD(J)=ZN(2)
48931 150 CONTINUE
48932C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
48933C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
48934C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
48935C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
48936 IFIRST=.FALSE.
48937 ENDIF
48938
48939 IF(NINT(3D0*E).EQ.2) THEN
48940 HL=HLT(I)
48941 HR=HRT(I)
48942 FL=FLT(I)
48943 FR=FRT(I)
48944 COSD=SFMIX(6,1)
48945 SIND=SFMIX(6,3)
48946 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
48947 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
48948 XM=PMAS(6,1)
48949 ELSE
48950 HL=HLB(I)
48951 HR=HRB(I)
48952 FL=FLB(I)
48953 FR=FRB(I)
48954 COSD=SFMIX(5,1)
48955 SIND=SFMIX(5,3)
48956 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
48957 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
48958 XM=PMAS(5,1)
48959 ENDIF
48960 COSD2=COSD*COSD
48961 SIND2=SIND*SIND
48962 COS2D=COSD2-SIND2
48963 SIN2D=SIND*COSD*2D0
48964 HL2=HL*HL
48965 HR2=HR*HR
48966 FL2=FL*FL
48967 FR2=FR*FR
48968 FF=FL*FR
48969 HH=HL*HR
48970 HFL=HL*FL
48971 HFR=HR*FR
48972 HRFL=HR*FL
48973 HLFR=HL*FR
48974 XM2=XM*XM
48975 XMG=XMGLU
48976 XMG2=XMG*XMG
48977 ALPHAW=PYALEM(XMG2)
48978 ALPHAS=PYALPS(XMG2)
48979 XMR=AMN(I)
48980 XMR2=XMR*XMR
48981 XMQ4=XMG*XM2*XMR
48982 XM24=(XMG2+XM2)*(XM2+XMR2)
48983 SMIN=4D0*XM2
48984 SMAX=(XMG-ABS(XMR))**2
48985 XMQA=XMG2+2D0*XM2+XMR2
48986 DO 170 LIN=1,NN-1
48987 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
48988 GRS=SBAR-XMQA
48989 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
48990 W=DSQRT(W)
48991 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
48992 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
48993 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
48994 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
48995 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
48996 & +2D0*(FF*SIND2-HH*COSD2))*W
48997 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
48998 & +4D0*HFL*XM*XMR)*XLN1
48999 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
49000 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
49001 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
49002 & +8D0*HFL*XMQ4*SIN2D)*B1
49003 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
49004 & +4D0*HFR*XMR*XM)*XLN2
49005 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
49006 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
49007 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
49008 & -8D0*HFR*XMQ4*SIN2D)*B2
49009 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
49010 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
49011 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
49012 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
49013 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
49014 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
49015 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
49016 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
49017 G(5)=(2D0*(HH*COSD2-FF*SIND2)
49018 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
49019 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
49020 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
49021 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
49022 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
49023 & +COS2D*XM*(SBAR+XMG2-XMR2))
49024 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
49025 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
49026 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
49027 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
49028 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
49029 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
49030 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
49031 SUMME(LIN)=0D0
49032 DO 160 J=0,6
49033 SUMME(LIN)=SUMME(LIN)+G(J)
49034 160 CONTINUE
49035 170 CONTINUE
49036 SUMME(0)=0D0
49037 SUMME(NN)=0D0
49038 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
49039 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
49040
49041 RETURN
49042 END
49043
49044C*********************************************************************
49045
49046C...PYTBBC
49047C...Calculates the three-body decay of gluinos into
49048C...charginos and third generation fermions.
49049
49050 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
49051
49052C...Double precision and integer declarations.
49053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49054 IMPLICIT INTEGER(I-N)
49055 INTEGER PYK,PYCHGE,PYCOMP
49056C...Parameter statement to help give large particle numbers.
49057 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49058 &KEXCIT=4000000,KDIMEN=5000000)
49059C...Commonblocks.
49060 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49061 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49062 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49063 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49064 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49065 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49066
49067C...Local variables.
49068 EXTERNAL PYSIMP,PYLAMF
49069 DOUBLE PRECISION PYSIMP,PYLAMF
49070 INTEGER I,NN,LIN
49071 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
49072 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
49073 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
49074 DOUBLE PRECISION SUMME(0:100),A(4,8)
49075 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
49076 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
49077 DOUBLE PRECISION XMGLU,GAM
49078 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
49079 &DDD(2),EEE(2),FFF(2)
49080 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
49081 DOUBLE PRECISION ALPHAW,ALPHAS
49082 DOUBLE PRECISION AMC(2)
49083 SAVE AMC
49084 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
49085 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
49086 SAVE AMSB,AMST
49087 LOGICAL IFIRST
49088 SAVE IFIRST
49089 DATA IFIRST/.TRUE./
49090
49091 TANB=RMSS(5)
49092 SINB=TANB/SQRT(1D0+TANB**2)
49093 COSB=SINB/TANB
49094 XW=PARU(102)
49095 AMW=PMAS(24,1)
49096 COSC=SFMIX(5,1)
49097 SINC=SFMIX(5,3)
49098 COSA=SFMIX(6,1)
49099 SINA=SFMIX(6,3)
49100 AMBOT=PYMRUN(5,XMGLU**2)
49101 AMTOP=PYMRUN(6,XMGLU**2)
49102 W2=SQRT(2D0)
49103 AMW=PMAS(24,1)
49104 FAKT1=AMBOT/W2/AMW/COSB
49105 FAKT2=AMTOP/W2/AMW/SINB
49106 IF(IFIRST) THEN
49107 AMC(1)=SMW(1)
49108 AMC(2)=SMW(2)
49109 DO 100 JJ=1,2
49110 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
49111 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
49112 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
49113 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
49114 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
49115 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
49116 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
49117 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
49118 100 CONTINUE
49119 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
49120 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
49121 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
49122 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
49123 IFIRST=.FALSE.
49124 ENDIF
49125
49126 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
49127 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
49128 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
49129 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
49130
49131 COS2A=COSA**2-SINA**2
49132 SIN2A=SINA*COSA*2D0
49133 COS2C=COSC**2-SINC**2
49134 SIN2C=SINC*COSC*2D0
49135
49136 XMG=XMGLU
49137 XMT=PMAS(6,1)
49138 XMB=PMAS(5,1)
49139 XMR=AMC(I)
49140 XMG2=XMG*XMG
49141 ALPHAW=PYALEM(XMG2)
49142 ALPHAS=PYALPS(XMG2)
49143 XMT2=XMT*XMT
49144 XMB2=XMB*XMB
49145 XMR2=XMR*XMR
49146 XMQ2=XMG2+XMT2+XMB2+XMR2
49147 XMQ4=XMG*XMT*XMB*XMR
49148 XMQ3=XMG2*XMR2+XMT2*XMB2
49149 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
49150 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
49151
49152 XMST(1)=AMST(1)*AMST(1)
49153 XMST(2)=AMST(1)*AMST(1)
49154 XMST(3)=AMST(2)*AMST(2)
49155 XMST(4)=AMST(2)*AMST(2)
49156 XMSB(1)=AMSB(1)*AMSB(1)
49157 XMSB(2)=AMSB(2)*AMSB(2)
49158 XMSB(3)=AMSB(1)*AMSB(1)
49159 XMSB(4)=AMSB(2)*AMSB(2)
49160
49161 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
49162 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
49163 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
49164 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
49165 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
49166 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
49167 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
49168 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
49169
49170 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
49171 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
49172 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
49173 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
49174 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
49175 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
49176 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
49177 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
49178
49179 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
49180 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
49181 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
49182 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
49183 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
49184 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
49185 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
49186 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
49187
49188 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
49189 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
49190 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
49191 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
49192 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
49193 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
49194 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
49195 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
49196
49197 SMAX=(XMG-ABS(XMR))**2
49198 SMIN=(XMB+XMT)**2+0.1D0
49199
49200 DO 120 LIN=0,NN-1
49201 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
49202 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
49203 GRS=SBAR-XMQ2
49204 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
49205 W=DSQRT(W)/2D0/SBAR
49206 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
49207 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
49208 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
49209 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
49210 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
49211 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
49212 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
49213 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
49214 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
49215 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
49216 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
49217 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
49218 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
49219 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
49220 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
49221 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
49222 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
49223 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
49224 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
49225 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
49226 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
49227 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
49228 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
49229 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
49230 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
49231 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
49232 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
49233 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
49234 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
49235 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
49236 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
49237 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
49238 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
49239 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
49240 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
49241 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
49242 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
49243 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
49244 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
49245 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
49246 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
49247 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
49248 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
49249 DO 110 J=1,4
49250 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
49251 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
49252 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
49253 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
49254 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
49255 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
49256 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
49257 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
49258 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
49259 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
49260 & -A(J,6)*(XMG2+XMR2-SBAR)
49261 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
49262 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
49263 & /(GRS+XMSB(J)+XMST(J))
49264 110 CONTINUE
49265 120 CONTINUE
49266 SUMME(NN)=0D0
49267 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
49268 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
49269
49270 RETURN
49271 END
49272
49273C*********************************************************************
49274
49275C...PYNJDC
49276C...Calculates decay widths for the neutralinos (admixtures of
49277C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
49278
49279C...Input: KCIN = KF code for particle
49280C...Output: XLAM = widths
49281C... IDLAM = KF codes for decay particles
49282C... IKNT = number of decay channels defined
49283C...AUTHOR: STEPHEN MRENNA
49284C...Last change:
49285C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
49286C...when CHIGAMMA .NE. 0
49287C...10 FEB 96: Calculate this decay for small tan(beta)
49288
49289 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
49290
49291C...Double precision and integer declarations.
49292 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49293 IMPLICIT INTEGER(I-N)
49294 INTEGER PYK,PYCHGE,PYCOMP
49295C...Parameter statement to help give large particle numbers.
49296 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49297 &KEXCIT=4000000,KDIMEN=5000000)
49298C...Commonblocks.
49299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49300 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49301 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49302c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49303c &SFMIX(16,4)
49304 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49305 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49306C COMMON/PYINTS/XXM(20)
49307 COMPLEX*16 CXC
49308 COMMON/PYINTC/XXC(10),CXC(8)
49309 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49310
49311C...Local variables.
49312 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49313 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
49314 INTEGER KFIN
49315 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
49316 &XMZ,XMZ2,AXMJ,AXMI
49317 DOUBLE PRECISION S12MIN,S12MAX
49318 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
49319 DOUBLE PRECISION PYLAMF,XL
49320 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
49321 DOUBLE PRECISION PYX2XH,PYX2XG
49322 DOUBLE PRECISION XLAM(0:400)
49323 INTEGER IDLAM(400,3)
49324 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
49325 INTEGER ITH(3),KF1,KF2
49326 INTEGER ITHC
49327 DOUBLE PRECISION DH(3),EH(3)
49328 DOUBLE PRECISION SR2
49329 DOUBLE PRECISION CBETA,SBETA
49330 DOUBLE PRECISION GAMCON,XMT1,XMT2
49331 DOUBLE PRECISION PYALEM,PI,PYALPS
49332 DOUBLE PRECISION RAT1,RAT2
49333 DOUBLE PRECISION T3T,FCOL
49334 DOUBLE PRECISION ALFA,BETA,TANB
49335 DOUBLE PRECISION PYXXGA
49336 EXTERNAL PYGAUS,PYXXZ6
49337 DOUBLE PRECISION PYGAUS,PYXXZ6
49338 DOUBLE PRECISION PREC
49339 INTEGER KFNCHI(4),KFCCHI(2)
49340 DATA ITH/25,35,36/
49341 DATA ITHC/37/
49342 DATA PREC/1D-2/
49343 DATA PI/3.141592654D0/
49344 DATA SR2/1.4142136D0/
49345 DATA KFNCHI/1000022,1000023,1000025,1000035/
49346 DATA KFCCHI/1000024,1000037/
49347
49348C...COUNT THE NUMBER OF DECAY MODES
49349 LKNT=0
49350
49351 XMW=PMAS(24,1)
49352 XMW2=XMW**2
49353 XMZ=PMAS(23,1)
49354 XMZ2=XMZ**2
49355 XW=1D0-XMW2/XMZ2
49356 XW1=1D0-XW
49357 TANW = SQRT(XW/XW1)
49358
49359C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
49360 IX=1
49361 IF(KFIN.EQ.KFNCHI(2)) IX=2
49362 IF(KFIN.EQ.KFNCHI(3)) IX=3
49363 IF(KFIN.EQ.KFNCHI(4)) IX=4
49364
49365 XMI=SMZ(IX)
49366 XMI2=XMI**2
49367 AXMI=ABS(XMI)
49368 AEM=PYALEM(XMI2)
49369 AS =PYALPS(XMI2)
49370 C1=AEM/XW
49371 XMI3=ABS(XMI**3)
49372
49373 TANB=RMSS(5)
49374 BETA=ATAN(TANB)
49375 ALFA=RMSS(18)
49376 CBETA=COS(BETA)
49377 SBETA=TANB*CBETA
49378 CALFA=COS(ALFA)
49379 SALFA=SIN(ALFA)
49380
49381 DO 110 I=1,4
49382 DO 100 J=1,4
49383 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49384 100 CONTINUE
49385 110 CONTINUE
49386 DO 130 I=1,2
49387 DO 120 J=1,2
49388 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49389 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49390 120 CONTINUE
49391 130 CONTINUE
49392
49393C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
49394 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
49395
49396C...FORCE CHI0_2 -> CHI0_1 + GAMMA
49397 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
49398 XMJ=SMZ(1)
49399 AXMJ=ABS(XMJ)
49400 LKNT=LKNT+1
49401 GAMCON=AEM**3/8D0/PI/XMW2/XW
49402 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
49403 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
49404 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
49405 IDLAM(LKNT,1)=KSUSY1+22
49406 IDLAM(LKNT,2)=22
49407 IDLAM(LKNT,3)=0
49408 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
49409 GOTO 340
49410 ENDIF
49411
49412C...GRAVITINO DECAY MODES
49413
49414 IF(IMSS(11).EQ.1) THEN
49415 XMP=RMSS(29)
49416 IDG=39+KSUSY1
49417 XMGR=PMAS(PYCOMP(IDG),1)
49418 SINW=SQRT(XW)
49419 COSW=SQRT(1D0-XW)
49420 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49421 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
49422 LKNT=LKNT+1
49423 IDLAM(LKNT,1)=IDG
49424 IDLAM(LKNT,2)=22
49425 IDLAM(LKNT,3)=0
49426 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
49427 ENDIF
49428 IF(AXMI.GT.XMGR+XMZ) THEN
49429 LKNT=LKNT+1
49430 IDLAM(LKNT,1)=IDG
49431 IDLAM(LKNT,2)=23
49432 IDLAM(LKNT,3)=0
49433 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
49434 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
49435 & (1D0-XMZ2/XMI2)**4
49436 ENDIF
49437 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
49438 LKNT=LKNT+1
49439 IDLAM(LKNT,1)=IDG
49440 IDLAM(LKNT,2)=25
49441 IDLAM(LKNT,3)=0
49442 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
49443 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
49444 ENDIF
49445 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
49446 LKNT=LKNT+1
49447 IDLAM(LKNT,1)=IDG
49448 IDLAM(LKNT,2)=35
49449 IDLAM(LKNT,3)=0
49450 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
49451 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
49452 ENDIF
49453 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
49454 LKNT=LKNT+1
49455 IDLAM(LKNT,1)=IDG
49456 IDLAM(LKNT,2)=36
49457 IDLAM(LKNT,3)=0
49458 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
49459 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
49460 ENDIF
49461 IF(IX.EQ.1) GOTO 300
49462 ENDIF
49463
49464 DO 220 IJ=1,IX-1
49465 XMJ=SMZ(IJ)
49466 AXMJ=ABS(XMJ)
49467 XMJ2=XMJ**2
49468
49469C...CHI0_I -> CHI0_J + GAMMA
49470 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
49471 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
49472 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
49473 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
49474 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
49475 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
49476 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
49477 LKNT=LKNT+1
49478 IDLAM(LKNT,1)=KFNCHI(IJ)
49479 IDLAM(LKNT,2)=22
49480 IDLAM(LKNT,3)=0
49481 GAMCON=AEM**3/8D0/PI/XMW2/XW
49482 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
49483 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
49484 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
49485 ENDIF
49486 ENDIF
49487
49488C...CHI0_I -> CHI0_J + Z0
49489 IF(AXMI.GE.AXMJ+XMZ) THEN
49490 LKNT=LKNT+1
49491 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
49492 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
49493 ORPP=-DCONJG(OLPP)
49494 GX2=ABS(OLPP)**2+ABS(ORPP)**2
49495 GLR=DBLE(OLPP*DCONJG(ORPP))
49496 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
49497 IDLAM(LKNT,1)=KFNCHI(IJ)
49498 IDLAM(LKNT,2)=23
49499 IDLAM(LKNT,3)=0
49500 ELSEIF(AXMI.GE.AXMJ) THEN
49501 XXC(1)=0D0
49502 XXC(2)=XMJ
49503 XXC(3)=0D0
49504 XXC(4)=XMI
49505 XXC(9)=XMZ
49506 XXC(10)=PMAS(23,2)
49507 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
49508 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
49509 ORPP=DCONJG(OLPP)
49510C...CHARGED LEPTONS
49511 FID=11
49512 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49513 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49514 EI=KCHG(FID,1)/3D0
49515 T3I=SIGN(1D0,EI+1D-6)/2D0
49516 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49517 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49518 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49519 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49520 CXC(2)=-GLIJ
49521 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49522 CXC(4)=DCONJG(GLIJ)
49523 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49524 CXC(6)=GRIJ
49525 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49526 CXC(8)=-DCONJG(GRIJ)
49527 S12MIN=0D0
49528 S12MAX=(AXMI-AXMJ)**2
49529 IF( XXC(5).LT.AXMI ) THEN
49530 XXC(5)=1D6
49531 ENDIF
49532 IF(XXC(6).LT.AXMI ) THEN
49533 XXC(6)=1D6
49534 ENDIF
49535 XXC(7)=XXC(5)
49536 XXC(8)=XXC(6)
49537
49538 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
49539 LKNT=LKNT+1
49540 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49541 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49542 IDLAM(LKNT,1)=KFNCHI(IJ)
49543 IDLAM(LKNT,2)=FID
49544 IDLAM(LKNT,3)=-FID
49545 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
49546 LKNT=LKNT+1
49547 XLAM(LKNT)=XLAM(LKNT-1)
49548 IDLAM(LKNT,1)=KFNCHI(IJ)
49549 IDLAM(LKNT,2)=13
49550 IDLAM(LKNT,3)=-13
49551 ENDIF
49552 ENDIF
49553 140 CONTINUE
49554 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
49555 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
49556 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
49557 ELSE
49558 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
49559 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
49560 ENDIF
49561 IF( XXC(5).LT.AXMI ) THEN
49562 XXC(5)=1D6
49563 ENDIF
49564 IF(XXC(6).LT.AXMI ) THEN
49565 XXC(6)=1D6
49566 ENDIF
49567 XXC(7)=XXC(5)
49568 XXC(8)=XXC(6)
49569
49570 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
49571 LKNT=LKNT+1
49572 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49573 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49574 IDLAM(LKNT,1)=KFNCHI(IJ)
49575 IDLAM(LKNT,2)=15
49576 IDLAM(LKNT,3)=-15
49577 ENDIF
49578
49579C...NEUTRINOS
49580 150 CONTINUE
49581 FID=12
49582 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49583 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49584 EI=KCHG(FID,1)/3D0
49585 T3I=SIGN(1D0,EI+1D-6)/2D0
49586 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49587 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49588 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49589 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49590 CXC(2)=-GLIJ
49591 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49592 CXC(4)=DCONJG(GLIJ)
49593 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49594 CXC(6)=GRIJ
49595 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49596 CXC(8)=-DCONJG(GRIJ)
49597 S12MIN=0D0
49598 S12MAX=(AXMI-AXMJ)**2
49599 IF( XXC(5).LT.AXMI ) THEN
49600 XXC(5)=1D6
49601 ENDIF
49602 IF( XXC(6).LT.AXMI ) THEN
49603 XXC(6)=1D6
49604 ENDIF
49605 XXC(7)=XXC(5)
49606 XXC(8)=XXC(6)
49607
49608 LKNT=LKNT+1
49609 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49610 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49611 IDLAM(LKNT,1)=KFNCHI(IJ)
49612 IDLAM(LKNT,2)=12
49613 IDLAM(LKNT,3)=-12
49614 LKNT=LKNT+1
49615 XLAM(LKNT)=XLAM(LKNT-1)
49616 IDLAM(LKNT,1)=KFNCHI(IJ)
49617 IDLAM(LKNT,2)=14
49618 IDLAM(LKNT,3)=-14
49619 160 CONTINUE
49620
49621 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
49622 & THEN
49623 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
49624 IF( XXC(5).LT.AXMI ) THEN
49625 XXC(5)=1D6
49626 ENDIF
49627 XXC(7)=XXC(5)
49628 LKNT=LKNT+1
49629 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49630 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
49631 ELSE
49632 LKNT=LKNT+1
49633 XLAM(LKNT)=XLAM(LKNT-1)
49634 ENDIF
49635 IDLAM(LKNT,1)=KFNCHI(IJ)
49636 IDLAM(LKNT,2)=16
49637 IDLAM(LKNT,3)=-16
49638C...D-TYPE QUARKS
49639 170 CONTINUE
49640 FID=1
49641 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49642 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49643 EI=KCHG(FID,1)/3D0
49644 T3I=SIGN(1D0,EI+1D-6)/2D0
49645 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49646 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49647 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49648 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49649 CXC(2)=-GLIJ
49650 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49651 CXC(4)=DCONJG(GLIJ)
49652 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49653 CXC(6)=GRIJ
49654 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49655 CXC(8)=-DCONJG(GRIJ)
49656 S12MIN=0D0
49657 S12MAX=(AXMI-AXMJ)**2
49658 IF( XXC(5).LT.AXMI ) THEN
49659 XXC(5)=1D6
49660 ENDIF
49661 IF( XXC(6).LT.AXMI ) THEN
49662 XXC(6)=1D6
49663 ENDIF
49664 XXC(7)=XXC(5)
49665 XXC(8)=XXC(6)
49666
49667 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49668 LKNT=LKNT+1
49669 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49670 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
49671 IDLAM(LKNT,1)=KFNCHI(IJ)
49672 IDLAM(LKNT,2)=1
49673 IDLAM(LKNT,3)=-1
49674 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49675 LKNT=LKNT+1
49676 XLAM(LKNT)=XLAM(LKNT-1)
49677 IDLAM(LKNT,1)=KFNCHI(IJ)
49678 IDLAM(LKNT,2)=3
49679 IDLAM(LKNT,3)=-3
49680 ENDIF
49681 ENDIF
49682 180 CONTINUE
49683 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
49684 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
49685 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
49686 ELSE
49687 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
49688 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
49689 ENDIF
49690 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
49691 IF(XXC(5).LT.AXMI) THEN
49692 XXC(5)=1D6
49693 ELSEIF(XXC(6).LT.AXMI) THEN
49694 XXC(6)=1D6
49695 ENDIF
49696 XXC(7)=XXC(5)
49697 XXC(8)=XXC(6)
49698 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49699 LKNT=LKNT+1
49700 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49701 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
49702 IDLAM(LKNT,1)=KFNCHI(IJ)
49703 IDLAM(LKNT,2)=5
49704 IDLAM(LKNT,3)=-5
49705 ENDIF
49706
49707C...U-TYPE QUARKS
49708 190 CONTINUE
49709 FID=2
49710 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
49711 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
49712 EI=KCHG(FID,1)/3D0
49713 T3I=SIGN(1D0,EI+1D-6)/2D0
49714 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
49715 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
49716 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
49717 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
49718 CXC(2)=-GLIJ
49719 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
49720 CXC(4)=DCONJG(GLIJ)
49721 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
49722 CXC(6)=GRIJ
49723 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
49724 CXC(8)=-DCONJG(GRIJ)
49725
49726 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
49727 IF(XXC(5).LT.AXMI) THEN
49728 XXC(5)=1D6
49729 ELSEIF(XXC(6).LT.AXMI) THEN
49730 XXC(6)=1D6
49731 ENDIF
49732 XXC(7)=XXC(5)
49733 XXC(8)=XXC(6)
49734
49735 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49736 LKNT=LKNT+1
49737 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49738 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
49739 IDLAM(LKNT,1)=KFNCHI(IJ)
49740 IDLAM(LKNT,2)=2
49741 IDLAM(LKNT,3)=-2
49742 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49743 LKNT=LKNT+1
49744 XLAM(LKNT)=XLAM(LKNT-1)
49745 IDLAM(LKNT,1)=KFNCHI(IJ)
49746 IDLAM(LKNT,2)=4
49747 IDLAM(LKNT,3)=-4
49748 ENDIF
49749 ENDIF
49750 200 CONTINUE
49751 ENDIF
49752
49753C...CHI0_I -> CHI0_J + H0_K
49754 EH(1)=SIN(ALFA)
49755 EH(2)=COS(ALFA)
49756 EH(3)=-SIN(BETA)
49757 DH(1)=COS(ALFA)
49758 DH(2)=-SIN(ALFA)
49759 DH(3)=COS(BETA)
49760 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
49761 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
49762 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
49763 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
49764 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
49765 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
49766 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
49767 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
49768 DO 210 IH=1,3
49769 XMH=PMAS(ITH(IH),1)
49770 XMH2=XMH**2
49771 IF(AXMI.GE.AXMJ+XMH) THEN
49772 LKNT=LKNT+1
49773 XL=PYLAMF(XMI2,XMJ2,XMH2)
49774 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
49775 F12K=F21K
49776C...SIGN OF MASSES I,J
49777 XMK=XMJ
49778 IF(IH.EQ.3) XMK=-XMK
49779 GX2=ABS(F21K)**2+ABS(F12K)**2
49780 GLR=DBLE(F21K*DCONJG(F12K))
49781 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
49782 IDLAM(LKNT,1)=KFNCHI(IJ)
49783 IDLAM(LKNT,2)=ITH(IH)
49784 IDLAM(LKNT,3)=0
49785 ENDIF
49786 210 CONTINUE
49787 220 CONTINUE
49788
49789C...CHI0_I -> CHI+_J + W-
49790 DO 260 IJ=1,2
49791 XMJ=SMW(IJ)
49792 AXMJ=ABS(XMJ)
49793 XMJ2=XMJ**2
49794 IF(AXMI.GE.AXMJ+XMW) THEN
49795 LKNT=LKNT+1
49796 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
49797 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
49798 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
49799 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
49800 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
49801 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
49802 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
49803 IDLAM(LKNT,1)=KFCCHI(IJ)
49804 IDLAM(LKNT,2)=-24
49805 IDLAM(LKNT,3)=0
49806 LKNT=LKNT+1
49807 XLAM(LKNT)=XLAM(LKNT-1)
49808 IDLAM(LKNT,1)=-KFCCHI(IJ)
49809 IDLAM(LKNT,2)=24
49810 IDLAM(LKNT,3)=0
49811 ELSEIF(AXMI.GE.AXMJ) THEN
49812 S12MIN=0D0
49813 S12MAX=(AXMI-AXMJ)**2
49814 RT2I = 1D0/SQRT(2D0)
49815 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
49816 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
49817 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
49818 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
49819 CXC(5)=DCMPLX(0D0,0D0)
49820 CXC(7)=DCMPLX(0D0,0D0)
49821 IA=11
49822 JA=12
49823 EI=KCHG(IA,1)/3D0
49824 T3I=SIGN(1D0,EI+1D-6)/2D0
49825 EJ=KCHG(JA,1)/3D0
49826 T3J=SIGN(1D0,EJ+1D-6)/2D0
49827 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
49828 & TANW+ZMIXC(IX,2)*T3J)*RT2I
49829 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
49830 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
49831 CXC(6)=DCMPLX(0D0,0D0)
49832 CXC(8)=DCMPLX(0D0,0D0)
49833 XXC(1)=0D0
49834 XXC(2)=XMJ
49835 XXC(3)=0D0
49836 XXC(4)=XMI
49837 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
49838 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
49839 XXC(9)=PMAS(24,1)
49840 XXC(10)=PMAS(24,2)
49841 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
49842 IF(XXC(5).LT.AXMI) THEN
49843 XXC(5)=1D6
49844 ELSEIF(XXC(6).LT.AXMI) THEN
49845 XXC(6)=1D6
49846 ENDIF
49847 XXC(7)=XXC(6)
49848 XXC(8)=XXC(5)
49849 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
49850 LKNT=LKNT+1
49851 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49852 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49853 IDLAM(LKNT,1)=KFCCHI(IJ)
49854 IDLAM(LKNT,2)=11
49855 IDLAM(LKNT,3)=-12
49856 LKNT=LKNT+1
49857 XLAM(LKNT)=XLAM(LKNT-1)
49858 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49859 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49860 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49861 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
49862 LKNT=LKNT+1
49863 XLAM(LKNT)=XLAM(LKNT-1)
49864 IDLAM(LKNT,1)=KFCCHI(IJ)
49865 IDLAM(LKNT,2)=13
49866 IDLAM(LKNT,3)=-14
49867 LKNT=LKNT+1
49868 XLAM(LKNT)=XLAM(LKNT-1)
49869 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49870 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49871 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49872 ENDIF
49873 ENDIF
49874 230 CONTINUE
49875 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
49876 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
49877 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
49878 ELSE
49879 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
49880 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
49881 ENDIF
49882 IF(XXC(5).LT.AXMI) THEN
49883 XXC(5)=1D6
49884 ENDIF
49885 IF(XXC(6).LT.AXMI) THEN
49886 XXC(6)=1D6
49887 ENDIF
49888 XXC(7)=XXC(6)
49889 XXC(8)=XXC(5)
49890 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
49891 LKNT=LKNT+1
49892 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
49893 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49894 XLAM(LKNT)=XLAM(LKNT-1)
49895 IDLAM(LKNT,1)=KFCCHI(IJ)
49896 IDLAM(LKNT,2)=15
49897 IDLAM(LKNT,3)=-16
49898 LKNT=LKNT+1
49899 XLAM(LKNT)=XLAM(LKNT-1)
49900 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49901 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49902 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49903 ENDIF
49904
49905C...NOW, DO THE QUARKS
49906 240 CONTINUE
49907 IA=1
49908 JA=2
49909 EI=KCHG(IA,1)/3D0
49910 T3I=SIGN(1D0,EI+1D-6)/2D0
49911 EJ=KCHG(JA,1)/3D0
49912 T3J=SIGN(1D0,EJ+1D-6)/2D0
49913 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
49914 & TANW+ZMIXC(IX,2)*T3J)
49915 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
49916 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
49917 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49918 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
49919 IF(XXC(5).LT.AXMI) THEN
49920 XXC(5)=1D6
49921 ENDIF
49922 IF(XXC(6).LT.AXMI) THEN
49923 XXC(6)=1D6
49924 ENDIF
49925 XXC(7)=XXC(6)
49926 XXC(8)=XXC(5)
49927 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
49928 LKNT=LKNT+1
49929 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
49930 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49931 IDLAM(LKNT,1)=KFCCHI(IJ)
49932 IDLAM(LKNT,2)=1
49933 IDLAM(LKNT,3)=-2
49934 LKNT=LKNT+1
49935 XLAM(LKNT)=XLAM(LKNT-1)
49936 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49937 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49938 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49939 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49940 LKNT=LKNT+1
49941 XLAM(LKNT)=XLAM(LKNT-1)
49942 IDLAM(LKNT,1)=KFCCHI(IJ)
49943 IDLAM(LKNT,2)=3
49944 IDLAM(LKNT,3)=-4
49945 LKNT=LKNT+1
49946 XLAM(LKNT)=XLAM(LKNT-1)
49947 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49948 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49949 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49950 ENDIF
49951 ENDIF
49952 250 CONTINUE
49953 ENDIF
49954 260 CONTINUE
49955 270 CONTINUE
49956
49957C...CHI0_I -> CHI+_I + H-
49958 DO 280 IJ=1,2
49959 XMJ=SMW(IJ)
49960 AXMJ=ABS(XMJ)
49961 XMJ2=XMJ**2
49962 XMHP=PMAS(ITHC,1)
49963 IF(AXMI.GE.AXMJ+XMHP) THEN
49964 LKNT=LKNT+1
49965 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
49966 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
49967 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
49968 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
49969 & UMIXC(IJ,2)/SR2)
49970 GX2=ABS(OLPP)**2+ABS(ORPP)**2
49971 GLR=DBLE(OLPP*DCONJG(ORPP))
49972 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
49973 IDLAM(LKNT,1)=KFCCHI(IJ)
49974 IDLAM(LKNT,2)=-ITHC
49975 IDLAM(LKNT,3)=0
49976 LKNT=LKNT+1
49977 XLAM(LKNT)=XLAM(LKNT-1)
49978 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49979 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49980 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49981 ELSE
49982
49983 ENDIF
49984 280 CONTINUE
49985
49986C...2-BODY DECAYS TO FERMION SFERMION
49987 DO 290 J=1,16
49988 IF(J.GE.7.AND.J.LE.10) GOTO 290
49989 KF1=KSUSY1+J
49990 KF2=KSUSY2+J
49991 XMSF1=PMAS(PYCOMP(KF1),1)
49992 XMSF2=PMAS(PYCOMP(KF2),1)
49993 XMF=PMAS(J,1)
49994 IF(J.LE.6) THEN
49995 FCOL=3D0
49996 ELSE
49997 FCOL=1D0
49998 ENDIF
49999
50000 EI=KCHG(J,1)/3D0
50001 T3T=SIGN(1D0,EI)
50002 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
50003 IF(MOD(J,2).EQ.0) THEN
50004 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
50005 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50006 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50007 CBR=CAL
50008 ELSE
50009 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
50010 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50011 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50012 CBR=CAL
50013 ENDIF
50014
50015C...D~ D_L
50016 IF(AXMI.GE.XMF+XMSF1) THEN
50017 LKNT=LKNT+1
50018 XMA2=XMSF1**2
50019 XMB2=XMF**2
50020 XL=PYLAMF(XMI2,XMA2,XMB2)
50021 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
50022 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
50023 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50024 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50025 IDLAM(LKNT,1)=KF1
50026 IDLAM(LKNT,2)=-J
50027 IDLAM(LKNT,3)=0
50028 LKNT=LKNT+1
50029 XLAM(LKNT)=XLAM(LKNT-1)
50030 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50031 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50032 IDLAM(LKNT,3)=0
50033 ENDIF
50034
50035C...D~ D_R
50036 IF(AXMI.GE.XMF+XMSF2) THEN
50037 LKNT=LKNT+1
50038 XMA2=XMSF2**2
50039 XMB2=XMF**2
50040 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
50041 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
50042 XL=PYLAMF(XMI2,XMA2,XMB2)
50043 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50044 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50045 IDLAM(LKNT,1)=KF2
50046 IDLAM(LKNT,2)=-J
50047 IDLAM(LKNT,3)=0
50048 LKNT=LKNT+1
50049 XLAM(LKNT)=XLAM(LKNT-1)
50050 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50051 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50052 IDLAM(LKNT,3)=0
50053 ENDIF
50054 290 CONTINUE
50055 300 CONTINUE
50056C...3-BODY DECAY TO Q Q~ GLUINO
50057 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50058 IF(AXMI.GE.XMJ) THEN
50059 RT2I = 1D0/SQRT(2D0)
50060 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
50061 ORPP=DCONJG(OLPP)
50062 AXMJ=ABS(XMJ)
50063 XXC(1)=0D0
50064 XXC(2)=XMJ
50065 XXC(3)=0D0
50066 XXC(4)=XMI
50067 FID=1
50068 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50069 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50070 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
50071 XXC(7)=XXC(5)
50072 XXC(8)=XXC(6)
50073 XXC(9)=1D6
50074 XXC(10)=0D0
50075 EI=KCHG(FID,1)/3D0
50076 T3I=SIGN(1D0,EI+1D-6)/2D0
50077 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50078 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50079 CXC(1)=0D0
50080 CXC(2)=-GLIJ
50081 CXC(3)=0D0
50082 CXC(4)=DCONJG(GLIJ)
50083 CXC(5)=0D0
50084 CXC(6)=GRIJ
50085 CXC(7)=0D0
50086 CXC(8)=-DCONJG(GRIJ)
50087 S12MIN=0D0
50088 S12MAX=(AXMI-AXMJ)**2
50089C...ALL QUARKS BUT T
50090 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50091 LKNT=LKNT+1
50092 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
50093 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50094 IDLAM(LKNT,1)=KSUSY1+21
50095 IDLAM(LKNT,2)=1
50096 IDLAM(LKNT,3)=-1
50097 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50098 LKNT=LKNT+1
50099 XLAM(LKNT)=XLAM(LKNT-1)
50100 IDLAM(LKNT,1)=KSUSY1+21
50101 IDLAM(LKNT,2)=3
50102 IDLAM(LKNT,3)=-3
50103 ENDIF
50104 ENDIF
50105 310 CONTINUE
50106 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50107 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50108 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50109 ELSE
50110 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50111 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50112 ENDIF
50113 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
50114 XXC(7)=XXC(5)
50115 XXC(8)=XXC(6)
50116 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50117 LKNT=LKNT+1
50118 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50119 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50120 IDLAM(LKNT,1)=KSUSY1+21
50121 IDLAM(LKNT,2)=5
50122 IDLAM(LKNT,3)=-5
50123 ENDIF
50124C...U-TYPE QUARKS
50125 320 CONTINUE
50126 FID=2
50127 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50128 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50129 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
50130 XXC(7)=XXC(5)
50131 XXC(8)=XXC(6)
50132 EI=KCHG(FID,1)/3D0
50133 T3I=SIGN(1D0,EI+1D-6)/2D0
50134 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50135 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50136 CXC(2)=-GLIJ
50137 CXC(4)=DCONJG(GLIJ)
50138 CXC(6)=GRIJ
50139 CXC(8)=-DCONJG(GRIJ)
50140 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50141 LKNT=LKNT+1
50142 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50143 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50144 IDLAM(LKNT,1)=KSUSY1+21
50145 IDLAM(LKNT,2)=2
50146 IDLAM(LKNT,3)=-2
50147 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50148 LKNT=LKNT+1
50149 XLAM(LKNT)=XLAM(LKNT-1)
50150 IDLAM(LKNT,1)=KSUSY1+21
50151 IDLAM(LKNT,2)=4
50152 IDLAM(LKNT,3)=-4
50153 ENDIF
50154 ENDIF
50155 330 CONTINUE
50156 ENDIF
50157
50158C...R-violating decay modes (SKANDS).
50159 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
50160
50161 340 IKNT=LKNT
50162 XLAM(0)=0D0
50163 DO 350 I=1,IKNT
50164 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50165 XLAM(0)=XLAM(0)+XLAM(I)
50166 350 CONTINUE
50167 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50168
50169 RETURN
50170 END
50171
50172C*********************************************************************
50173
50174C...PYCJDC
50175C...Calculate decay widths for the charginos (admixtures of
50176C...charged Wino and charged Higgsino.
50177
50178C...Input: KCIN = KF code for particle
50179C...Output: XLAM = widths
50180C... IDLAM = KF codes for decay particles
50181C... IKNT = number of decay channels defined
50182C...AUTHOR: STEPHEN MRENNA
50183C...Last change:
50184C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
50185C...when CHIENU .NE. 0
50186
50187 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
50188
50189C...Double precision and integer declarations.
50190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50191 IMPLICIT INTEGER(I-N)
50192 INTEGER PYK,PYCHGE,PYCOMP
50193C...Parameter statement to help give large particle numbers.
50194 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50195 &KEXCIT=4000000,KDIMEN=5000000)
50196C...Commonblocks.
50197 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50198 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50199 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50200 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50201 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50202CC &SFMIX(16,4),
50203C COMMON/PYINTS/XXM(20)
50204 COMPLEX*16 CXC
50205 COMMON/PYINTC/XXC(10),CXC(8)
50206 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50207
50208C...Local variables
50209 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
50210 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
50211 INTEGER KFIN,KCIN
50212 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50213 &XMZ,XMZ2,AXMJ,AXMI
50214 DOUBLE PRECISION S12MIN,S12MAX
50215 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
50216 DOUBLE PRECISION PYLAMF,XL
50217 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
50218 DOUBLE PRECISION PYX2XH,PYX2XG
50219 DOUBLE PRECISION XLAM(0:400)
50220 INTEGER IDLAM(400,3)
50221 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
50222 INTEGER ITH(3)
50223 INTEGER ITHC
50224 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
50225 DOUBLE PRECISION SR2
50226 DOUBLE PRECISION CBETA,SBETA,TANB
50227
50228 DOUBLE PRECISION PYALEM,PI,PYALPS
50229 DOUBLE PRECISION FCOL
50230 INTEGER KF1,KF2,ISF
50231 INTEGER KFNCHI(4),KFCCHI(2)
50232
50233 DOUBLE PRECISION TEMP
50234 EXTERNAL PYGAUS,PYXXZ6
50235 DOUBLE PRECISION PYGAUS,PYXXZ6
50236 DOUBLE PRECISION PREC
50237 DATA ITH/25,35,36/
50238 DATA ITHC/37/
50239 DATA ETAH/1D0,1D0,-1D0/
50240 DATA SR2/1.4142136D0/
50241 DATA PI/3.141592654D0/
50242 DATA PREC/1D-2/
50243 DATA KFNCHI/1000022,1000023,1000025,1000035/
50244 DATA KFCCHI/1000024,1000037/
50245
50246C...COUNT THE NUMBER OF DECAY MODES
50247 LKNT=0
50248 XMW=PMAS(24,1)
50249 XMW2=XMW**2
50250 XMZ=PMAS(23,1)
50251 XMZ2=XMZ**2
50252 XW=1D0-XMW2/XMZ2
50253 XW1=1D0-XW
50254 TANW = SQRT(XW/XW1)
50255
50256C...1 OR 2 DEPENDING ON CHARGINO TYPE
50257 IX=1
50258 IF(KFIN.EQ.KFCCHI(2)) IX=2
50259 KCIN=PYCOMP(KFIN)
50260
50261 XMI=SMW(IX)
50262 XMI2=XMI**2
50263 AXMI=ABS(XMI)
50264 AEM=PYALEM(XMI2)
50265 AS =PYALPS(XMI2)
50266 C1=AEM/XW
50267 XMI3=ABS(XMI**3)
50268 TANB=RMSS(5)
50269 BETA=ATAN(TANB)
50270 CBETA=COS(BETA)
50271 SBETA=TANB*CBETA
50272 ALFA=RMSS(18)
50273
50274 DO 110 I=1,2
50275 DO 100 J=1,2
50276 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50277 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50278 100 CONTINUE
50279 110 CONTINUE
50280
50281C...GRAVITINO DECAY MODES
50282
50283 IF(IMSS(11).EQ.1) THEN
50284 XMP=RMSS(29)
50285 IDG=39+KSUSY1
50286 XMGR=PMAS(PYCOMP(IDG),1)
50287C SINW=SQRT(XW)
50288C COSW=SQRT(1D0-XW)
50289 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50290 IF(AXMI.GT.XMGR+XMW) THEN
50291 LKNT=LKNT+1
50292 IDLAM(LKNT,1)=IDG
50293 IDLAM(LKNT,2)=24
50294 IDLAM(LKNT,3)=0
50295 XLAM(LKNT)=XFAC*(
50296 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
50297 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
50298 & (1D0-XMW2/XMI2)**4
50299 ENDIF
50300 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
50301 LKNT=LKNT+1
50302 IDLAM(LKNT,1)=IDG
50303 IDLAM(LKNT,2)=37
50304 IDLAM(LKNT,3)=0
50305 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
50306 & (ABS(UMIXC(IX,2))*SBETA)**2))
50307 & *(1D0-PMAS(37,1)**2/XMI2)**4
50308 ENDIF
50309 ENDIF
50310
50311C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50312 IF(IX.EQ.1) GOTO 170
50313 XMJ=SMW(1)
50314 AXMJ=ABS(XMJ)
50315 XMJ2=XMJ**2
50316
50317C...CHI_2+ -> CHI_1+ + Z0
50318 IF(AXMI.GE.AXMJ+XMZ) THEN
50319 LKNT=LKNT+1
50320 IJ=1
50321 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
50322 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
50323 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
50324 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
50325 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50326 GLR=DBLE(OLPP*DCONJG(ORPP))
50327 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50328 IDLAM(LKNT,1)=KFCCHI(1)
50329 IDLAM(LKNT,2)=23
50330 IDLAM(LKNT,3)=0
50331
50332C...CHARGED LEPTONS
50333 ELSEIF(AXMI.GE.AXMJ) THEN
50334 S12MIN=0D0
50335 S12MAX=(AXMI-AXMJ)**2
50336 IA=11
50337 JA=12
50338 EI=KCHG(IABS(IA),1)/3D0
50339 T3I=SIGN(1D0,EI+1D-6)/2D0
50340 XXC(1)=0D0
50341 XXC(2)=XMJ
50342 XXC(3)=0D0
50343 XXC(4)=XMI
50344 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50345 XXC(6)=1D6
50346 XXC(9)=PMAS(23,1)
50347 XXC(10)=PMAS(23,2)
50348 IJ=1
50349 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
50350 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
50351 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
50352 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
50353 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50354 CXC(2)=DCMPLX(0D0,0D0)
50355 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50356 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
50357 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50358 CXC(6)=DCMPLX(0D0,0D0)
50359 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50360 CXC(8)=DCMPLX(0D0,0D0)
50361 IF( XXC(5).LT.AXMI ) THEN
50362 XXC(5)=1D6
50363 ENDIF
50364 XXC(7)=XXC(5)
50365 XXC(8)=XXC(6)
50366 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50367 LKNT=LKNT+1
50368 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50369 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50370 IDLAM(LKNT,1)=KFCCHI(1)
50371 IDLAM(LKNT,2)=11
50372 IDLAM(LKNT,3)=-11
50373 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50374 LKNT=LKNT+1
50375 XLAM(LKNT)=XLAM(LKNT-1)
50376 IDLAM(LKNT,1)=KFCCHI(1)
50377 IDLAM(LKNT,2)=13
50378 IDLAM(LKNT,3)=-13
50379 ENDIF
50380 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50381 LKNT=LKNT+1
50382 XLAM(LKNT)=XLAM(LKNT-1)
50383 IDLAM(LKNT,1)=KFCCHI(1)
50384 IDLAM(LKNT,2)=15
50385 IDLAM(LKNT,3)=-15
50386 ENDIF
50387 ENDIF
50388
50389C...NEUTRINOS
50390 120 CONTINUE
50391 IA=12
50392 JA=11
50393 EI=KCHG(IABS(IA),1)/3D0
50394 T3I=SIGN(1D0,EI+1D-6)/2D0
50395 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50396 XXC(6)=1D6
50397 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50398 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50399 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
50400 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50401 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50402 IF( XXC(5).LT.AXMI ) THEN
50403 XXC(5)=1D6
50404 ENDIF
50405 XXC(7)=XXC(5)
50406 XXC(8)=XXC(6)
50407 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
50408 LKNT=LKNT+1
50409 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50410 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50411 IDLAM(LKNT,1)=KFCCHI(1)
50412 IDLAM(LKNT,2)=12
50413 IDLAM(LKNT,3)=-12
50414 LKNT=LKNT+1
50415 XLAM(LKNT)=XLAM(LKNT-1)
50416 IDLAM(LKNT,1)=KFCCHI(1)
50417 IDLAM(LKNT,2)=14
50418 IDLAM(LKNT,3)=-14
50419 ENDIF
50420 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
50421 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50422 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50423 ELSE
50424 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50425 ENDIF
50426 IF( XXC(5).LT.AXMI ) THEN
50427 XXC(5)=1D6
50428 ENDIF
50429 XXC(7)=XXC(5)
50430 LKNT=LKNT+1
50431 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50432 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50433 IDLAM(LKNT,1)=KFCCHI(1)
50434 IDLAM(LKNT,2)=16
50435 IDLAM(LKNT,3)=-16
50436 ENDIF
50437
50438C...D-TYPE QUARKS
50439 130 CONTINUE
50440 IA=1
50441 JA=2
50442 EI=KCHG(IABS(IA),1)/3D0
50443 T3I=SIGN(1D0,EI+1D-6)/2D0
50444 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50445 XXC(6)=1D6
50446 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50447 CXC(2)=DCMPLX(0D0,0D0)
50448 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50449 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
50450 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50451 CXC(6)=DCMPLX(0D0,0D0)
50452 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50453 CXC(8)=DCMPLX(0D0,0D0)
50454 IF( XXC(5).LT.AXMI ) THEN
50455 XXC(5)=1D6
50456 ENDIF
50457 XXC(7)=XXC(5)
50458 XXC(8)=XXC(6)
50459 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50460 LKNT=LKNT+1
50461 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50462 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50463 IDLAM(LKNT,1)=KFCCHI(1)
50464 IDLAM(LKNT,2)=1
50465 IDLAM(LKNT,3)=-1
50466 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50467 LKNT=LKNT+1
50468 XLAM(LKNT)=XLAM(LKNT-1)
50469 IDLAM(LKNT,1)=KFCCHI(1)
50470 IDLAM(LKNT,2)=3
50471 IDLAM(LKNT,3)=-3
50472 ENDIF
50473 ENDIF
50474 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50475 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50476 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50477 ELSE
50478 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50479 ENDIF
50480 IF( XXC(5).LT.AXMI ) THEN
50481 XXC(5)=1D6
50482 ENDIF
50483 XXC(7)=XXC(5)
50484 LKNT=LKNT+1
50485 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50486 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50487 IDLAM(LKNT,1)=KFCCHI(1)
50488 IDLAM(LKNT,2)=5
50489 IDLAM(LKNT,3)=-5
50490 ENDIF
50491
50492C...U-TYPE QUARKS
50493 140 CONTINUE
50494 IA=2
50495 JA=1
50496 EI=KCHG(IABS(IA),1)/3D0
50497 T3I=SIGN(1D0,EI+1D-6)/2D0
50498 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50499 XXC(6)=1D6
50500 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
50501 CXC(2)=DCMPLX(0D0,0D0)
50502 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
50503 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
50504 CXC(5)=-DCMPLX(EI/XW1)*ORPP
50505 CXC(6)=DCMPLX(0D0,0D0)
50506 CXC(7)=-DCMPLX(EI/XW1)*OLPP
50507 CXC(8)=DCMPLX(0D0,0D0)
50508 IF( XXC(5).LT.AXMI ) THEN
50509 XXC(5)=1D6
50510 ENDIF
50511 XXC(7)=XXC(5)
50512 XXC(8)=XXC(6)
50513 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50514 LKNT=LKNT+1
50515 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50516 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50517 IDLAM(LKNT,1)=KFCCHI(1)
50518 IDLAM(LKNT,2)=2
50519 IDLAM(LKNT,3)=-2
50520 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50521 LKNT=LKNT+1
50522 XLAM(LKNT)=XLAM(LKNT-1)
50523 IDLAM(LKNT,1)=KFCCHI(1)
50524 IDLAM(LKNT,2)=4
50525 IDLAM(LKNT,3)=-4
50526 ENDIF
50527 ENDIF
50528 150 CONTINUE
50529 ENDIF
50530
50531C...CHI_2+ -> CHI_1+ + H0_K
50532 EH(2)=COS(ALFA)
50533 EH(1)=SIN(ALFA)
50534 EH(3)=-SBETA
50535 DH(2)=-SIN(ALFA)
50536 DH(1)=COS(ALFA)
50537 DH(3)=COS(BETA)
50538 DO 160 IH=1,3
50539 XMH=PMAS(ITH(IH),1)
50540 XMH2=XMH**2
50541C...NO 3-BODY OPTION
50542 IF(AXMI.GE.AXMJ+XMH) THEN
50543 LKNT=LKNT+1
50544 XL=PYLAMF(XMI2,XMJ2,XMH2)
50545 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
50546 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
50547 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
50548 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
50549 XMK=XMJ*ETAH(IH)
50550 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50551 GLR=DBLE(OLPP*DCONJG(ORPP))
50552 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50553 IDLAM(LKNT,1)=KFCCHI(1)
50554 IDLAM(LKNT,2)=ITH(IH)
50555 IDLAM(LKNT,3)=0
50556 ENDIF
50557 160 CONTINUE
50558
50559C...CHI1 JUMPS TO HERE
50560 170 CONTINUE
50561
50562C...CHI+_I -> CHI0_J + W+
50563 DO 220 IJ=1,4
50564 XMJ=SMZ(IJ)
50565 AXMJ=ABS(XMJ)
50566 XMJ2=XMJ**2
50567 IF(AXMI.GE.AXMJ+XMW) THEN
50568 LKNT=LKNT+1
50569 DO 180 I=1,4
50570 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
50571 180 CONTINUE
50572 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
50573 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
50574 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
50575 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
50576 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50577 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50578 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50579 IDLAM(LKNT,1)=KFNCHI(IJ)
50580 IDLAM(LKNT,2)=24
50581 IDLAM(LKNT,3)=0
50582C...LEPTONS
50583 ELSEIF(AXMI.GE.AXMJ) THEN
50584 S12MIN=0D0
50585 S12MAX=(AXMI-AXMJ)**2
50586 DO 190 I=1,4
50587 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
50588 190 CONTINUE
50589 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
50590 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
50591 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
50592 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
50593 CXC(5)=DCMPLX(0D0,0D0)
50594 CXC(7)=DCMPLX(0D0,0D0)
50595 IA=11
50596 JA=12
50597 EI=KCHG(IA,1)/3D0
50598 T3I=SIGN(1D0,EI+1D-6)/2D0
50599 EJ=KCHG(JA,1)/3D0
50600 T3J=SIGN(1D0,EJ+1D-6)/2D0
50601 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
50602 & TANW+ZMIXC(IJ,2)*T3J)/SR2
50603 CXC(4)=-DCONJG(UMIXC(IX,1))*(
50604 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
50605 CXC(6)=DCMPLX(0D0,0D0)
50606 CXC(8)=DCMPLX(0D0,0D0)
50607 XXC(1)=0D0
50608 XXC(2)=XMJ
50609 XXC(3)=0D0
50610 XXC(4)=XMI
50611 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50612 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50613 XXC(9)=PMAS(24,1)
50614 XXC(10)=PMAS(24,2)
50615CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50616 IF(XXC(5).LT.AXMI) THEN
50617 XXC(5)=1D6
50618 ELSEIF(XXC(6).LT.AXMI) THEN
50619 XXC(6)=1D6
50620 ENDIF
50621 XXC(7)=XXC(6)
50622 XXC(8)=XXC(5)
50623C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
50624C...--> 1/(16PI)/M**3*(AEM/XW)**2
50625 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50626 LKNT=LKNT+1
50627 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50628 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
50629 IDLAM(LKNT,1)=KFNCHI(IJ)
50630 IDLAM(LKNT,2)=-11
50631 IDLAM(LKNT,3)=12
50632C...ONLY DECAY CHI+1 -> E+ NU_E
50633 IF( IMSS(12).NE. 0 ) GOTO 260
50634 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50635 LKNT=LKNT+1
50636 XLAM(LKNT)=XLAM(LKNT-1)
50637 IDLAM(LKNT,1)=KFNCHI(IJ)
50638 IDLAM(LKNT,2)=-13
50639 IDLAM(LKNT,3)=14
50640 ENDIF
50641 ENDIF
50642 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
50643 LKNT=LKNT+1
50644 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50645 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50646 ELSE
50647 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50648 ENDIF
50649 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50650 IF(XXC(5).LT.AXMI) THEN
50651 XXC(5)=1D6
50652 ELSEIF(XXC(6).LT.AXMI) THEN
50653 XXC(6)=1D6
50654 ENDIF
50655 XXC(7)=XXC(6)
50656 XXC(8)=XXC(5)
50657 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50658 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
50659 IDLAM(LKNT,1)=KFNCHI(IJ)
50660 IDLAM(LKNT,2)=-15
50661 IDLAM(LKNT,3)=16
50662 ENDIF
50663
50664C...NOW, DO THE QUARKS
50665 200 CONTINUE
50666 IA=1
50667 JA=2
50668 EI=KCHG(IA,1)/3D0
50669 T3I=SIGN(1D0,EI+1D-6)/2D0
50670 EJ=KCHG(JA,1)/3D0
50671 T3J=SIGN(1D0,EJ+1D-6)/2D0
50672 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
50673 & TANW+ZMIXC(IJ,2)*T3J)
50674 CXC(4)=-DCONJG(UMIXC(IX,1))*(
50675 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
50676 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50677 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50678 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
50679 IF(XXC(5).LT.AXMI) THEN
50680 XXC(5)=1D6
50681 ENDIF
50682 IF(XXC(6).LT.AXMI) THEN
50683 XXC(6)=1D6
50684 ENDIF
50685 XXC(7)=XXC(6)
50686 XXC(8)=XXC(5)
50687 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50688 LKNT=LKNT+1
50689 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
50690 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50691 IDLAM(LKNT,1)=KFNCHI(IJ)
50692 IDLAM(LKNT,2)=-1
50693 IDLAM(LKNT,3)=2
50694 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50695 LKNT=LKNT+1
50696 XLAM(LKNT)=XLAM(LKNT-1)
50697 IDLAM(LKNT,1)=KFNCHI(IJ)
50698 IDLAM(LKNT,2)=-3
50699 IDLAM(LKNT,3)=4
50700 ENDIF
50701 ENDIF
50702 210 CONTINUE
50703 ENDIF
50704 220 CONTINUE
50705
50706C...CHI+_I -> CHI0_J + H+
50707 DO 230 IJ=1,4
50708 XMJ=SMZ(IJ)
50709 AXMJ=ABS(XMJ)
50710 XMJ2=XMJ**2
50711 XMHP=PMAS(ITHC,1)
50712 IF(AXMI.GE.AXMJ+XMHP) THEN
50713 LKNT=LKNT+1
50714 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
50715 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
50716 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
50717 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
50718 & UMIXC(IX,2)/SR2)
50719 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50720 GLR=DBLE(OLPP*DCONJG(ORPP))
50721 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
50722 IDLAM(LKNT,1)=KFNCHI(IJ)
50723 IDLAM(LKNT,2)=ITHC
50724 IDLAM(LKNT,3)=0
50725 ELSE
50726
50727 ENDIF
50728 230 CONTINUE
50729
50730C...2-BODY DECAYS TO FERMION SFERMION
50731 DO 240 J=1,16
50732 IF(J.GE.7.AND.J.LE.10) GOTO 240
50733 IF(MOD(J,2).EQ.0) THEN
50734 KF1=KSUSY1+J-1
50735 ELSE
50736 KF1=KSUSY1+J+1
50737 ENDIF
50738 KF2=KF1+KSUSY1
50739 XMSF1=PMAS(PYCOMP(KF1),1)
50740 XMSF2=PMAS(PYCOMP(KF2),1)
50741 XMF=PMAS(J,1)
50742 IF(J.LE.6) THEN
50743 FCOL=3D0
50744 ELSE
50745 FCOL=1D0
50746 ENDIF
50747
50748C...U~ D_L
50749 IF(MOD(J,2).EQ.0) THEN
50750 XMFP=PMAS(J-1,1)
50751 CAL=UMIXC(IX,1)
50752 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
50753 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
50754 CBR=0D0
50755 ISF=J-1
50756 ELSE
50757 XMFP=PMAS(J+1,1)
50758 CAL=VMIXC(IX,1)
50759 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
50760 CBR=0D0
50761 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
50762 ISF=J+1
50763 ENDIF
50764
50765C...~U_L D
50766 IF(AXMI.GE.XMF+XMSF1) THEN
50767 LKNT=LKNT+1
50768 XMA2=XMSF1**2
50769 XMB2=XMF**2
50770 XL=PYLAMF(XMI2,XMA2,XMB2)
50771 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
50772 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
50773 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50774 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50775 IDLAM(LKNT,3)=0
50776 IF(MOD(J,2).EQ.0) THEN
50777 IDLAM(LKNT,1)=-KF1
50778 IDLAM(LKNT,2)=J
50779 ELSE
50780 IDLAM(LKNT,1)=KF1
50781 IDLAM(LKNT,2)=-J
50782 ENDIF
50783 ENDIF
50784
50785C...U~ D_R
50786 IF(AXMI.GE.XMF+XMSF2) THEN
50787 LKNT=LKNT+1
50788 XMA2=XMSF2**2
50789 XMB2=XMF**2
50790 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
50791 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
50792 XL=PYLAMF(XMI2,XMA2,XMB2)
50793 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
50794 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
50795 IDLAM(LKNT,3)=0
50796 IF(MOD(J,2).EQ.0) THEN
50797 IDLAM(LKNT,1)=-KF2
50798 IDLAM(LKNT,2)=J
50799 ELSE
50800 IDLAM(LKNT,1)=KF2
50801 IDLAM(LKNT,2)=-J
50802 ENDIF
50803 ENDIF
50804 240 CONTINUE
50805
50806C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
50807C...A 2-BODY -- 2-BODY CHAIN
50808 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50809 IF(AXMI.GE.XMJ) THEN
50810 AXMJ=ABS(XMJ)
50811 S12MIN=0D0
50812 S12MAX=(AXMI-AXMJ)**2
50813 XXC(1)=0D0
50814 XXC(2)=XMJ
50815 XXC(3)=0D0
50816 XXC(4)=XMI
50817 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50818 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50819 XXC(9)=1D6
50820 XXC(10)=0D0
50821 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50822 ORPP=DCONJG(OLPP)
50823 CXC(1)=DCMPLX(0D0,0D0)
50824 CXC(3)=DCMPLX(0D0,0D0)
50825 CXC(5)=DCMPLX(0D0,0D0)
50826 CXC(7)=DCMPLX(0D0,0D0)
50827 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50828 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50829 CXC(6)=DCMPLX(0D0,0D0)
50830 CXC(8)=DCMPLX(0D0,0D0)
50831 IF(XXC(5).LT.AXMI) THEN
50832 XXC(5)=1D6
50833 ELSEIF(XXC(6).LT.AXMI) THEN
50834 XXC(6)=1D6
50835 ENDIF
50836 XXC(7)=XXC(6)
50837 XXC(8)=XXC(5)
50838 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
50839 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50840 LKNT=LKNT+1
50841 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
50842 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50843 IDLAM(LKNT,1)=KSUSY1+21
50844 IDLAM(LKNT,2)=-1
50845 IDLAM(LKNT,3)=2
50846 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50847 LKNT=LKNT+1
50848 XLAM(LKNT)=XLAM(LKNT-1)
50849 IDLAM(LKNT,1)=KSUSY1+21
50850 IDLAM(LKNT,2)=-3
50851 IDLAM(LKNT,3)=4
50852 ENDIF
50853 ENDIF
50854 250 CONTINUE
50855 ENDIF
50856
50857C...R-violating decay modes (SKANDS).
50858 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
50859
50860 260 IKNT=LKNT
50861 XLAM(0)=0D0
50862 DO 270 I=1,IKNT
50863 XLAM(0)=XLAM(0)+XLAM(I)
50864 IF(XLAM(I).LT.0D0) THEN
50865 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
50866 & (IDLAM(I,J),J=1,3)
50867 XLAM(I)=0D0
50868 ENDIF
50869 270 CONTINUE
50870 IF(XLAM(0).EQ.0D0) THEN
50871 XLAM(0)=1D-6
50872 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
50873 WRITE(MSTU(11),*) LKNT
50874 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
50875 ENDIF
50876
50877 RETURN
50878 END
50879
50880C*********************************************************************
50881
50882C...PYXXZ6
50883C...Used in the calculation of inoi -> inoj + f + ~f.
50884
50885 FUNCTION PYXXZ6(X)
50886
50887C...Double precision and integer declarations.
50888 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50889 IMPLICIT INTEGER(I-N)
50890 INTEGER PYK,PYCHGE,PYCOMP
50891C...Parameter statement to help give large particle numbers.
50892 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50893 &KEXCIT=4000000,KDIMEN=5000000)
50894C...Commonblocks.
50895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50896C COMMON/PYINTS/XXM(20)
50897 COMPLEX*16 CXC
50898 COMMON/PYINTC/XXC(10),CXC(8)
50899 SAVE /PYDAT1/,/PYINTC/
50900
50901C...Local variables.
50902 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
50903 DOUBLE PRECISION PYXXZ6,X
50904 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
50905 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
50906 DOUBLE PRECISION SIJ
50907 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
50908 DOUBLE PRECISION OL2
50909 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
50910 INTEGER I
50911
50912C...Statement functions.
50913C...Integral from x to y of (t-a)(b-t) dt.
50914 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
50915C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
50916 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
50917 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
50918C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
50919 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
50920 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
50921C...Integral from x to y of (t-a)/(b-t) dt.
50922 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
50923C...Integral from x to y of 1/(t-a) dt.
50924 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
50925
50926 XM12=XXC(1)**2
50927 XM22=XXC(2)**2
50928 XM32=XXC(3)**2
50929 S=XXC(4)**2
50930 S13=X
50931
50932 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
50933 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
50934 &( (X-XM22-S)**2 -4D0*XM22*S ) )
50935
50936 S23MIN=(S23AVE-S23DEL)
50937 S23MAX=(S23AVE+S23DEL)
50938
50939 XMSD1=XXC(5)**2
50940 XMSD2=XXC(7)**2
50941 XMSU1=XXC(6)**2
50942 XMSU2=XXC(8)**2
50943
50944 XMV=XXC(9)
50945 XMG=XXC(10)
50946 QLLS=CXC(1)
50947 QLLU=CXC(2)
50948 QLRS=CXC(3)
50949 QLRT=CXC(4)
50950 QRLS=CXC(5)
50951 QRLT=CXC(6)
50952 QRRS=CXC(7)
50953 QRRU=CXC(8)
50954 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
50955 SIJ=2D0*XXC(2)*XXC(4)*S13
50956 IF(XMV.LE.1000D0) THEN
50957 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
50958 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
50959 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
50960 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
50961 IF(XXC(5).LE.10000D0) THEN
50962 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
50963 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
50964 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
50965 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
50966 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
50967 & *(S13-XMV**2)/WPROP2
50968 ELSE
50969 WFL1=0D0
50970 ENDIF
50971
50972 IF(XXC(6).LE.10000D0) THEN
50973 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
50974 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
50975 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
50976 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
50977 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
50978 & *(S13-XMV**2)/WPROP2
50979 ELSE
50980 WFL2=0D0
50981 ENDIF
50982 ELSE
50983 WW=0D0
50984 WFL1=0D0
50985 WFL2=0D0
50986 ENDIF
50987 IF(XXC(5).LE.10000D0) THEN
50988 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
50989 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
50990 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
50991 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
50992 ELSE
50993 WF1=0D0
50994 ENDIF
50995 IF(XXC(6).LE.10000D0) THEN
50996 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
50997 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
50998 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
50999 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
51000 ELSE
51001 WF2=0D0
51002 ENDIF
51003
51004 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
51005
51006 IF(PYXXZ6.LT.0D0) THEN
51007 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
51008 WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4)
51009 WRITE(MSTU(11),*) (XXc(I),I=5,8)
51010 WRITE(MSTU(11),*) (XXc(I),I=9,12)
51011 WRITE(MSTU(11),*) (XXc(I),I=13,16)
51012 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
51013 WRITE(MSTU(11),*) S23MIN,S23MAX
51014 PYXXZ6=0D0
51015 ENDIF
51016
51017 RETURN
51018 END
51019
51020
51021C*********************************************************************
51022
51023C...PYXXGA
51024C...Calculates chi0_i -> chi0_j + gamma.
51025
51026 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
51027
51028C...Double precision and integer declarations.
51029 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51030 IMPLICIT INTEGER(I-N)
51031 INTEGER PYK,PYCHGE,PYCOMP
51032
51033C...Local variables.
51034 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
51035 DOUBLE PRECISION F1,F2
51036
51037 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
51038 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
51039 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
51040 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
51041
51042 RETURN
51043 END
51044
51045C*********************************************************************
51046
51047C...PYX2XG
51048C...Calculates the decay rate for ino -> ino + gauge boson.
51049
51050 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
51051
51052C...Double precision and integer declarations.
51053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51054 IMPLICIT INTEGER(I-N)
51055 INTEGER PYK,PYCHGE,PYCOMP
51056
51057C...Local variables.
51058 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
51059 DOUBLE PRECISION XL,PYLAMF,C1
51060 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
51061
51062 XMI2=XM1**2
51063 XMI3=ABS(XM1**3)
51064 XMJ2=XM2**2
51065 XMV2=XM3**2
51066 XL=PYLAMF(XMI2,XMJ2,XMV2)
51067 PYX2XG=C1/8D0/XMI3*SQRT(XL)
51068 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
51069 &12D0*GLR*XM1*XM2*XMV2)
51070
51071 RETURN
51072 END
51073
51074C*********************************************************************
51075
51076C...PYX2XH
51077C...Calculates the decay rate for ino -> ino + H.
51078
51079 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
51080
51081C...Double precision and integer declarations.
51082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51083 IMPLICIT INTEGER(I-N)
51084 INTEGER PYK,PYCHGE,PYCOMP
51085
51086C...Local variables.
51087 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
51088 DOUBLE PRECISION XL,PYLAMF,C1
51089 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
51090
51091 XMI2=XM1**2
51092 XMI3=ABS(XM1**3)
51093 XMJ2=XM2**2
51094 XMV2=XM3**2
51095 XL=PYLAMF(XMI2,XMJ2,XMV2)
51096 PYX2XH=C1/8D0/XMI3*SQRT(XL)
51097 &*(GX2*(XMI2+XMJ2-XMV2)+
51098 &4D0*GLR*XM1*XM2)
51099
51100 RETURN
51101 END
51102
51103C*********************************************************************
51104
51105C...PYHEXT
51106C...Calculates the non-standard decay modes of the Higgs boson.
51107C...
51108C...Author: Stephen Mrenna
51109C...Last Update: April 2001
51110C......Allow complex values for Z,U, and V
51111
51112 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
51113
51114C...Double precision and integer declarations.
51115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51116 IMPLICIT INTEGER(I-N)
51117 INTEGER PYK,PYCHGE,PYCOMP
51118C...Parameter statement to help give large particle numbers.
51119 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51120 &KEXCIT=4000000,KDIMEN=5000000)
51121C...Commonblocks.
51122 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51123 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51125 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51126 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51127 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51128 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
51129
51130C...Local variables.
51131 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51132 COMPLEX*16 QIJ,RIJ,F21K,F12K
51133 INTEGER KFIN
51134 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
51135 DOUBLE PRECISION XMI2,XMI3,XMJ2
51136 DOUBLE PRECISION PYLAMF,XL,CF,EI
51137 INTEGER IDU,IFL
51138 DOUBLE PRECISION TANW,XW,AEM,C1,AS
51139 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
51140 DOUBLE PRECISION XLAM(0:400)
51141 INTEGER IDLAM(400,3)
51142 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
51143 INTEGER ITH(4)
51144 INTEGER KFNCHI(4),KFCCHI(2)
51145 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
51146 DOUBLE PRECISION SR2
51147 DOUBLE PRECISION BETA,ALFA
51148 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
51149 DOUBLE PRECISION PYALEM
51150 DOUBLE PRECISION AL,AR,ALR
51151 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
51152 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
51153 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
51154 DATA ITH/25,35,36,37/
51155 DATA ETAH/1D0,1D0,-1D0/
51156 DATA SR2/1.4142136D0/
51157 DATA KFNCHI/1000022,1000023,1000025,1000035/
51158 DATA KFCCHI/1000024,1000037/
51159
51160C...COUNT THE NUMBER OF DECAY MODES
51161 LKNT=IKNT
51162
51163 XMW=PMAS(24,1)
51164 XMW2=XMW**2
51165 XMZ=PMAS(23,1)
51166 XW=PARU(102)
51167 TANW = SQRT(XW/(1D0-XW))
51168 CW=SQRT(1D0-XW)
51169
51170C...1 - 4 DEPENDING ON Higgs species.
51171 IH=1
51172 IF(KFIN.EQ.ITH(2)) IH=2
51173 IF(KFIN.EQ.ITH(3)) IH=3
51174 IF(KFIN.EQ.ITH(4)) IH=4
51175
51176 XMI=PMAS(KFIN,1)
51177 XMI2=XMI**2
51178 AXMI=ABS(XMI)
51179 AEM=PYALEM(XMI2)
51180 C1=AEM/XW
51181 XMI3=ABS(XMI**3)
51182
51183 TANB=RMSS(5)
51184 BETA=ATAN(TANB)
51185 CBETA=COS(BETA)
51186 SBETA=TANB*CBETA
51187 ALFA=RMSS(18)
51188 COSA=COS(ALFA)
51189 SINA=SIN(ALFA)
51190 ATRIT=RMSS(16)
51191 ATRIB=RMSS(15)
51192 ATRIL=RMSS(17)
51193 XMUZ=-RMSS(4)
51194
51195 DO 110 I=1,4
51196 DO 100 J=1,4
51197 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51198 100 CONTINUE
51199 110 CONTINUE
51200 DO 130 I=1,2
51201 DO 120 J=1,2
51202 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51203 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51204 120 CONTINUE
51205 130 CONTINUE
51206
51207
51208 IF(IH.EQ.4) GOTO 220
51209
51210C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51211C...H0_K -> CHI0_I + CHI0_J
51212 EH(2)=SINA
51213 EH(1)=COSA
51214 EH(3)=CBETA
51215 DH(2)=COSA
51216 DH(1)=-SINA
51217 DH(3)=SBETA
51218 DO 150 IJ=1,4
51219 XMJ=SMZ(IJ)
51220 AXMJ=ABS(XMJ)
51221 DO 140 IK=1,IJ
51222 XMK=SMZ(IK)
51223 AXMK=ABS(XMK)
51224 IF(AXMI.GE.AXMJ+AXMK) THEN
51225 LKNT=LKNT+1
51226 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
51227 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
51228 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
51229 & ZMIXC(IJ,3)*ZMIXC(IK,1))
51230 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
51231 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
51232 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
51233 & ZMIXC(IJ,4)*ZMIXC(IK,1))
51234 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
51235 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
51236C...SIGN OF MASSES I,J
51237 XML=XMK*ETAH(IH)
51238 GX2=ABS(F12K)**2+ABS(F21K)**2
51239 GLR=DBLE(F12K*DCONJG(F21K))
51240 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
51241 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
51242 IDLAM(LKNT,1)=KFNCHI(IJ)
51243 IDLAM(LKNT,2)=KFNCHI(IK)
51244 IDLAM(LKNT,3)=0
51245 ENDIF
51246 140 CONTINUE
51247 150 CONTINUE
51248
51249C...H0_K -> CHI+_I CHI-_J
51250 DO 170 IJ=1,2
51251 XMJ=SMW(IJ)
51252 AXMJ=ABS(XMJ)
51253 DO 160 IK=1,2
51254 XMK=SMW(IK)
51255 AXMK=ABS(XMK)
51256 IF(AXMI.GE.AXMJ+AXMK) THEN
51257 LKNT=LKNT+1
51258 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
51259 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
51260 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
51261 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
51262 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51263 GLR=DBLE(OLPP*DCONJG(ORPP))
51264 XML=XMK*ETAH(IH)
51265 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
51266 IDLAM(LKNT,1)=KFCCHI(IJ)
51267 IDLAM(LKNT,2)=-KFCCHI(IK)
51268 IDLAM(LKNT,3)=0
51269 ENDIF
51270 160 CONTINUE
51271 170 CONTINUE
51272
51273C...HIGGS TO SFERMION SFERMION
51274 DO 200 IFL=1,16
51275 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
51276 IJ=KSUSY1+IFL
51277 XMJL=PMAS(PYCOMP(IJ),1)
51278 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
51279 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
51280 XMJ=XMJL
51281 XMJ2=XMJ**2
51282 XL=PYLAMF(XMI2,XMJ2,XMJ2)
51283 XMF=PMAS(IFL,1)
51284 EI=KCHG(IFL,1)/3D0
51285 IDU=2-MOD(IFL,2)
51286
51287 IF(IH.EQ.1) THEN
51288 IF(IDU.EQ.1) THEN
51289 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
51290 & XMF**2/XMW*SINA/CBETA
51291 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
51292 & XMF**2/XMW*SINA/CBETA
51293 IF(IFL.EQ.5) THEN
51294 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
51295 & ATRIB*SINA)
51296 ELSEIF(IFL.EQ.15) THEN
51297 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
51298 & ATRIL*SINA)
51299 ELSE
51300 GHLR=0D0
51301 ENDIF
51302 ELSE
51303 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
51304 & XMF**2/XMW*COSA/SBETA
51305 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
51306 & XMF**2/XMW*COSA/SBETA
51307 IF(IFL.EQ.6) THEN
51308 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
51309 & ATRIT*COSA)
51310 ELSE
51311 GHLR=0D0
51312 ENDIF
51313 ENDIF
51314
51315 ELSEIF(IH.EQ.2) THEN
51316 IF(IDU.EQ.1) THEN
51317 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
51318 & XMF**2/XMW*COSA/CBETA
51319 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
51320 & XMF**2/XMW*COSA/CBETA
51321 IF(IFL.EQ.5) THEN
51322 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
51323 & ATRIB*COSA)
51324 ELSEIF(IFL.EQ.15) THEN
51325 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
51326 & ATRIL*COSA)
51327 ELSE
51328 GHLR=0D0
51329 ENDIF
51330 ELSE
51331 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
51332 & XMF**2/XMW*SINA/SBETA
51333 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
51334 & XMF**2/XMW*SINA/SBETA
51335 IF(IFL.EQ.6) THEN
51336 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
51337 & ATRIT*SINA)
51338 ELSE
51339 GHLR=0D0
51340 ENDIF
51341 ENDIF
51342
51343 ELSEIF(IH.EQ.3) THEN
51344 GHLL=0D0
51345 GHRR=0D0
51346 GHLR=0D0
51347 IF(IDU.EQ.1) THEN
51348 IF(IFL.EQ.5) THEN
51349 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
51350 ELSEIF(IFL.EQ.15) THEN
51351 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
51352 ENDIF
51353 ELSE
51354 IF(IFL.EQ.6) THEN
51355 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
51356 ENDIF
51357 ENDIF
51358 ENDIF
51359 IF(IH.EQ.3) GOTO 180
51360
51361 AL=SFMIX(IFL,1)**2
51362 AR=SFMIX(IFL,2)**2
51363 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
51364 IF(IFL.LE.6) THEN
51365 CF=3D0
51366 ELSE
51367 CF=1D0
51368 ENDIF
51369
51370 IF(AXMI.GE.2D0*XMJ) THEN
51371 LKNT=LKNT+1
51372 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51373 & (GHLL*AL+GHRR*AR
51374 & +2D0*GHLR*ALR)**2
51375 IDLAM(LKNT,1)=IJ
51376 IDLAM(LKNT,2)=-IJ
51377 IDLAM(LKNT,3)=0
51378 ENDIF
51379
51380 IF(AXMI.GE.2D0*XMJR) THEN
51381 LKNT=LKNT+1
51382 AL=SFMIX(IFL,3)**2
51383 AR=SFMIX(IFL,4)**2
51384 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
51385 XMJ=XMJR
51386 XMJ2=XMJ**2
51387 XL=PYLAMF(XMI2,XMJ2,XMJ2)
51388 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51389 & (GHLL*AL+GHRR*AR
51390 & +2D0*GHLR*ALR)**2
51391 IDLAM(LKNT,1)=IJ+KSUSY1
51392 IDLAM(LKNT,2)=-(IJ+KSUSY1)
51393 IDLAM(LKNT,3)=0
51394 ENDIF
51395 180 CONTINUE
51396
51397 IF(AXMI.GE.XMJL+XMJR) THEN
51398 LKNT=LKNT+1
51399 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
51400 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
51401 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
51402 XMJ=XMJR
51403 XMJ2=XMJ**2
51404 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
51405 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51406 & (GHLL*AL+GHRR*AR)**2
51407 IDLAM(LKNT,1)=IJ
51408 IDLAM(LKNT,2)=-(IJ+KSUSY1)
51409 IDLAM(LKNT,3)=0
51410 LKNT=LKNT+1
51411 IDLAM(LKNT,1)=-IJ
51412 IDLAM(LKNT,2)=IJ+KSUSY1
51413 IDLAM(LKNT,3)=0
51414 XLAM(LKNT)=XLAM(LKNT-1)
51415 ENDIF
51416 ENDIF
51417 190 CONTINUE
51418 200 CONTINUE
51419 210 CONTINUE
51420
51421 GOTO 270
51422 220 CONTINUE
51423
51424C...H+ -> CHI+_I + CHI0_J
51425 DO 240 IJ=1,4
51426 XMJ=SMZ(IJ)
51427 AXMJ=ABS(XMJ)
51428 XMJ2=XMJ**2
51429 DO 230 IK=1,2
51430 XMK=SMW(IK)
51431 AXMK=ABS(XMK)
51432 IF(AXMI.GE.AXMJ+AXMK) THEN
51433 LKNT=LKNT+1
51434 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
51435 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
51436 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
51437 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
51438 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51439 GLR=DBLE(OLPP*DCONJG(ORPP))
51440 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
51441 IDLAM(LKNT,1)=KFNCHI(IJ)
51442 IDLAM(LKNT,2)=KFCCHI(IK)
51443 IDLAM(LKNT,3)=0
51444 ENDIF
51445 230 CONTINUE
51446 240 CONTINUE
51447
51448 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
51449 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
51450 AL=0D0
51451 AR=0D0
51452 CF=3D0
51453
51454C...H+ -> T_1 B_1~
51455 XM1=PMAS(PYCOMP(KSUSY1+6),1)
51456 XM2=PMAS(PYCOMP(KSUSY1+5),1)
51457 IF(XMI.GE.XM1+XM2) THEN
51458 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51459 LKNT=LKNT+1
51460 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51461 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
51462 IDLAM(LKNT,1)=KSUSY1+6
51463 IDLAM(LKNT,2)=-(KSUSY1+5)
51464 IDLAM(LKNT,3)=0
51465 ENDIF
51466
51467C...H+ -> T_2 B_1~
51468 XM1=PMAS(PYCOMP(KSUSY2+6),1)
51469 XM2=PMAS(PYCOMP(KSUSY1+5),1)
51470 IF(XMI.GE.XM1+XM2) THEN
51471 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51472 LKNT=LKNT+1
51473 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51474 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
51475 IDLAM(LKNT,1)=KSUSY2+6
51476 IDLAM(LKNT,2)=-(KSUSY1+5)
51477 IDLAM(LKNT,3)=0
51478 ENDIF
51479
51480C...H+ -> T_1 B_2~
51481 XM1=PMAS(PYCOMP(KSUSY1+6),1)
51482 XM2=PMAS(PYCOMP(KSUSY2+5),1)
51483 IF(XMI.GE.XM1+XM2) THEN
51484 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51485 LKNT=LKNT+1
51486 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51487 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
51488 IDLAM(LKNT,1)=KSUSY1+6
51489 IDLAM(LKNT,2)=-(KSUSY2+5)
51490 IDLAM(LKNT,3)=0
51491 ENDIF
51492
51493C...H+ -> T_2 B_2~
51494 XM1=PMAS(PYCOMP(KSUSY2+6),1)
51495 XM2=PMAS(PYCOMP(KSUSY2+5),1)
51496 IF(XMI.GE.XM1+XM2) THEN
51497 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51498 LKNT=LKNT+1
51499 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
51500 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
51501 IDLAM(LKNT,1)=KSUSY2+6
51502 IDLAM(LKNT,2)=-(KSUSY2+5)
51503 IDLAM(LKNT,3)=0
51504 ENDIF
51505
51506C...H+ -> UL DL~
51507 GL=-XMW/SR2*SIN(2D0*BETA)
51508 DO 250 IJ=1,3,2
51509 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
51510 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
51511 IF(XMI.GE.XM1+XM2) THEN
51512 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51513 LKNT=LKNT+1
51514 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
51515 IDLAM(LKNT,1)=-(KSUSY1+IJ)
51516 IDLAM(LKNT,2)=KSUSY1+IJ+1
51517 IDLAM(LKNT,3)=0
51518 ENDIF
51519 250 CONTINUE
51520
51521C...H+ -> EL~ NUL
51522 CF=1D0
51523 DO 260 IJ=11,13,2
51524 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
51525 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
51526 IF(XMI.GE.XM1+XM2) THEN
51527 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51528 LKNT=LKNT+1
51529 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
51530 IDLAM(LKNT,1)=-(KSUSY1+IJ)
51531 IDLAM(LKNT,2)=KSUSY1+IJ+1
51532 IDLAM(LKNT,3)=0
51533 ENDIF
51534 260 CONTINUE
51535
51536C...H+ -> TAU1 NUTAUL
51537 XM1=PMAS(PYCOMP(KSUSY1+15),1)
51538 XM2=PMAS(PYCOMP(KSUSY1+16),1)
51539 IF(XMI.GE.XM1+XM2) THEN
51540 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51541 LKNT=LKNT+1
51542 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
51543 IDLAM(LKNT,1)=-(KSUSY1+15)
51544 IDLAM(LKNT,2)= KSUSY1+16
51545 IDLAM(LKNT,3)=0
51546 ENDIF
51547
51548C...H+ -> TAU2 NUTAUL
51549 XM1=PMAS(PYCOMP(KSUSY2+15),1)
51550 XM2=PMAS(PYCOMP(KSUSY1+16),1)
51551 IF(XMI.GE.XM1+XM2) THEN
51552 XL=PYLAMF(XMI2,XM1**2,XM2**2)
51553 LKNT=LKNT+1
51554 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
51555 IDLAM(LKNT,1)=-(KSUSY2+15)
51556 IDLAM(LKNT,2)= KSUSY1+16
51557 IDLAM(LKNT,3)=0
51558 ENDIF
51559
51560 270 CONTINUE
51561 IKNT=LKNT
51562 XLAM(0)=0D0
51563 DO 280 I=1,IKNT
51564 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
51565 XLAM(0)=XLAM(0)+XLAM(I)
51566 280 CONTINUE
51567 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51568
51569 RETURN
51570 END
51571
51572C*********************************************************************
51573
51574C...PYH2XX
51575C...Calculates the decay rate for a Higgs to an ino pair.
51576
51577 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
51578
51579C...Double precision and integer declarations.
51580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51581 IMPLICIT INTEGER(I-N)
51582 INTEGER PYK,PYCHGE,PYCOMP
51583C...Commonblocks.
51584 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51585 SAVE /PYDAT1/
51586
51587C...Local variables.
51588 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
51589 DOUBLE PRECISION XL,PYLAMF,C1
51590 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
51591
51592 XMI2=XM1**2
51593 XMI3=ABS(XM1**3)
51594 XMJ2=XM2**2
51595 XMK2=XM3**2
51596 XL=PYLAMF(XMI2,XMJ2,XMK2)
51597 PYH2XX=C1/4D0/XMI3*SQRT(XL)
51598 &*(GX2*(XMI2-XMJ2-XMK2)-
51599 &4D0*GLR*XM3*XM2)
51600 IF(PYH2XX.LT.0D0) THEN
51601 WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
51602 WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
51603 STOP
51604 ENDIF
51605
51606 RETURN
51607 END
51608
51609C*********************************************************************
51610
51611C...PYGAUS
51612C...Integration by adaptive Gaussian quadrature.
51613C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
51614
51615 FUNCTION PYGAUS(F, A, B, EPS)
51616
51617C...Double precision and integer declarations.
51618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51619 IMPLICIT INTEGER(I-N)
51620 INTEGER PYK,PYCHGE,PYCOMP
51621
51622C...Local declarations.
51623 EXTERNAL F
51624 DOUBLE PRECISION F,W(12), X(12)
51625 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
51626 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
51627 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
51628 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
51629 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
51630 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
51631 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
51632 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
51633 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
51634 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
51635 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
51636 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
51637
51638C...The Gaussian quadrature algorithm.
51639 H = 0D0
51640 IF(B .EQ. A) GOTO 140
51641 CONST = 5D-3 / ABS(B-A)
51642 BB = A
51643 100 CONTINUE
51644 AA = BB
51645 BB = B
51646 110 CONTINUE
51647 C1 = 0.5D0*(BB+AA)
51648 C2 = 0.5D0*(BB-AA)
51649 S8 = 0D0
51650 DO 120 I = 1, 4
51651 U = C2*X(I)
51652 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
51653 120 CONTINUE
51654 S16 = 0D0
51655 DO 130 I = 5, 12
51656 U = C2*X(I)
51657 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
51658 130 CONTINUE
51659 S16 = C2*S16
51660 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
51661 H = H + S16
51662 IF(BB .NE. B) GOTO 100
51663 ELSE
51664 BB = C1
51665 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
51666 H = 0D0
51667 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
51668 GOTO 140
51669 ENDIF
51670 140 CONTINUE
51671 PYGAUS = H
51672
51673 RETURN
51674 END
51675
51676C*********************************************************************
51677
51678C...PYGAU2
51679C...Integration by adaptive Gaussian quadrature.
51680C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
51681C...Carbon copy of PYGAUS, but avoids having to use it recursively.
51682
51683 FUNCTION PYGAU2(F, A, B, EPS)
51684
51685C...Double precision and integer declarations.
51686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51687 IMPLICIT INTEGER(I-N)
51688 INTEGER PYK,PYCHGE,PYCOMP
51689
51690C...Local declarations.
51691 EXTERNAL F
51692 DOUBLE PRECISION F,W(12), X(12)
51693 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
51694 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
51695 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
51696 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
51697 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
51698 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
51699 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
51700 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
51701 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
51702 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
51703 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
51704 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
51705
51706C...The Gaussian quadrature algorithm.
51707 H = 0D0
51708 IF(B .EQ. A) GOTO 140
51709 CONST = 5D-3 / ABS(B-A)
51710 BB = A
51711 100 CONTINUE
51712 AA = BB
51713 BB = B
51714 110 CONTINUE
51715 C1 = 0.5D0*(BB+AA)
51716 C2 = 0.5D0*(BB-AA)
51717 S8 = 0D0
51718 DO 120 I = 1, 4
51719 U = C2*X(I)
51720 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
51721 120 CONTINUE
51722 S16 = 0D0
51723 DO 130 I = 5, 12
51724 U = C2*X(I)
51725 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
51726 130 CONTINUE
51727 S16 = C2*S16
51728 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
51729 H = H + S16
51730 IF(BB .NE. B) GOTO 100
51731 ELSE
51732 BB = C1
51733 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
51734 H = 0D0
51735 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
51736 GOTO 140
51737 ENDIF
51738 140 CONTINUE
51739 PYGAU2 = H
51740
51741 RETURN
51742 END
51743
51744C*********************************************************************
51745
51746C...PYSIMP
51747C...Simpson formula for an integral.
51748
51749 FUNCTION PYSIMP(Y,X0,X1,N)
51750
51751C...Double precision and integer declarations.
51752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51753 IMPLICIT INTEGER(I-N)
51754 INTEGER PYK,PYCHGE,PYCOMP
51755
51756C...Local variables.
51757 DOUBLE PRECISION Y,X0,X1,H,S
51758 DIMENSION Y(0:N)
51759
51760 S=0D0
51761 H=(X1-X0)/N
51762 DO 100 I=0,N-2,2
51763 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
51764 100 CONTINUE
51765 PYSIMP=S*H/3D0
51766
51767 RETURN
51768 END
51769
51770C*********************************************************************
51771
51772C...PYLAMF
51773C...The standard lambda function.
51774
51775 FUNCTION PYLAMF(X,Y,Z)
51776
51777C...Double precision and integer declarations.
51778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51779 IMPLICIT INTEGER(I-N)
51780 INTEGER PYK,PYCHGE,PYCOMP
51781
51782C...Local variables.
51783 DOUBLE PRECISION PYLAMF,X,Y,Z
51784
51785 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
51786 IF(PYLAMF.LT.0D0) PYLAMF=0D0
51787
51788 RETURN
51789 END
51790
51791C*********************************************************************
51792
51793C...PYTBDY
51794C...Generates 3-body decays of gauginos.
51795
51796 SUBROUTINE PYTBDY(IDIN)
51797
51798C...Double precision and integer declarations.
51799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51800 IMPLICIT INTEGER(I-N)
51801 INTEGER PYK,PYCHGE,PYCOMP
51802C...Parameter statement to help give large particle numbers.
51803 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51804 &KEXCIT=4000000,KDIMEN=5000000)
51805C...Commonblocks.
51806 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
51807 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51808 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51809C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
51810C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
51811 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51812 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51813C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
51814 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
51815
51816C...Local variables.
51817 DOUBLE PRECISION XM(5)
51818 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
51819 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
51820 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
51821 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
51822 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
51823 DOUBLE PRECISION CPHI1,SPHI1
51824 DOUBLE PRECISION S23DEL,EPS
51825 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
51826 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
51827 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
51828 INTEGER INOID(4)
51829 DATA INOID/22,23,25,35/
51830 DATA EPS/1D-6/
51831
51832 ID=IDIN
51833 ISKIP=1
51834 XM(1)=P(N+1,5)
51835 XM(2)=P(N+2,5)
51836 XM(3)=P(N+3,5)
51837 XM(5)=P(ID,5)
51838
51839C...GENERATE S12
51840 S12MIN=(XM(1)+XM(2))**2
51841 S12MAX=(XM(5)-XM(3))**2
51842 YJACO1=S12MAX-S12MIN
51843
51844C...Initialize some parameters
51845 XW=PARU(102)
51846 XW1=1D0-XW
51847 TANW=SQRT(XW/XW1)
51848 IZID1=0
51849 IWID1=0
51850 IZID2=0
51851 IWID2=0
51852 DO 100 I1=1,4
51853 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
51854 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
51855 100 CONTINUE
51856 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
51857 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
51858 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
51859 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
51860 IA=K(N+2,2)
51861 JA=K(N+3,2)
51862 ZM12=XM(5)**2
51863 ZM22=XM(1)**2
51864 EI=KCHG(IABS(IA),1)/3D0
51865 T3I=SIGN(1D0,EI+1D-6)/2D0
51866 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
51867 ISKIP=0
51868 ELSEIF(IZID1*IZID2.NE.0) THEN
51869 SQMZ=PMAS(23,1)**2
51870 GMMZ=PMAS(23,1)*PMAS(23,2)
51871 DO 110 I=1,4
51872 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
51873 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
51874 110 CONTINUE
51875 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
51876 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
51877 ORPP=DCONJG(OLPP)
51878 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
51879 XLR2=XLL2
51880 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
51881 XRL2=XRR2
51882 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
51883 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
51884 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
51885 XM1M2=SMZ(IZID1)*SMZ(IZID2)
51886 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51887 QLLU=-GLIJ
51888 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51889 QLRT=DCONJG(GLIJ)
51890 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
51891 QRLT=GRIJ
51892 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
51893 QRRU=-DCONJG(GRIJ)
51894 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
51895 IF(IZID1.NE.0) THEN
51896 XM1M2=SMZ(IZID1)*SMW(IWID2)
51897 IZID1=IWID2
51898 IZID2=IZID1
51899 ELSE
51900 XM1M2=SMZ(IZID2)*SMW(IWID1)
51901 IZID1=IWID1
51902 ENDIF
51903 RT2I = 1D0/SQRT(2D0)
51904 SQMZ=PMAS(24,1)**2
51905 GMMZ=PMAS(24,1)*PMAS(24,2)
51906 DO 120 I=1,2
51907 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
51908 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
51909 120 CONTINUE
51910 DO 130 I=1,4
51911 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
51912 130 CONTINUE
51913 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
51914 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
51915 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
51916 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
51917 EJ=KCHG(JA,1)/3D0
51918 T3J=SIGN(1D0,EJ+1D-6)/2D0
51919 QRLS=DCMPLX(0D0,0D0)
51920 QRLT=QRLS
51921 QRRS=QRLS
51922 QRRU=QRLS
51923 XRR2=1D6**2
51924 XRL2=XRR2
51925 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
51926 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
51927 IF(MOD(IA,2).EQ.0) THEN
51928 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
51929 & TANW+ZMIXC(IZID2,2)*T3I)
51930 QLRT=-DCONJG(UMIXC(IZID1,1))*(
51931 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
51932 ELSE
51933 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
51934 & TANW+ZMIXC(IZID2,2)*T3J)
51935 QLRT=-DCONJG(UMIXC(IZID1,1))*(
51936 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
51937 ENDIF
51938 ELSEIF(IWID1*IWID2.NE.0) THEN
51939 IZID1=IWID1
51940 IZID2=IWID2
51941 XM1M2=SMW(IWID1)*SMW(IWID2)
51942 SQMZ=PMAS(23,1)**2
51943 GMMZ=PMAS(23,1)*PMAS(23,2)
51944 DO 140 I=1,2
51945 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
51946 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
51947 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
51948 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
51949 140 CONTINUE
51950 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
51951 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
51952 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
51953 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
51954 QRLS=-DCMPLX(EI/XW1)*ORPP
51955 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51956 QRRS=-DCMPLX(EI/XW1)*OLPP
51957 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51958 IF(MOD(IA,2).EQ.0) THEN
51959 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
51960 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
51961 ELSE
51962 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
51963 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
51964 ENDIF
51965 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
51966 &THEN
51967 ISKIP=0
51968 ELSE
51969 ISKIP=0
51970 ENDIF
51971
51972 IF(ISKIP.NE.0) THEN
51973 WTMAX=0D0
51974 DO 160 KT=1,100
51975 S12=S12MIN+YJACO1*(KT-1)/99
51976 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
51977 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
51978 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
51979 & -(2D0*XM(1)*XM(2))**2
51980 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
51981 & -(2D0*XM(3)*XM(5))**2
51982 S23DF1=S23DF1*EPS
51983 S23DF2=S23DF2*EPS
51984 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
51985 S23DEL=S23DEL/EPS
51986 S23MIN=S23AVE-S23DEL
51987 S23MAX=S23AVE+S23DEL
51988 YJACO2=S23MAX-S23MIN
51989 TH=S12
51990 DO 150 KS=1,100
51991 S23=S23MIN+YJACO2*(KS-1)/99
51992 SH=S23
51993 UH=ZM12+ZM22-SH-TH
51994 WU2 = (UH-ZM12)*(UH-ZM22)
51995 WT2 = (TH-ZM12)*(TH-ZM22)
51996 WS2 = XM1M2*SH
51997 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
51998 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
51999 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
52000 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
52001 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
52002 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
52003 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
52004 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
52005 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
52006 IF(WT0.GT.WTMAX) WTMAX=WT0
52007 150 CONTINUE
52008 160 CONTINUE
52009
52010 WTMAX=WTMAX*1.05D0
52011 ENDIF
52012
52013C...FIND S12*
52014 AX=S12MIN
52015 CX=S12MAX
52016 BX=S12MIN+0.5D0*YJACO1
52017 X0=AX
52018 X3=CX
52019 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
52020 X1=BX
52021 X2=BX+C*(CX-BX)
52022 ELSE
52023 X2=BX
52024 X1=BX-C*(BX-AX)
52025 ENDIF
52026
52027C...SOLVE FOR F1 AND F2
52028 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
52029 &-(2D0*XM(1)*XM(2))**2
52030 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
52031 &-(2D0*XM(3)*XM(5))**2
52032 S23DF1=S23DF1*EPS
52033 S23DF2=S23DF2*EPS
52034 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
52035 F1=-2D0*S23DEL/EPS
52036 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
52037 &-(2D0*XM(1)*XM(2))**2
52038 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
52039 &-(2D0*XM(3)*XM(5))**2
52040 S23DF1=S23DF1*EPS
52041 S23DF2=S23DF2*EPS
52042 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
52043 F2=-2D0*S23DEL/EPS
52044
52045 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
52046C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
52047 IF(F2.LE.F1)THEN
52048 X0=X1
52049 X1=X2
52050 X2=R*X1+C*X3
52051 F1=F2
52052 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
52053 & -(2D0*XM(1)*XM(2))**2
52054 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
52055 & -(2D0*XM(3)*XM(5))**2
52056 S23DF1=S23DF1*EPS
52057 S23DF2=S23DF2*EPS
52058 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
52059 F2=-2D0*S23DEL/EPS
52060 ELSE
52061 X3=X2
52062 X2=X1
52063 X1=R*X2+C*X0
52064 F2=F1
52065 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
52066 & -(2D0*XM(1)*XM(2))**2
52067 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
52068 & -(2D0*XM(3)*XM(5))**2
52069 S23DF1=S23DF1*EPS
52070 S23DF2=S23DF2*EPS
52071 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
52072 F1=-2D0*S23DEL/EPS
52073 ENDIF
52074 GOTO 170
52075 ENDIF
52076C...WE WANT THE MAXIMUM, NOT THE MINIMUM
52077 IF(F1.LT.F2)THEN
52078 GOLDEN=-F1
52079 XMIN=X1
52080 ELSE
52081 GOLDEN=-F2
52082 XMIN=X2
52083 ENDIF
52084
52085 IKNT=0
52086 180 S12=S12MIN+PYR(0)*YJACO1
52087 IKNT=IKNT+1
52088C...GENERATE S23
52089 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
52090 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
52091 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
52092 &-(2D0*XM(1)*XM(2))**2
52093 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
52094 &-(2D0*XM(3)*XM(5))**2
52095 S23DF1=S23DF1*EPS
52096 S23DF2=S23DF2*EPS
52097 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
52098 S23DEL=S23DEL/EPS
52099 S23MIN=S23AVE-S23DEL
52100 S23MAX=S23AVE+S23DEL
52101 YJACO2=S23MAX-S23MIN
52102 S23=S23MIN+PYR(0)*YJACO2
52103
52104C...CHECK THE SAMPLING
52105 IF(IKNT.GT.100) THEN
52106 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
52107 GOTO 190
52108 ENDIF
52109 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
52110
52111 IF(ISKIP.EQ.0) GOTO 190
52112
52113 SH=S23
52114 TH=S12
52115 UH=ZM12+ZM22-SH-TH
52116
52117 WU2 = (UH-ZM12)*(UH-ZM22)
52118 WT2 = (TH-ZM12)*(TH-ZM22)
52119 WS2 = XM1M2*SH
52120 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
52121 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
52122
52123 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
52124 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
52125 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
52126 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
52127c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
52128c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
52129c &/DCMPLX(TH-XML2)
52130c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
52131c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
52132c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
52133 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
52134 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
52135 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
52136
52137 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
52138 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
52139
52140 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
52141 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
52142 D2=XM(5)-D1-D3
52143 P1=SQRT(D1*D1-XM(1)**2)
52144 P2=SQRT(D2*D2-XM(2)**2)
52145 P3=SQRT(D3*D3-XM(3)**2)
52146 CTHE1=2D0*PYR(0)-1D0
52147 ANG1=2D0*PYR(0)*PARU(1)
52148 CPHI1=COS(ANG1)
52149 SPHI1=SIN(ANG1)
52150 ARG=1D0-CTHE1**2
52151 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
52152 STHE1=SQRT(ARG)
52153 P(N+1,1)=P1*STHE1*CPHI1
52154 P(N+1,2)=P1*STHE1*SPHI1
52155 P(N+1,3)=P1*CTHE1
52156 P(N+1,4)=D1
52157
52158C...GET CPHI3
52159 ANG3=2D0*PYR(0)*PARU(1)
52160 CPHI3=COS(ANG3)
52161 SPHI3=SIN(ANG3)
52162 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
52163 ARG=1D0-CTHE3**2
52164 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
52165 STHE3=SQRT(ARG)
52166 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
52167 &+P3*STHE3*SPHI3*SPHI1
52168 &+P3*CTHE3*STHE1*CPHI1
52169 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
52170 &-P3*STHE3*SPHI3*CPHI1
52171 &+P3*CTHE3*STHE1*SPHI1
52172 P(N+3,3)=P3*STHE3*CPHI3*STHE1
52173 &+P3*CTHE3*CTHE1
52174 P(N+3,4)=D3
52175
52176 DO 200 I=1,3
52177 P(N+2,I)=-P(N+1,I)-P(N+3,I)
52178 200 CONTINUE
52179 P(N+2,4)=D2
52180
52181 RETURN
52182 END
52183
52184C*********************************************************************
52185
52186C...PYTECM
52187C...Finds the s-hat dependent eigenvalues of the inverse propagator
52188C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
52189C...phase space generation.
52190
52191 SUBROUTINE PYTECM(S1,S2)
52192
52193C...Double precision and integer declarations.
52194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52195 IMPLICIT INTEGER(I-N)
52196 INTEGER PYK,PYCHGE,PYCOMP
52197C...Parameter statement to help give large particle numbers.
52198 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52199 &KEXCIT=4000000,KDIMEN=5000000)
52200C...Commonblocks.
52201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52203 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52204 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
52205 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
52206
52207C...Local variables.
52208 DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
52209 &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
52210 &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
52211 INTEGER i,j,ierr
52212
52213 SH=PMAS(PYCOMP(KTECHN+113),1)**2
52214 AEM=PYALEM(SH)
52215
52216 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
52217 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
52218 QUPD=2D0*RTCM(2)-1D0
52219
52220 ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
52221 FAR=SQRT(AEM/ALPRHT)
52222 FAO=FAR*QUPD
52223 FZR=FAR*CT2W
52224 FZO=-FAO*TANW
52225
52226 AR(1,1) = SH
52227 AR(2,2) = SH-PMAS(23,1)**2
52228 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
52229 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
52230 AR(1,2) = 0D0
52231 AR(2,1) = 0D0
52232 AR(1,3) = -SH*FAR
52233 AR(3,1) = AR(1,3)
52234 AR(1,4) = -SH*FAO
52235 AR(4,1) = AR(1,4)
52236 AR(2,3) = -SH*FZR
52237 AR(3,2) = AR(2,3)
52238 AR(2,4) = -SH*FZO
52239 AR(4,2) = AR(2,4)
52240 AR(3,4) = 0D0
52241 AR(4,3) = 0D0
52242CCCCCCCC
52243 DO 110 I=1,4
52244 DO 100 J=1,4
52245 AT(I,J)=0D0
52246 100 CONTINUE
52247 110 CONTINUE
52248 SHR=SQRT(SH)
52249 CALL PYWIDT(23,SH,WDTP,WDTE)
52250 AT(2,2) = WDTP(0)*SHR
52251 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
52252 AT(3,3) = WDTP(0)*SHR
52253 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
52254 AT(4,4) = WDTP(0)*SHR
52255CCCC
52256 CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
52257 DO 120 I=1,4
52258 WI(I)=SQRT(ABS(SH-WR(I)))
52259 WR(I)=ABS(WR(I))
52260 120 CONTINUE
52261 R1=MIN(WR(1),WR(2),WR(3),WR(4))
52262 R2=1D20
52263 S1=0D0
52264 S2=0D0
52265 DO 130 I=1,4
52266 IF(ABS(WR(I)-R1).LT.1D-6) THEN
52267 S1=WI(I)
52268 GOTO 130
52269 ENDIF
52270 IF(WR(I).LE.R2) THEN
52271 R2=WR(I)
52272 S2=WI(I)
52273 ENDIF
52274 130 CONTINUE
52275 S1=S1**2
52276 S2=S2**2
52277 RETURN
52278 END
52279
52280C*********************************************************************
52281
52282C...PYEIGC
52283C...Finds eigenvalues of a general complex matrix
52284C
52285C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
52286C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
52287C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
52288C OF A COMPLEX GENERAL MATRIX.
52289C
52290C ON INPUT
52291C
52292C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
52293C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
52294C DIMENSION STATEMENT.
52295C
52296C N IS THE ORDER OF THE MATRIX A=(AR,AI).
52297C
52298C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
52299C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
52300C
52301C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
52302C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
52303C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
52304C
52305C ON OUTPUT
52306C
52307C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
52308C RESPECTIVELY, OF THE EIGENVALUES.
52309C
52310C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
52311C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
52312C
52313C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
52314C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
52315C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
52316C
52317C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
52318C
52319C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
52320C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
52321C
52322C THIS VERSION DATED AUGUST 1983.
52323C
52324
52325 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
52326
52327 INTEGER N,NM,IS1,IS2,IERR,MATZ
52328 DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
52329 X FV1(4),FV2(4),FV3(4)
52330 IF (N .LE. NM) GOTO 100
52331 IERR = 10 * N
52332 GOTO 120
52333C
52334 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
52335 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
52336 IF (MATZ .NE. 0) GOTO 110
52337C .......... FIND EIGENVALUES ONLY ..........
52338 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
52339 GOTO 120
52340C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
52341 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
52342 IF (IERR .NE. 0) GOTO 120
52343 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
52344 120 RETURN
52345 END
52346
52347C*********************************************************************
52348
52349C...PYCMQR
52350C...Auxiliary to PYEICG.
52351C
52352C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
52353C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
52354C AND WILKINSON.
52355C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
52356C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
52357C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
52358C
52359C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
52360C UPPER HESSENBERG MATRIX BY THE QR METHOD.
52361C
52362C ON INPUT
52363C
52364C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
52365C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
52366C DIMENSION STATEMENT.
52367C
52368C N IS THE ORDER OF THE MATRIX.
52369C
52370C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
52371C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
52372C SET LOW=1, IGH=N.
52373C
52374C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
52375C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
52376C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
52377C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
52378C THE REDUCTION BY CORTH, IF PERFORMED.
52379C
52380C ON OUTPUT
52381C
52382C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
52383C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
52384C CALLING COMQR IF SUBSEQUENT CALCULATION OF
52385C EIGENVECTORS IS TO BE PERFORMED.
52386C
52387C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
52388C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
52389C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
52390C FOR INDICES IERR+1,...,N.
52391C
52392C IERR IS SET TO
52393C ZERO FOR NORMAL RETURN,
52394C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
52395C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
52396C
52397C CALLS PYCDIV FOR COMPLEX DIVISION.
52398C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
52399C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
52400C
52401C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
52402C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
52403C
52404C THIS VERSION DATED AUGUST 1983.
52405C
52406
52407 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
52408
52409 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
52410 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4)
52411 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
52412 X PYTHAG
52413
52414 IERR = 0
52415 IF (LOW .EQ. IGH) GOTO 130
52416C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
52417 L = LOW + 1
52418C
52419 DO 120 I = L, IGH
52420 LL = MIN0(I+1,IGH)
52421 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
52422 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
52423 YR = HR(I,I-1) / NORM
52424 YI = HI(I,I-1) / NORM
52425 HR(I,I-1) = NORM
52426 HI(I,I-1) = 0.0D0
52427C
52428 DO 100 J = I, IGH
52429 SI = YR * HI(I,J) - YI * HR(I,J)
52430 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
52431 HI(I,J) = SI
52432 100 CONTINUE
52433C
52434 DO 110 J = LOW, LL
52435 SI = YR * HI(J,I) + YI * HR(J,I)
52436 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
52437 HI(J,I) = SI
52438 110 CONTINUE
52439C
52440 120 CONTINUE
52441C .......... STORE ROOTS ISOLATED BY CBAL ..........
52442 130 DO 140 I = 1, N
52443 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
52444 WR(I) = HR(I,I)
52445 WI(I) = HI(I,I)
52446 140 CONTINUE
52447C
52448 EN = IGH
52449 TR = 0.0D0
52450 TI = 0.0D0
52451 ITN = 30*N
52452C .......... SEARCH FOR NEXT EIGENVALUE ..........
52453 150 IF (EN .LT. LOW) GOTO 320
52454 ITS = 0
52455 ENM1 = EN - 1
52456C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
52457C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
52458 160 DO 170 LL = LOW, EN
52459 L = EN + LOW - LL
52460 IF (L .EQ. LOW) GOTO 180
52461 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
52462 X + DABS(HR(L,L)) + DABS(HI(L,L))
52463 TST2 = TST1 + DABS(HR(L,L-1))
52464 IF (TST2 .EQ. TST1) GOTO 180
52465 170 CONTINUE
52466C .......... FORM SHIFT ..........
52467 180 IF (L .EQ. EN) GOTO 300
52468 IF (ITN .EQ. 0) GOTO 310
52469 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
52470 SR = HR(EN,EN)
52471 SI = HI(EN,EN)
52472 XR = HR(ENM1,EN) * HR(EN,ENM1)
52473 XI = HI(ENM1,EN) * HR(EN,ENM1)
52474 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
52475 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
52476 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
52477 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
52478 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
52479 ZZR = -ZZR
52480 ZZI = -ZZI
52481 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
52482 SR = SR - XR
52483 SI = SI - XI
52484 GOTO 210
52485C .......... FORM EXCEPTIONAL SHIFT ..........
52486 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
52487 SI = 0.0D0
52488C
52489 210 DO 220 I = LOW, EN
52490 HR(I,I) = HR(I,I) - SR
52491 HI(I,I) = HI(I,I) - SI
52492 220 CONTINUE
52493C
52494 TR = TR + SR
52495 TI = TI + SI
52496 ITS = ITS + 1
52497 ITN = ITN - 1
52498C .......... REDUCE TO TRIANGLE (ROWS) ..........
52499 LP1 = L + 1
52500C
52501 DO 240 I = LP1, EN
52502 SR = HR(I,I-1)
52503 HR(I,I-1) = 0.0D0
52504 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
52505 XR = HR(I-1,I-1) / NORM
52506 WR(I-1) = XR
52507 XI = HI(I-1,I-1) / NORM
52508 WI(I-1) = XI
52509 HR(I-1,I-1) = NORM
52510 HI(I-1,I-1) = 0.0D0
52511 HI(I,I-1) = SR / NORM
52512C
52513 DO 230 J = I, EN
52514 YR = HR(I-1,J)
52515 YI = HI(I-1,J)
52516 ZZR = HR(I,J)
52517 ZZI = HI(I,J)
52518 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
52519 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
52520 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
52521 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
52522 230 CONTINUE
52523C
52524 240 CONTINUE
52525C
52526 SI = HI(EN,EN)
52527 IF (SI .EQ. 0.0D0) GOTO 250
52528 NORM = PYTHAG(HR(EN,EN),SI)
52529 SR = HR(EN,EN) / NORM
52530 SI = SI / NORM
52531 HR(EN,EN) = NORM
52532 HI(EN,EN) = 0.0D0
52533C .......... INVERSE OPERATION (COLUMNS) ..........
52534 250 DO 280 J = LP1, EN
52535 XR = WR(J-1)
52536 XI = WI(J-1)
52537C
52538 DO 270 I = L, J
52539 YR = HR(I,J-1)
52540 YI = 0.0D0
52541 ZZR = HR(I,J)
52542 ZZI = HI(I,J)
52543 IF (I .EQ. J) GOTO 260
52544 YI = HI(I,J-1)
52545 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
52546 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
52547 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
52548 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
52549 270 CONTINUE
52550C
52551 280 CONTINUE
52552C
52553 IF (SI .EQ. 0.0D0) GOTO 160
52554C
52555 DO 290 I = L, EN
52556 YR = HR(I,EN)
52557 YI = HI(I,EN)
52558 HR(I,EN) = SR * YR - SI * YI
52559 HI(I,EN) = SR * YI + SI * YR
52560 290 CONTINUE
52561C
52562 GOTO 160
52563C .......... A ROOT FOUND ..........
52564 300 WR(EN) = HR(EN,EN) + TR
52565 WI(EN) = HI(EN,EN) + TI
52566 EN = ENM1
52567 GOTO 150
52568C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
52569C CONVERGED AFTER 30*N ITERATIONS ..........
52570 310 IERR = EN
52571 320 RETURN
52572 END
52573
52574C*********************************************************************
52575
52576C...PYCMQ2
52577C...Auxiliary to PYEICG.
52578C
52579C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
52580C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
52581C AND WILKINSON.
52582C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
52583C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
52584C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
52585C
52586C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
52587C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
52588C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
52589C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
52590C THIS GENERAL MATRIX TO HESSENBERG FORM.
52591C
52592C ON INPUT
52593C
52594C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
52595C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
52596C DIMENSION STATEMENT.
52597C
52598C N IS THE ORDER OF THE MATRIX.
52599C
52600C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
52601C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
52602C SET LOW=1, IGH=N.
52603C
52604C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
52605C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
52606C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
52607C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
52608C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
52609C
52610C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
52611C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
52612C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
52613C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
52614C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
52615C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
52616C ARBITRARY.
52617C
52618C ON OUTPUT
52619C
52620C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
52621C HAVE BEEN DESTROYED.
52622C
52623C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
52624C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
52625C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
52626C FOR INDICES IERR+1,...,N.
52627C
52628C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
52629C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
52630C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
52631C THE EIGENVECTORS HAS BEEN FOUND.
52632C
52633C IERR IS SET TO
52634C ZERO FOR NORMAL RETURN,
52635C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
52636C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
52637C
52638C CALLS PYCDIV FOR COMPLEX DIVISION.
52639C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
52640C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
52641C
52642C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
52643C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
52644C
52645C THIS VERSION DATED OCTOBER 1989.
52646C
52647C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
52648C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
52649C
52650
52651 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
52652
52653 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
52654 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
52655 DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
52656 X ORTR(4),ORTI(4)
52657 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
52658 X PYTHAG
52659
52660 IERR = 0
52661C .......... INITIALIZE EIGENVECTOR MATRIX ..........
52662 DO 110 J = 1, N
52663C
52664 DO 100 I = 1, N
52665 ZR(I,J) = 0.0D0
52666 ZI(I,J) = 0.0D0
52667 100 CONTINUE
52668 ZR(J,J) = 1.0D0
52669 110 CONTINUE
52670C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
52671C FROM THE INFORMATION LEFT BY CORTH ..........
52672 IEND = IGH - LOW - 1
52673 IF (IEND.LT.0) GOTO 220
52674 IF (IEND.EQ.0) GOTO 170
52675C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
52676 DO 160 II = 1, IEND
52677 I = IGH - II
52678 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
52679 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
52680C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
52681 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
52682 IP1 = I + 1
52683C
52684 DO 120 K = IP1, IGH
52685 ORTR(K) = HR(K,I-1)
52686 ORTI(K) = HI(K,I-1)
52687 120 CONTINUE
52688C
52689 DO 150 J = I, IGH
52690 SR = 0.0D0
52691 SI = 0.0D0
52692C
52693 DO 130 K = I, IGH
52694 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
52695 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
52696 130 CONTINUE
52697C
52698 SR = SR / NORM
52699 SI = SI / NORM
52700C
52701 DO 140 K = I, IGH
52702 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
52703 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
52704 140 CONTINUE
52705C
52706 150 CONTINUE
52707C
52708 160 CONTINUE
52709C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
52710 170 L = LOW + 1
52711C
52712 DO 210 I = L, IGH
52713 LL = MIN0(I+1,IGH)
52714 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
52715 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
52716 YR = HR(I,I-1) / NORM
52717 YI = HI(I,I-1) / NORM
52718 HR(I,I-1) = NORM
52719 HI(I,I-1) = 0.0D0
52720C
52721 DO 180 J = I, N
52722 SI = YR * HI(I,J) - YI * HR(I,J)
52723 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
52724 HI(I,J) = SI
52725 180 CONTINUE
52726C
52727 DO 190 J = 1, LL
52728 SI = YR * HI(J,I) + YI * HR(J,I)
52729 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
52730 HI(J,I) = SI
52731 190 CONTINUE
52732C
52733 DO 200 J = LOW, IGH
52734 SI = YR * ZI(J,I) + YI * ZR(J,I)
52735 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
52736 ZI(J,I) = SI
52737 200 CONTINUE
52738C
52739 210 CONTINUE
52740C .......... STORE ROOTS ISOLATED BY CBAL ..........
52741 220 DO 230 I = 1, N
52742 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
52743 WR(I) = HR(I,I)
52744 WI(I) = HI(I,I)
52745 230 CONTINUE
52746C
52747 EN = IGH
52748 TR = 0.0D0
52749 TI = 0.0D0
52750 ITN = 30*N
52751C .......... SEARCH FOR NEXT EIGENVALUE ..........
52752 240 IF (EN .LT. LOW) GOTO 430
52753 ITS = 0
52754 ENM1 = EN - 1
52755C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
52756C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
52757 250 DO 260 LL = LOW, EN
52758 L = EN + LOW - LL
52759 IF (L .EQ. LOW) GOTO 270
52760 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
52761 X + DABS(HR(L,L)) + DABS(HI(L,L))
52762 TST2 = TST1 + DABS(HR(L,L-1))
52763 IF (TST2 .EQ. TST1) GOTO 270
52764 260 CONTINUE
52765C .......... FORM SHIFT ..........
52766 270 IF (L .EQ. EN) GOTO 420
52767 IF (ITN .EQ. 0) GOTO 550
52768 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
52769 SR = HR(EN,EN)
52770 SI = HI(EN,EN)
52771 XR = HR(ENM1,EN) * HR(EN,ENM1)
52772 XI = HI(ENM1,EN) * HR(EN,ENM1)
52773 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
52774 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
52775 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
52776 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
52777 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
52778 ZZR = -ZZR
52779 ZZI = -ZZI
52780 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
52781 SR = SR - XR
52782 SI = SI - XI
52783 GOTO 300
52784C .......... FORM EXCEPTIONAL SHIFT ..........
52785 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
52786 SI = 0.0D0
52787C
52788 300 DO 310 I = LOW, EN
52789 HR(I,I) = HR(I,I) - SR
52790 HI(I,I) = HI(I,I) - SI
52791 310 CONTINUE
52792C
52793 TR = TR + SR
52794 TI = TI + SI
52795 ITS = ITS + 1
52796 ITN = ITN - 1
52797C .......... REDUCE TO TRIANGLE (ROWS) ..........
52798 LP1 = L + 1
52799C
52800 DO 330 I = LP1, EN
52801 SR = HR(I,I-1)
52802 HR(I,I-1) = 0.0D0
52803 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
52804 XR = HR(I-1,I-1) / NORM
52805 WR(I-1) = XR
52806 XI = HI(I-1,I-1) / NORM
52807 WI(I-1) = XI
52808 HR(I-1,I-1) = NORM
52809 HI(I-1,I-1) = 0.0D0
52810 HI(I,I-1) = SR / NORM
52811C
52812 DO 320 J = I, N
52813 YR = HR(I-1,J)
52814 YI = HI(I-1,J)
52815 ZZR = HR(I,J)
52816 ZZI = HI(I,J)
52817 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
52818 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
52819 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
52820 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
52821 320 CONTINUE
52822C
52823 330 CONTINUE
52824C
52825 SI = HI(EN,EN)
52826 IF (SI .EQ. 0.0D0) GOTO 350
52827 NORM = PYTHAG(HR(EN,EN),SI)
52828 SR = HR(EN,EN) / NORM
52829 SI = SI / NORM
52830 HR(EN,EN) = NORM
52831 HI(EN,EN) = 0.0D0
52832 IF (EN .EQ. N) GOTO 350
52833 IP1 = EN + 1
52834C
52835 DO 340 J = IP1, N
52836 YR = HR(EN,J)
52837 YI = HI(EN,J)
52838 HR(EN,J) = SR * YR + SI * YI
52839 HI(EN,J) = SR * YI - SI * YR
52840 340 CONTINUE
52841C .......... INVERSE OPERATION (COLUMNS) ..........
52842 350 DO 390 J = LP1, EN
52843 XR = WR(J-1)
52844 XI = WI(J-1)
52845C
52846 DO 370 I = 1, J
52847 YR = HR(I,J-1)
52848 YI = 0.0D0
52849 ZZR = HR(I,J)
52850 ZZI = HI(I,J)
52851 IF (I .EQ. J) GOTO 360
52852 YI = HI(I,J-1)
52853 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
52854 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
52855 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
52856 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
52857 370 CONTINUE
52858C
52859 DO 380 I = LOW, IGH
52860 YR = ZR(I,J-1)
52861 YI = ZI(I,J-1)
52862 ZZR = ZR(I,J)
52863 ZZI = ZI(I,J)
52864 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
52865 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
52866 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
52867 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
52868 380 CONTINUE
52869C
52870 390 CONTINUE
52871C
52872 IF (SI .EQ. 0.0D0) GOTO 250
52873C
52874 DO 400 I = 1, EN
52875 YR = HR(I,EN)
52876 YI = HI(I,EN)
52877 HR(I,EN) = SR * YR - SI * YI
52878 HI(I,EN) = SR * YI + SI * YR
52879 400 CONTINUE
52880C
52881 DO 410 I = LOW, IGH
52882 YR = ZR(I,EN)
52883 YI = ZI(I,EN)
52884 ZR(I,EN) = SR * YR - SI * YI
52885 ZI(I,EN) = SR * YI + SI * YR
52886 410 CONTINUE
52887C
52888 GOTO 250
52889C .......... A ROOT FOUND ..........
52890 420 HR(EN,EN) = HR(EN,EN) + TR
52891 WR(EN) = HR(EN,EN)
52892 HI(EN,EN) = HI(EN,EN) + TI
52893 WI(EN) = HI(EN,EN)
52894 EN = ENM1
52895 GOTO 240
52896C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
52897C VECTORS OF UPPER TRIANGULAR FORM ..........
52898 430 NORM = 0.0D0
52899C
52900 DO 440 I = 1, N
52901C
52902 DO 440 J = I, N
52903 TR = DABS(HR(I,J)) + DABS(HI(I,J))
52904 IF (TR .GT. NORM) NORM = TR
52905 440 CONTINUE
52906C
52907 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
52908C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
52909 DO 500 NN = 2, N
52910 EN = N + 2 - NN
52911 XR = WR(EN)
52912 XI = WI(EN)
52913 HR(EN,EN) = 1.0D0
52914 HI(EN,EN) = 0.0D0
52915 ENM1 = EN - 1
52916C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
52917 DO 490 II = 1, ENM1
52918 I = EN - II
52919 ZZR = 0.0D0
52920 ZZI = 0.0D0
52921 IP1 = I + 1
52922C
52923 DO 450 J = IP1, EN
52924 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
52925 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
52926 450 CONTINUE
52927C
52928 YR = XR - WR(I)
52929 YI = XI - WI(I)
52930 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
52931 TST1 = NORM
52932 YR = TST1
52933 460 YR = 0.01D0 * YR
52934 TST2 = NORM + YR
52935 IF (TST2 .GT. TST1) GOTO 460
52936 470 CONTINUE
52937 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
52938C .......... OVERFLOW CONTROL ..........
52939 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
52940 IF (TR .EQ. 0.0D0) GOTO 490
52941 TST1 = TR
52942 TST2 = TST1 + 1.0D0/TST1
52943 IF (TST2 .GT. TST1) GOTO 490
52944 DO 480 J = I, EN
52945 HR(J,EN) = HR(J,EN)/TR
52946 HI(J,EN) = HI(J,EN)/TR
52947 480 CONTINUE
52948C
52949 490 CONTINUE
52950C
52951 500 CONTINUE
52952C .......... END BACKSUBSTITUTION ..........
52953C .......... VECTORS OF ISOLATED ROOTS ..........
52954 DO 520 I = 1, N
52955 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
52956C
52957 DO 510 J = I, N
52958 ZR(I,J) = HR(I,J)
52959 ZI(I,J) = HI(I,J)
52960 510 CONTINUE
52961C
52962 520 CONTINUE
52963C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
52964C VECTORS OF ORIGINAL FULL MATRIX.
52965C FOR J=N STEP -1 UNTIL LOW DO -- ..........
52966 DO 540 JJ = LOW, N
52967 J = N + LOW - JJ
52968 M = MIN0(J,IGH)
52969C
52970 DO 540 I = LOW, IGH
52971 ZZR = 0.0D0
52972 ZZI = 0.0D0
52973C
52974 DO 530 K = LOW, M
52975 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
52976 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
52977 530 CONTINUE
52978C
52979 ZR(I,J) = ZZR
52980 ZI(I,J) = ZZI
52981 540 CONTINUE
52982C
52983 GOTO 560
52984C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
52985C CONVERGED AFTER 30*N ITERATIONS ..........
52986 550 IERR = EN
52987 560 RETURN
52988 END
52989
52990C*********************************************************************
52991
52992C...PYCDIV
52993C...Auxiliary to PYCMQR
52994C
52995C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
52996C
52997
52998 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
52999
53000 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
53001 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
53002
53003 S = DABS(BR) + DABS(BI)
53004 ARS = AR/S
53005 AIS = AI/S
53006 BRS = BR/S
53007 BIS = BI/S
53008 S = BRS**2 + BIS**2
53009 CR = (ARS*BRS + AIS*BIS)/S
53010 CI = (AIS*BRS - ARS*BIS)/S
53011 RETURN
53012 END
53013
53014C*********************************************************************
53015
53016C...PYCSRT
53017C...Auxiliary to PYCMQR
53018C
53019C (YR,YI) = COMPLEX DSQRT(XR,XI)
53020C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
53021C
53022
53023 SUBROUTINE PYCSRT(XR,XI,YR,YI)
53024
53025 DOUBLE PRECISION XR,XI,YR,YI
53026 DOUBLE PRECISION S,TR,TI,PYTHAG
53027
53028 TR = XR
53029 TI = XI
53030 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
53031 IF (TR .GE. 0.0D0) YR = S
53032 IF (TI .LT. 0.0D0) S = -S
53033 IF (TR .LE. 0.0D0) YI = S
53034 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
53035 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
53036 RETURN
53037 END
53038
53039 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
53040 DOUBLE PRECISION A,B
53041C
53042C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
53043C
53044 DOUBLE PRECISION P,R,S,T,U
53045 P = DMAX1(DABS(A),DABS(B))
53046 IF (P .EQ. 0.0D0) GOTO 110
53047 R = (DMIN1(DABS(A),DABS(B))/P)**2
53048 100 CONTINUE
53049 T = 4.0D0 + R
53050 IF (T .EQ. 4.0D0) GOTO 110
53051 S = R/T
53052 U = 1.0D0 + 2.0D0*S
53053 P = U*P
53054 R = (S/U)**2 * R
53055 GOTO 100
53056 110 PYTHAG = P
53057 RETURN
53058 END
53059
53060C*********************************************************************
53061
53062C...PYCBAL
53063C...Auxiliary to PYEICG
53064C
53065C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
53066C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
53067C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
53068C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
53069C
53070C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
53071C EIGENVALUES WHENEVER POSSIBLE.
53072C
53073C ON INPUT
53074C
53075C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53076C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53077C DIMENSION STATEMENT.
53078C
53079C N IS THE ORDER OF THE MATRIX.
53080C
53081C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53082C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
53083C
53084C ON OUTPUT
53085C
53086C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53087C RESPECTIVELY, OF THE BALANCED MATRIX.
53088C
53089C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
53090C ARE EQUAL TO ZERO IF
53091C (1) I IS GREATER THAN J AND
53092C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
53093C
53094C SCALE CONTAINS INFORMATION DETERMINING THE
53095C PERMUTATIONS AND SCALING FACTORS USED.
53096C
53097C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
53098C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
53099C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
53100C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
53101C SCALE(J) = P(J), FOR J = 1,...,LOW-1
53102C = D(J,J) J = LOW,...,IGH
53103C = P(J) J = IGH+1,...,N.
53104C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
53105C THEN 1 TO LOW-1.
53106C
53107C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
53108C
53109C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
53110C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
53111C K,L HAVE BEEN REVERSED.)
53112C
53113C ARITHMETIC IS REAL THROUGHOUT.
53114C
53115C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53116C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53117C
53118C THIS VERSION DATED AUGUST 1983.
53119C
53120
53121 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
53122
53123 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
53124 DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4)
53125 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
53126 LOGICAL NOCONV
53127
53128 RADIX = 16.0D0
53129C
53130 B2 = RADIX * RADIX
53131 K = 1
53132 L = N
53133 GOTO 150
53134C .......... IN-LINE PROCEDURE FOR ROW AND
53135C COLUMN EXCHANGE ..........
53136 100 SCALE(M) = J
53137 IF (J .EQ. M) GOTO 130
53138C
53139 DO 110 I = 1, L
53140 F = AR(I,J)
53141 AR(I,J) = AR(I,M)
53142 AR(I,M) = F
53143 F = AI(I,J)
53144 AI(I,J) = AI(I,M)
53145 AI(I,M) = F
53146 110 CONTINUE
53147C
53148 DO 120 I = K, N
53149 F = AR(J,I)
53150 AR(J,I) = AR(M,I)
53151 AR(M,I) = F
53152 F = AI(J,I)
53153 AI(J,I) = AI(M,I)
53154 AI(M,I) = F
53155 120 CONTINUE
53156C
53157 130 IF(IEXC.EQ.1) GOTO 140
53158 IF(IEXC.EQ.2) GOTO 180
53159C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
53160C AND PUSH THEM DOWN ..........
53161 140 IF (L .EQ. 1) GOTO 320
53162 L = L - 1
53163C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
53164 150 DO 170 JJ = 1, L
53165 J = L + 1 - JJ
53166C
53167 DO 160 I = 1, L
53168 IF (I .EQ. J) GOTO 160
53169 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
53170 160 CONTINUE
53171C
53172 M = L
53173 IEXC = 1
53174 GOTO 100
53175 170 CONTINUE
53176C
53177 GOTO 190
53178C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
53179C AND PUSH THEM LEFT ..........
53180 180 K = K + 1
53181C
53182 190 DO 210 J = K, L
53183C
53184 DO 200 I = K, L
53185 IF (I .EQ. J) GOTO 200
53186 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
53187 200 CONTINUE
53188C
53189 M = K
53190 IEXC = 2
53191 GOTO 100
53192 210 CONTINUE
53193C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
53194 DO 220 I = K, L
53195 220 SCALE(I) = 1.0D0
53196C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
53197 230 NOCONV = .FALSE.
53198C
53199 DO 310 I = K, L
53200 C = 0.0D0
53201 R = 0.0D0
53202C
53203 DO 240 J = K, L
53204 IF (J .EQ. I) GOTO 240
53205 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
53206 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
53207 240 CONTINUE
53208C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
53209 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
53210 G = R / RADIX
53211 F = 1.0D0
53212 S = C + R
53213 250 IF (C .GE. G) GOTO 260
53214 F = F * RADIX
53215 C = C * B2
53216 GOTO 250
53217 260 G = R * RADIX
53218 270 IF (C .LT. G) GOTO 280
53219 F = F / RADIX
53220 C = C / B2
53221 GOTO 270
53222C .......... NOW BALANCE ..........
53223 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
53224 G = 1.0D0 / F
53225 SCALE(I) = SCALE(I) * F
53226 NOCONV = .TRUE.
53227C
53228 DO 290 J = K, N
53229 AR(I,J) = AR(I,J) * G
53230 AI(I,J) = AI(I,J) * G
53231 290 CONTINUE
53232C
53233 DO 300 J = 1, L
53234 AR(J,I) = AR(J,I) * F
53235 AI(J,I) = AI(J,I) * F
53236 300 CONTINUE
53237C
53238 310 CONTINUE
53239C
53240 IF (NOCONV) GOTO 230
53241C
53242 320 LOW = K
53243 IGH = L
53244 RETURN
53245 END
53246
53247C*********************************************************************
53248
53249C...PYCBA2
53250C...Auxiliary to PYEICG.
53251C
53252C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
53253C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
53254C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
53255C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
53256C
53257C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
53258C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
53259C BALANCED MATRIX DETERMINED BY CBAL.
53260C
53261C ON INPUT
53262C
53263C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53264C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53265C DIMENSION STATEMENT.
53266C
53267C N IS THE ORDER OF THE MATRIX.
53268C
53269C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
53270C
53271C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
53272C AND SCALING FACTORS USED BY CBAL.
53273C
53274C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
53275C
53276C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53277C RESPECTIVELY, OF THE EIGENVECTORS TO BE
53278C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
53279C
53280C ON OUTPUT
53281C
53282C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53283C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
53284C IN THEIR FIRST M COLUMNS.
53285C
53286C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53287C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53288C
53289C THIS VERSION DATED AUGUST 1983.
53290C
53291
53292 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
53293
53294 INTEGER I,J,K,M,N,II,NM,IGH,LOW
53295 DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4)
53296 DOUBLE PRECISION S
53297
53298 IF (M .EQ. 0) GOTO 150
53299 IF (IGH .EQ. LOW) GOTO 120
53300C
53301 DO 110 I = LOW, IGH
53302 S = SCALE(I)
53303C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
53304C IF THE FOREGOING STATEMENT IS REPLACED BY
53305C S=1.0D0/SCALE(I). ..........
53306 DO 100 J = 1, M
53307 ZR(I,J) = ZR(I,J) * S
53308 ZI(I,J) = ZI(I,J) * S
53309 100 CONTINUE
53310C
53311 110 CONTINUE
53312C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
53313C IGH+1 STEP 1 UNTIL N DO -- ..........
53314 120 DO 140 II = 1, N
53315 I = II
53316 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53317 IF (I .LT. LOW) I = LOW - II
53318 K = SCALE(I)
53319 IF (K .EQ. I) GOTO 140
53320C
53321 DO 130 J = 1, M
53322 S = ZR(I,J)
53323 ZR(I,J) = ZR(K,J)
53324 ZR(K,J) = S
53325 S = ZI(I,J)
53326 ZI(I,J) = ZI(K,J)
53327 ZI(K,J) = S
53328 130 CONTINUE
53329C
53330 140 CONTINUE
53331C
53332 150 RETURN
53333 END
53334
53335C*********************************************************************
53336
53337C...PYCRTH
53338C...Auxiliary to PYEICG.
53339C
53340C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
53341C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
53342C BY MARTIN AND WILKINSON.
53343C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
53344C
53345C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
53346C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
53347C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
53348C UNITARY SIMILARITY TRANSFORMATIONS.
53349C
53350C ON INPUT
53351C
53352C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53353C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53354C DIMENSION STATEMENT.
53355C
53356C N IS THE ORDER OF THE MATRIX.
53357C
53358C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53359C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53360C SET LOW=1, IGH=N.
53361C
53362C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53363C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
53364C
53365C ON OUTPUT
53366C
53367C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53368C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
53369C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
53370C IS STORED IN THE REMAINING TRIANGLES UNDER THE
53371C HESSENBERG MATRIX.
53372C
53373C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
53374C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
53375C
53376C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53377C
53378C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53379C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53380C
53381C THIS VERSION DATED AUGUST 1983.
53382C
53383
53384 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
53385
53386 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
53387 DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4)
53388 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
53389
53390 LA = IGH - 1
53391 KP1 = LOW + 1
53392 IF (LA .LT. KP1) GOTO 210
53393C
53394 DO 200 M = KP1, LA
53395 H = 0.0D0
53396 ORTR(M) = 0.0D0
53397 ORTI(M) = 0.0D0
53398 SCALE = 0.0D0
53399C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
53400 DO 100 I = M, IGH
53401 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
53402C
53403 IF (SCALE .EQ. 0.0D0) GOTO 200
53404 MP = M + IGH
53405C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
53406 DO 110 II = M, IGH
53407 I = MP - II
53408 ORTR(I) = AR(I,M-1) / SCALE
53409 ORTI(I) = AI(I,M-1) / SCALE
53410 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
53411 110 CONTINUE
53412C
53413 G = DSQRT(H)
53414 F = PYTHAG(ORTR(M),ORTI(M))
53415 IF (F .EQ. 0.0D0) GOTO 120
53416 H = H + F * G
53417 G = G / F
53418 ORTR(M) = (1.0D0 + G) * ORTR(M)
53419 ORTI(M) = (1.0D0 + G) * ORTI(M)
53420 GOTO 130
53421C
53422 120 ORTR(M) = G
53423 AR(M,M-1) = SCALE
53424C .......... FORM (I-(U*UT)/H) * A ..........
53425 130 DO 160 J = M, N
53426 FR = 0.0D0
53427 FI = 0.0D0
53428C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
53429 DO 140 II = M, IGH
53430 I = MP - II
53431 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
53432 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
53433 140 CONTINUE
53434C
53435 FR = FR / H
53436 FI = FI / H
53437C
53438 DO 150 I = M, IGH
53439 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
53440 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
53441 150 CONTINUE
53442C
53443 160 CONTINUE
53444C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
53445 DO 190 I = 1, IGH
53446 FR = 0.0D0
53447 FI = 0.0D0
53448C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
53449 DO 170 JJ = M, IGH
53450 J = MP - JJ
53451 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
53452 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
53453 170 CONTINUE
53454C
53455 FR = FR / H
53456 FI = FI / H
53457C
53458 DO 180 J = M, IGH
53459 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
53460 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
53461 180 CONTINUE
53462C
53463 190 CONTINUE
53464C
53465 ORTR(M) = SCALE * ORTR(M)
53466 ORTI(M) = SCALE * ORTI(M)
53467 AR(M,M-1) = -G * AR(M,M-1)
53468 AI(M,M-1) = -G * AI(M,M-1)
53469 200 CONTINUE
53470C
53471 210 RETURN
53472 END
53473
53474C*********************************************************************
53475
53476C...PYLDCM
53477C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
53478C...processes.
53479
53480 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
53481 IMPLICIT NONE
53482 INTEGER N,NP,INDX(N)
53483 REAL*8 D,TINY
53484 COMPLEX*16 A(NP,NP)
53485 PARAMETER (TINY=1.0D-20)
53486 INTEGER I,IMAX,J,K
53487 REAL*8 AAMAX,VV(6),DUM
53488 COMPLEX*16 SUM,DUMC
53489
53490 D=1D0
53491 DO 110 I=1,N
53492 AAMAX=0D0
53493 DO 100 J=1,N
53494 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
53495 100 CONTINUE
53496 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
53497 VV(I)=1D0/AAMAX
53498 110 CONTINUE
53499 DO 180 J=1,N
53500 DO 130 I=1,J-1
53501 SUM=A(I,J)
53502 DO 120 K=1,I-1
53503 SUM=SUM-A(I,K)*A(K,J)
53504 120 CONTINUE
53505 A(I,J)=SUM
53506 130 CONTINUE
53507 AAMAX=0D0
53508 DO 150 I=J,N
53509 SUM=A(I,J)
53510 DO 140 K=1,J-1
53511 SUM=SUM-A(I,K)*A(K,J)
53512 140 CONTINUE
53513 A(I,J)=SUM
53514 DUM=VV(I)*ABS(SUM)
53515 IF (DUM.GE.AAMAX) THEN
53516 IMAX=I
53517 AAMAX=DUM
53518 ENDIF
53519 150 CONTINUE
53520 IF (J.NE.IMAX)THEN
53521 DO 160 K=1,N
53522 DUMC=A(IMAX,K)
53523 A(IMAX,K)=A(J,K)
53524 A(J,K)=DUMC
53525 160 CONTINUE
53526 D=-D
53527 VV(IMAX)=VV(J)
53528 ENDIF
53529 INDX(J)=IMAX
53530 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
53531 IF(J.NE.N)THEN
53532 DO 170 I=J+1,N
53533 A(I,J)=A(I,J)/A(J,J)
53534 170 CONTINUE
53535 ENDIF
53536 180 CONTINUE
53537
53538 RETURN
53539 END
53540
53541C*********************************************************************
53542
53543C...PYBKSB
53544C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
53545C...processes.
53546
53547 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
53548 IMPLICIT NONE
53549 INTEGER N,NP,INDX(N)
53550 COMPLEX*16 A(NP,NP),B(N)
53551 INTEGER I,II,J,LL
53552 COMPLEX*16 SUM
53553
53554 II=0
53555 DO 110 I=1,N
53556 LL=INDX(I)
53557 SUM=B(LL)
53558 B(LL)=B(I)
53559 IF (II.NE.0)THEN
53560 DO 100 J=II,I-1
53561 SUM=SUM-A(I,J)*B(J)
53562 100 CONTINUE
53563 ELSE IF (ABS(SUM).NE.0D0) THEN
53564 II=I
53565 ENDIF
53566 B(I)=SUM
53567 110 CONTINUE
53568 DO 130 I=N,1,-1
53569 SUM=B(I)
53570 DO 120 J=I+1,N
53571 SUM=SUM-A(I,J)*B(J)
53572 120 CONTINUE
53573 B(I)=SUM/A(I,I)
53574 130 CONTINUE
53575 RETURN
53576 END
53577
53578C***********************************************************************
53579
53580C...PYWIDX
53581C...Calculates full and partial widths of resonances.
53582C....copy of PYWIDT, used for techniparticle widths
53583
53584 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
53585
53586C...Double precision and integer declarations.
53587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53588 IMPLICIT INTEGER(I-N)
53589 INTEGER PYK,PYCHGE,PYCOMP
53590C...Parameter statement to help give large particle numbers.
53591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53592 &KEXCIT=4000000,KDIMEN=5000000)
53593C...Commonblocks.
53594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53596 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53597 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
53598 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53599 COMMON/PYINT1/MINT(400),VINT(400)
53600 COMMON/PYINT4/MWID(500),WIDS(500,5)
53601 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53602 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53603 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
53604 &/PYINT4/,/PYMSSM/,/PYTCSM/
53605C...Local arrays and saved variables.
53606 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
53607 &WID2SV(3,2)
53608 SAVE MOFSV,WIDWSV,WID2SV
53609 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
53610
53611C...Compressed code and sign; mass.
53612 KFLA=IABS(KFLR)
53613 KFLS=ISIGN(1,KFLR)
53614 KC=PYCOMP(KFLA)
53615 SHR=SQRT(SH)
53616 PMR=PMAS(KC,1)
53617
53618C...Reset width information.
53619 DO 110 I=0,200
53620 WDTP(I)=0D0
53621 DO 100 J=0,5
53622 WDTE(I,J)=0D0
53623 100 CONTINUE
53624 110 CONTINUE
53625
53626C...Common electroweak and strong constants.
53627 XW=PARU(102)
53628 XWV=XW
53629 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
53630 XW1=1D0-XW
53631 AEM=PYALEM(SH)
53632 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
53633 AS=PYALPS(SH)
53634 RADC=1D0+AS/PARU(1)
53635
53636 IF(KFLA.EQ.23) THEN
53637C...Z0:
53638 ICASE=1
53639 XWC=1D0/(16D0*XW*XW1)
53640 FAC=(AEM*XWC/3D0)*SHR
53641 120 CONTINUE
53642 DO 130 I=1,MDCY(KC,3)
53643 IDC=I+MDCY(KC,2)-1
53644 IF(MDME(IDC,1).LT.0) GOTO 130
53645 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
53646 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
53647 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
53648 WID2=1D0
53649 IF(I.LE.8) THEN
53650C...Z0 -> q + qbar
53651 EF=KCHG(I,1)/3D0
53652 AF=SIGN(1D0,EF+0.1D0)
53653 VF=AF-4D0*EF*XWV
53654 FCOF=3D0*RADC
53655 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
53656 IF(I.EQ.6) WID2=WIDS(6,1)
53657 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
53658 ELSEIF(I.LE.16) THEN
53659C...Z0 -> l+ + l-, nu + nubar
53660 EF=KCHG(I+2,1)/3D0
53661 AF=SIGN(1D0,EF+0.1D0)
53662 VF=AF-4D0*EF*XWV
53663 FCOF=1D0
53664 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
53665 ENDIF
53666 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
53667 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
53668 & BE34
53669 WDTP(0)=WDTP(0)+WDTP(I)
53670 IF(MDME(IDC,1).GT.0) THEN
53671 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
53672 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
53673 & WDTE(I,MDME(IDC,1))
53674 WDTE(I,0)=WDTE(I,MDME(IDC,1))
53675 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
53676 ENDIF
53677 130 CONTINUE
53678
53679
53680 ELSEIF(KFLA.EQ.24) THEN
53681C...W+/-:
53682 FAC=(AEM/(24D0*XW))*SHR
53683 DO 140 I=1,MDCY(KC,3)
53684 IDC=I+MDCY(KC,2)-1
53685 IF(MDME(IDC,1).LT.0) GOTO 140
53686 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
53687 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
53688 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
53689 WID2=1D0
53690 IF(I.LE.16) THEN
53691C...W+/- -> q + qbar'
53692 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
53693 IF(KFLR.GT.0) THEN
53694 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
53695 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
53696 IF(I.GE.13) WID2=WID2*WIDS(7,3)
53697 ELSE
53698 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
53699 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
53700 IF(I.GE.13) WID2=WID2*WIDS(7,2)
53701 ENDIF
53702 ELSEIF(I.LE.20) THEN
53703C...W+/- -> l+/- + nu
53704 FCOF=1D0
53705 IF(KFLR.GT.0) THEN
53706 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
53707 ELSE
53708 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
53709 ENDIF
53710 ENDIF
53711 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
53712 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
53713 WDTP(0)=WDTP(0)+WDTP(I)
53714 IF(MDME(IDC,1).GT.0) THEN
53715 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
53716 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
53717 WDTE(I,0)=WDTE(I,MDME(IDC,1))
53718 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
53719 ENDIF
53720 140 CONTINUE
53721
53722C.....V8 -> quark anti-quark
53723 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
53724 FAC=AS/6D0*SHR
53725 TANT3=RTCM(21)
53726 IF(ITCM(2).EQ.0) THEN
53727 IMDL=1
53728 ELSEIF(ITCM(2).EQ.1) THEN
53729 IMDL=2
53730 ENDIF
53731 DO 150 I=1,MDCY(KC,3)
53732 IDC=I+MDCY(KC,2)-1
53733 IF(MDME(IDC,1).LT.0) GOTO 150
53734 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
53735 RM1=PM1**2/SH
53736 IF(RM1.GT.0.25D0) GOTO 150
53737 WID2=1D0
53738 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
53739 FMIX=1D0/TANT3**2
53740 ELSE
53741 FMIX=TANT3**2
53742 ENDIF
53743 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
53744 IF(I.EQ.6) WID2=WIDS(6,1)
53745 WDTP(0)=WDTP(0)+WDTP(I)
53746 IF(MDME(IDC,1).GT.0) THEN
53747 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
53748 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
53749 WDTE(I,0)=WDTE(I,MDME(IDC,1))
53750 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
53751 ENDIF
53752 150 CONTINUE
53753 ENDIF
53754
53755 RETURN
53756 END
53757
53758C*********************************************************************
53759
53760C...PYRVSF
53761C...Calculates R-violating decays of sfermions.
53762C...P. Z. Skands
53763
53764 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
53765
53766C...Double precision and integer declarations.
53767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53768 IMPLICIT INTEGER(I-N)
53769C...Parameter statement to help give large particle numbers.
53770 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53771 &KEXCIT=4000000,KDIMEN=5000000)
53772C...Commonblocks.
53773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53774 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53775 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53776 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53777 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
53778C...Local variables.
53779 DOUBLE PRECISION XLAM(0:400)
53780 INTEGER IDLAM(400,3), PYCOMP
53781 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
53782
53783C...IS R-VIOLATION ON ?
53784 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
53785C...Mass eigenstate counter
53786 ICNT=INT(KFIN/KSUSY1)
53787C...SM KF code of SUSY particle
53788 KFSM=KFIN-ICNT*KSUSY1
53789C...Squared Sparticle Mass
53790 SM=PMAS(PYCOMP(KFIN),1)**2
53791C... Squared mass of top quark
53792 SMT=PMAS(PYCOMP(6),1)**2
53793C...IS L-VIOLATION ON ?
53794 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
53795C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
53796 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
53797 & THEN
53798 K=INT((KFSM-9)/2)
53799 DO 110 I=1,3
53800 DO 100 J=1,3
53801 IF(I.NE.J) THEN
53802C...~e,~mu,~tau -> nu_I + lepton-_J
53803 LKNT = LKNT+1
53804 IDLAM(LKNT,1)= 12 +2*(I-1)
53805 IDLAM(LKNT,2)= 11 +2*(J-1)
53806 IDLAM(LKNT,3)= 0
53807 XLAM(LKNT)=0D0
53808 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
53809 IF (IMSS(51).NE.0) XLAM(LKNT) =
53810 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53811C...KINEMATICS CHECK
53812 IF (XLAM(LKNT).EQ.0D0) THEN
53813 LKNT=LKNT-1
53814 ENDIF
53815 ENDIF
53816 100 CONTINUE
53817 110 CONTINUE
53818C...~e,~mu,~tau -> nu_Ibar + lepton-_K
53819 J=INT((KFSM-9)/2)
53820 DO 130 I=1,3
53821 IF(I.NE.J) THEN
53822 DO 120 K=1,3
53823 LKNT = LKNT+1
53824 IDLAM(LKNT,1)=-12 -2*(I-1)
53825 IDLAM(LKNT,2)= 11 +2*(K-1)
53826 IDLAM(LKNT,3)= 0
53827 XLAM(LKNT)=0D0
53828 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53829 IF (IMSS(51).NE.0) XLAM(LKNT) =
53830 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53831C...KINEMATICS CHECK
53832 IF (XLAM(LKNT).EQ.0D0) THEN
53833 LKNT=LKNT-1
53834 ENDIF
53835 120 CONTINUE
53836 ENDIF
53837 130 CONTINUE
53838C...~e,~mu,~tau -> u_Jbar + d_K
53839 I=INT((KFSM-9)/2)
53840 DO 150 J=1,3
53841 DO 140 K=1,3
53842 LKNT = LKNT+1
53843 IDLAM(LKNT,1)=-2 -2*(J-1)
53844 IDLAM(LKNT,2)= 1 +2*(K-1)
53845 IDLAM(LKNT,3)= 0
53846 XLAM(LKNT)=0
53847 IF (IMSS(52).NE.0) THEN
53848C...Use massive top quark
53849 IF (IDLAM(LKNT,1).EQ.-6) THEN
53850 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
53851 & * (SM-SMT)
53852 XLAM(LKNT) =
53853 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
53854C...If no top quark, all decay products massless
53855 ELSE
53856 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53857 XLAM(LKNT) =
53858 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53859 ENDIF
53860C...KINEMATICS CHECK
53861 IF (XLAM(LKNT).EQ.0D0) THEN
53862 LKNT=LKNT-1
53863 ENDIF
53864 ENDIF
53865 140 CONTINUE
53866 150 CONTINUE
53867 ENDIF
53868C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
53869C...No right-handed neutrinos
53870 IF(ICNT.EQ.1) THEN
53871 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
53872 J=INT((KFSM-10)/2)
53873 DO 170 I=1,3
53874 DO 160 K=1,3
53875 IF (I.NE.J) THEN
53876C...~nu_J -> lepton+_I + lepton-_K
53877 LKNT = LKNT+1
53878 IDLAM(LKNT,1)=-11 -2*(I-1)
53879 IDLAM(LKNT,2)= 11 +2*(K-1)
53880 IDLAM(LKNT,3)= 0
53881 XLAM(LKNT)=0D0
53882 RM2=RVLAM(I,J,K)**2 * SM
53883 IF (IMSS(51).NE.0) XLAM(LKNT) =
53884 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53885C...KINEMATICS CHECK
53886 IF (XLAM(LKNT).EQ.0D0) THEN
53887 LKNT=LKNT-1
53888 ENDIF
53889 ENDIF
53890 160 CONTINUE
53891 170 CONTINUE
53892C...~nu_I -> dbar_J + d_K
53893 I=INT((KFSM-10)/2)
53894 DO 190 J=1,3
53895 DO 180 K=1,3
53896 LKNT = LKNT+1
53897 IDLAM(LKNT,1)=-1 -2*(J-1)
53898 IDLAM(LKNT,2)= 1 +2*(K-1)
53899 IDLAM(LKNT,3)= 0
53900 XLAM(LKNT)=0D0
53901 RM2=3*RVLAMP(I,J,K)**2 * SM
53902 IF (IMSS(52).NE.0) XLAM(LKNT) =
53903 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53904C...KINEMATICS CHECK
53905 IF (XLAM(LKNT).EQ.0D0) THEN
53906 LKNT=LKNT-1
53907 ENDIF
53908 180 CONTINUE
53909 190 CONTINUE
53910 ENDIF
53911 ENDIF
53912C * SDOWN -> NU(BAR) + D and LEPTON- + U
53913 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
53914 J=INT((KFSM+1)/2)
53915 DO 210 I=1,3
53916 DO 200 K=1,3
53917C...~d_J -> nu_Ibar + d_K
53918 LKNT = LKNT+1
53919 IDLAM(LKNT,1)=-12 -2*(I-1)
53920 IDLAM(LKNT,2)= 1 +2*(K-1)
53921 IDLAM(LKNT,3)= 0
53922 XLAM(LKNT)=0D0
53923 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53924 IF (IMSS(52).NE.0) XLAM(LKNT) =
53925 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53926C...KINEMATICS CHECK
53927 IF (XLAM(LKNT).EQ.0D0) THEN
53928 LKNT=LKNT-1
53929 ENDIF
53930 200 CONTINUE
53931 210 CONTINUE
53932 K=INT((KFSM+1)/2)
53933 DO 240 I=1,3
53934 DO 230 J=1,3
53935C...~d_K -> nu_I + d_J
53936 LKNT = LKNT+1
53937 IDLAM(LKNT,1)= 12 +2*(I-1)
53938 IDLAM(LKNT,2)= 1 +2*(J-1)
53939 IDLAM(LKNT,3)= 0
53940 XLAM(LKNT)=0D0
53941 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
53942 IF (IMSS(52).NE.0) XLAM(LKNT) =
53943 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53944C...KINEMATICS CHECK
53945 IF (XLAM(LKNT).EQ.0D0) THEN
53946 LKNT=LKNT-1
53947 ENDIF
53948C...~d_K -> lepton_I- + u_J
53949 220 LKNT = LKNT+1
53950 IDLAM(LKNT,1)= 11 +2*(I-1)
53951 IDLAM(LKNT,2)= 2 +2*(J-1)
53952 IDLAM(LKNT,3)= 0
53953 XLAM(LKNT)=0D0
53954 IF (IMSS(52).NE.0) THEN
53955C...Use massive top quark
53956 IF (IDLAM(LKNT,2).EQ.6) THEN
53957 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
53958 XLAM(LKNT) =
53959 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
53960C...If no top quark, all decay products massless
53961 ELSE
53962 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
53963 XLAM(LKNT) =
53964 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53965 ENDIF
53966C...KINEMATICS CHECK
53967 IF (XLAM(LKNT).EQ.0D0) THEN
53968 LKNT=LKNT-1
53969 ENDIF
53970 ENDIF
53971 230 CONTINUE
53972 240 CONTINUE
53973 ENDIF
53974C * SUP -> LEPTON+ + D
53975 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
53976 J=NINT(KFSM/2.)
53977 DO 260 I=1,3
53978 DO 250 K=1,3
53979C...~u_J -> lepton_I+ + d_K
53980 LKNT = LKNT+1
53981 IDLAM(LKNT,1)=-11 -2*(I-1)
53982 IDLAM(LKNT,2)= 1 +2*(K-1)
53983 IDLAM(LKNT,3)= 0
53984 XLAM(LKNT)=0D0
53985 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
53986 IF (IMSS(52).NE.0) XLAM(LKNT) =
53987 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
53988C...KINEMATICS CHECK
53989 IF (XLAM(LKNT).EQ.0D0) THEN
53990 LKNT=LKNT-1
53991 ENDIF
53992 250 CONTINUE
53993 260 CONTINUE
53994 ENDIF
53995 ENDIF
53996C...BARYON NUMBER VIOLATING DECAYS
53997 IF (IMSS(53).GE.1) THEN
53998C * SUP -> DBAR + DBAR
53999 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
54000 I = KFSM/2
54001 DO 280 J=1,3
54002 DO 270 K=1,3
54003C...~u_I -> dbar_J + dbar_K
54004 IF (J.LT.K) THEN
54005C...(anti-) symmetry J <-> K.
54006 LKNT = LKNT + 1
54007 IDLAM(LKNT,1) = -1 -2*(J-1)
54008 IDLAM(LKNT,2) = -1 -2*(K-1)
54009 IDLAM(LKNT,3) = 0
54010 XLAM(LKNT) = 0D0
54011 RM2 = 2.*(RVLAMB(I,J,K)**2)
54012 & * SFMIX(KFSM,2*ICNT)**2 * SM
54013 XLAM(LKNT) =
54014 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54015C...KINEMATICS CHECK
54016 IF (XLAM(LKNT).EQ.0D0) THEN
54017 LKNT = LKNT-1
54018 ENDIF
54019 ENDIF
54020 270 CONTINUE
54021 280 CONTINUE
54022 ENDIF
54023C * SDOWN -> UBAR + DBAR
54024 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
54025 K=(KFSM+1)/2
54026 DO 300 I=1,3
54027 DO 290 J=1,3
54028C...LAMB coupling antisymmetric in J and K.
54029 IF (J.NE.K) THEN
54030C...~d_K -> ubar_I + dbar_K
54031 LKNT = LKNT + 1
54032 IDLAM(LKNT,1)= -2 -2*(I-1)
54033 IDLAM(LKNT,2)= -1 -2*(J-1)
54034 IDLAM(LKNT,3)= 0
54035 XLAM(LKNT)=0D0
54036C...Use massive top quark
54037 IF (IDLAM(LKNT,1).EQ.-6) THEN
54038 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
54039 & )
54040 XLAM(LKNT) =
54041 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54042C...If no top quark, all decay products massless
54043 ELSE
54044 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54045 XLAM(LKNT) =
54046 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54047 ENDIF
54048C...KINEMATICS CHECK
54049 IF (XLAM(LKNT).EQ.0D0) THEN
54050 LKNT=LKNT-1
54051 ENDIF
54052 ENDIF
54053 290 CONTINUE
54054 300 CONTINUE
54055 ENDIF
54056 ENDIF
54057 ENDIF
54058
54059 RETURN
54060 END
54061
54062C*********************************************************************
54063
54064C...PYRVNE
54065C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
54066C...P. Z. Skands
54067
54068 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
54069
54070C...Double precision and integer declarations.
54071 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54072 IMPLICIT INTEGER(I-N)
54073C...Parameter statement to help give large particle numbers.
54074 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54075 &KEXCIT=4000000,KDIMEN=5000000)
54076C...Commonblocks.
54077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54079 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54080 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54081 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54082 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54083C...Local variables.
54084 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
54085 & ,DCMASS,KFR(3)
54086 DOUBLE PRECISION XLAM(0:400)
54087 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
54088 INTEGER IDLAM(400,3), PYCOMP
54089 LOGICAL DCMASS
54090 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
54091
54092C...R-VIOLATING DECAYS
54093 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54094 KFSM=KFIN-KSUSY1
54095 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
54096C...WHICH NEUTRALINO ?
54097 NCHI=1
54098 IF (KFSM.EQ.23) NCHI=2
54099 IF (KFSM.EQ.25) NCHI=3
54100 IF (KFSM.EQ.35) NCHI=4
54101C...SIGN OF MASS (Opposite convention as HERWIG)
54102 ISM = 1
54103 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
54104
54105C...Useful parameters for the calculation of the A and B constants.
54106 WMASS = PMAS(PYCOMP(24),1)
54107 ECHG = 2*SQRT(PARU(103)*PARU(1))
54108 COSB=1/(SQRT(1+RMSS(5)**2))
54109 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
54110 COSW=SQRT(1-PARU(102))
54111 SINW=SQRT(PARU(102))
54112 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
54113C...Run quark masses to neutralino mass squared (for Higgs-type
54114C...couplings)
54115 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
54116 DO 100 I=1,6
54117 RMQ(I)=PYMRUN(I,SQMCHI)
54118 100 CONTINUE
54119C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
54120 DO 110 NCHJ=1,4
54121 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
54122 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
54123 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
54124 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
54125 110 CONTINUE
54126 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
54127 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
54128 C2=ECHG*ZPMIX(NCHI,1)
54129 C3=GW*ZPMIX(NCHI,2)/COSW
54130 EU=2D0/3D0
54131 ED=-1D0/3D0
54132C... AB(x,y,z):
54133C x=1-2 : Select A or B constant (1:A ; 2:B)
54134C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
54135C 11-16:e,nu_e,mu,...)
54136C z=1-2 : Mass eigenstate number
54137C...CALCULATE COUPLINGS
54138 DO 120 I = 11,15,2
54139 CMS=PMAS(PYCOMP(I),1)
54140C...Intermediate sleptons
54141 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
54142 & *(C2-C3*SINW**2))
54143 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
54144 & *(C2-C3*SINW**2))
54145 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
54146 & **2))
54147 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
54148 & **2))
54149C...Inermediate sneutrinos
54150 AB(1,I+1,1)=0D0
54151 AB(2,I+1,1)=5D-1*C3
54152 AB(1,I+1,2)=0D0
54153 AB(2,I+1,2)=0D0
54154C...Inermediate sdown
54155 J=I-10
54156 CMS=RMQ(J)
54157 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
54158 & *ED*(C2-C3*SINW**2))
54159 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
54160 & *ED*(C2-C3*SINW**2))
54161 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
54162 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
54163 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
54164 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
54165C...Inermediate sup
54166 J=J+1
54167 CMS=RMQ(J)
54168 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
54169 & *EU*(C2-C3*SINW**2))
54170 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
54171 & *EU*(C2-C3*SINW**2))
54172 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
54173 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
54174 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
54175 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
54176 120 CONTINUE
54177
54178 IF (IMSS(51).GE.1) THEN
54179C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
54180C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
54181C...STEP IN I,J,K USING SINGLE COUNTER
54182 DO 130 ISC=0,26
54183C...LAMBDA COUPLING ASYM IN I,J
54184 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
54185 LKNT = LKNT+1
54186 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54187 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
54188 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
54189 XLAM(LKNT) = 0D0
54190C...Set coupling, and decay product masses on/off
54191 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
54192 & ,MOD(ISC,3)+1)**2
54193 DCMASS=.FALSE.
54194 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
54195 & DCMASS = .TRUE.
54196C...Resonance KF codes (1=I,2=J,3=K)
54197 KFR(1)=-IDLAM(LKNT,1)
54198 KFR(2)=-IDLAM(LKNT,2)
54199 KFR(3)=-IDLAM(LKNT,3)
54200C...Calculate width.
54201 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54202 & IDLAM(LKNT,3),XLAM(LKNT))
54203 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54204C...Charge conjugate mode.
54205 LKNT=LKNT+1
54206 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54207 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54208 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54209 XLAM(LKNT)=XLAM(LKNT-1)
54210C...KINEMATICS CHECK
54211 IF (XLAM(LKNT).EQ.0D0) THEN
54212 LKNT=LKNT-2
54213 ENDIF
54214 ENDIF
54215 130 CONTINUE
54216 ENDIF
54217
54218 IF (IMSS(52).GE.1) THEN
54219C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
54220C * CHI0 -> NUBAR_I + DBAR_J + D_K
54221 DO 140 ISC=0,26
54222 LKNT = LKNT+1
54223 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54224 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54225 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54226 XLAM(LKNT) = 0D0
54227C...Set coupling, and decay product masses on/off
54228 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
54229 & ,MOD(ISC,3)+1)**2
54230 DCMASS=.FALSE.
54231 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
54232 & DCMASS = .TRUE.
54233C...Resonance KF codes (1=I,2=J,3=K)
54234 KFR(1)=-IDLAM(LKNT,1)
54235 KFR(2)=-IDLAM(LKNT,2)
54236 KFR(3)=-IDLAM(LKNT,3)
54237C...Calculate width.
54238 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54239 & ,XLAM(LKNT))
54240 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54241C...Charge conjugate mode.
54242 LKNT=LKNT+1
54243 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54244 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54245 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54246 XLAM(LKNT)=XLAM(LKNT-1)
54247C...KINEMATICS CHECK
54248 IF (XLAM(LKNT).EQ.0D0) THEN
54249 LKNT=LKNT-2
54250 ENDIF
54251
54252C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
54253 LKNT = LKNT+1
54254 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54255 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
54256 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54257 XLAM(LKNT) = 0D0
54258C...Set coupling, and decay product masses on/off
54259 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
54260 & ,MOD(ISC,3)+1)**2
54261 DCMASS=.FALSE.
54262 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
54263 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
54264C...Resonance KF codes (1=I,2=J,3=K)
54265 KFR(1)=-IDLAM(LKNT,1)
54266 KFR(2)=-IDLAM(LKNT,2)
54267 KFR(3)=-IDLAM(LKNT,3)
54268C...Calculate width.
54269 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54270 & ,XLAM(LKNT))
54271 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54272C...Charge conjugate mode.
54273 LKNT=LKNT+1
54274 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54275 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54276 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54277 XLAM(LKNT)=XLAM(LKNT-1)
54278C...KINEMATICS CHECK
54279 IF (XLAM(LKNT).EQ.0D0) THEN
54280 LKNT=LKNT-2
54281 ENDIF
54282 140 CONTINUE
54283 ENDIF
54284
54285 IF (IMSS(53).GE.1) THEN
54286C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
54287C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
54288 DO 150 ISC=0,26
54289C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
54290 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
54291 LKNT = LKNT+1
54292 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
54293 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54294 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54295 XLAM(LKNT) = 0D0
54296C...Set coupling, and decay product masses on/off
54297 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
54298 & +1,MOD(ISC,3)+1)**2
54299 DCMASS=.FALSE.
54300 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
54301 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
54302C...Resonance KF codes (1=I,2=J,3=K)
54303 KFR(1) = IDLAM(LKNT,1)
54304 KFR(2) = IDLAM(LKNT,2)
54305 KFR(3) = IDLAM(LKNT,3)
54306C...Calculate width.
54307 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54308 & IDLAM(LKNT,3),XLAM(LKNT))
54309 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54310C...Charge conjugate mode.
54311 LKNT=LKNT+1
54312 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
54313 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
54314 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
54315 XLAM(LKNT)=XLAM(LKNT-1)
54316C...KINEMATICS CHECK
54317 IF (XLAM(LKNT).EQ.0D0) THEN
54318 LKNT=LKNT-2
54319 ENDIF
54320 ENDIF
54321 150 CONTINUE
54322 ENDIF
54323 ENDIF
54324 ENDIF
54325
54326 RETURN
54327 END
54328
54329C*********************************************************************
54330
54331C...PYRVCH
54332C...Calculates R-violating chargino decay widths.
54333C...P. Z. Skands
54334
54335 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
54336
54337C...Double precision and integer declarations.
54338 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54339 IMPLICIT INTEGER(I-N)
54340C...Parameter statement to help give large particle numbers.
54341 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54342 &KEXCIT=4000000,KDIMEN=5000000)
54343C...Commonblocks.
54344 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54345 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54346 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54347 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54348 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54349 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54350C...Local variables.
54351 DOUBLE PRECISION XLAM(0:400)
54352 INTEGER IDLAM(400,3), PYCOMP
54353C...Information from main routine to PYRVGW
54354 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
54355 & ,DCMASS,KFR(3)
54356C...Auxiliary variables needed for BV (RV Gauge STOre)
54357 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
54358 & ,RVLJKI,RVLJIK
54359C...Running quark masses
54360 DOUBLE PRECISION RMQ(6)
54361C...Decay product masses on/off
54362 LOGICAL DCMASS
54363 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
54364 & /RVGSTO/
54365
54366
54367C...IF R-VIOLATION ON.
54368 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54369 KFSM=KFIN-KSUSY1
54370 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
54371C...WHICH CHARGINO ?
54372 NCHI = 1
54373 IF (KFSM.EQ.37) NCHI = 2
54374
54375C...Useful parameters for calculating the A and B constants.
54376C...SIGN OF MASS (Opposite convention as HERWIG)
54377 ISM = 1
54378 IF (SMW(NCHI).LT.0D0) ISM = -1
54379 WMASS = PMAS(PYCOMP(24),1)
54380 COSB = 1/(SQRT(1+RMSS(5)**2))
54381 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
54382 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
54383 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
54384 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
54385 C2 = UMIX(NCHI,1)
54386 C3 = VMIX(NCHI,1)
54387C...Running masses at Q^2=MCHI^2.
54388 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
54389 DO 100 I=1,6
54390 RMQ(I)=PYMRUN(I,SQMCHI)
54391 100 CONTINUE
54392
54393C... AB(x,y,z) coefficients:
54394C x=1-2 : A or B coefficient (1:A ; 2:B)
54395C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
54396C 11-16:e,nu_e,mu,...)
54397C z=1-2 : Mass eigenstate number
54398 DO 110 I = 11,15,2
54399C...Intermediate sleptons
54400 AB(1,I,1) = 0D0
54401 AB(1,I,2) = 0D0
54402 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
54403 & SFMIX(I,1)*C2
54404 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
54405 & SFMIX(I,3)*C2
54406C...Intermediate sneutrinos
54407 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
54408 AB(1,I+1,2) = 0D0
54409 AB(2,I+1,1) = ISM*C3
54410 AB(2,I+1,2) = 0D0
54411C...Intermediate sdown
54412 J=I-10
54413 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
54414 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
54415 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
54416 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
54417C...Intermediate sup
54418 J=J+1
54419 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
54420 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
54421 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
54422 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
54423 110 CONTINUE
54424
54425C...LLE TYPE R-VIOLATION
54426 IF (IMSS(51).GE.1) THEN
54427C...LOOP OVER DECAY MODES
54428 DO 140 ISC=0,26
54429
54430C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
54431 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
54432 LKNT = LKNT+1
54433 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
54434 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
54435 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
54436 XLAM(LKNT) = 0D0
54437C...Set coupling, and decay product masses on/off
54438 RVLAMC = GW2 * 5D-1 *
54439 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
54440 & **2
54441 DCMASS=.FALSE.
54442 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
54443C...Resonance KF codes (1=I,2=J,3=K).
54444 KFR(1) = 0
54445 KFR(2) = 0
54446 KFR(3) = -IDLAM(LKNT,3)+1
54447C...Calculate width.
54448 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54449 & IDLAM(LKNT,3),XLAM(LKNT))
54450 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54451C...KINEMATICS CHECK
54452 IF (XLAM(LKNT).EQ.0D0) THEN
54453 LKNT=LKNT-1
54454 ENDIF
54455
54456C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
54457 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
54458 LKNT = LKNT+1
54459 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
54460 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
54461 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
54462 XLAM(LKNT) = 0D0
54463C...Set coupling, and decay product masses on/off
54464 RVLAMC = GW2 * 5D-1 *
54465 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54466C...I,J SYMMETRY => FACTOR 2
54467 RVLAMC=2*RVLAMC
54468 DCMASS=.FALSE.
54469 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
54470C...Resonance KF codes (1=I,2=J,3=K)
54471 KFR(1)=IDLAM(LKNT,1)-1
54472 KFR(2)=IDLAM(LKNT,2)-1
54473 KFR(3)=0
54474C...Calculate width.
54475 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54476 & IDLAM(LKNT,3),XLAM(LKNT))
54477 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54478C...KINEMATICS CHECK
54479 IF (XLAM(LKNT).EQ.0D0) THEN
54480 LKNT=LKNT-1
54481 ENDIF
54482 130 ENDIF
54483
54484C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
54485 LKNT = LKNT+1
54486 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54487 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
54488 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
54489 XLAM(LKNT) = 0D0
54490C...Set coupling, and decay product masses on/off
54491 RVLAMC = GW2 * 5D-1 *
54492 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54493C...I,J SYMMETRY => FACTOR 2
54494 RVLAMC=2*RVLAMC
54495 DCMASS=.FALSE.
54496 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
54497 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
54498C...Resonance KF codes (1=I,2=J,3=K)
54499 KFR(1) =-IDLAM(LKNT,1)+1
54500 KFR(2) =-IDLAM(LKNT,2)+1
54501 KFR(3) = 0
54502C...Calculate width.
54503 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54504 & IDLAM(LKNT,3),XLAM(LKNT))
54505 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54506C...KINEMATICS CHECK
54507 IF (XLAM(LKNT).EQ.0D0) THEN
54508 LKNT=LKNT-1
54509 ENDIF
54510 ENDIF
54511 140 CONTINUE
54512 ENDIF
54513
54514C...LQD TYPE R-VIOLATION
54515 IF (IMSS(52).GE.1) THEN
54516C...LOOP OVER DECAY MODES
54517 DO 180 ISC=0,26
54518
54519C...CHI+ -> NUBAR_I + DBAR_J + U_K
54520 LKNT = LKNT+1
54521 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54522 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54523 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
54524 XLAM(LKNT) = 0D0
54525C...Set coupling, and decay product masses on/off
54526 RVLAMC = 3. * GW2 * 5D-1 *
54527 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54528 DCMASS=.FALSE.
54529 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
54530 & DCMASS = .TRUE.
54531C...Resonance KF codes (1=I,2=J,3=K)
54532 KFR(1)=0
54533 KFR(2)=0
54534 KFR(3)=-IDLAM(LKNT,3)+1
54535C...Calculate width.
54536 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54537 & ,XLAM(LKNT))
54538 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54539C...KINEMATICS CHECK
54540 IF (XLAM(LKNT).EQ.0D0) THEN
54541 LKNT=LKNT-1
54542 ENDIF
54543
54544C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
54545 150 LKNT = LKNT+1
54546 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54547 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
54548 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
54549 XLAM(LKNT) = 0D0
54550C...Set coupling, and decay product masses on/off
54551 RVLAMC = 3. * GW2 * 5D-1 *
54552 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54553 DCMASS=.FALSE.
54554 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
54555 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
54556C...Resonance KF codes (1=I,2=J,3=K)
54557 KFR(1)=0
54558 KFR(2)=0
54559 KFR(3)=-IDLAM(LKNT,3)+1
54560C...Calculate width.
54561 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54562 & ,XLAM(LKNT))
54563 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54564C...KINEMATICS CHECK
54565 IF (XLAM(LKNT).EQ.0D0) THEN
54566 LKNT=LKNT-1
54567 ENDIF
54568
54569C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
54570 160 LKNT = LKNT+1
54571 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54572 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54573 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54574 XLAM(LKNT) = 0D0
54575C...Set coupling, and decay product masses on/off
54576 RVLAMC = 3. * GW2 * 5D-1 *
54577 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54578 DCMASS = .FALSE.
54579 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
54580 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
54581C...Resonance KF codes (1=I,2=J,3=K)
54582 KFR(1)=-IDLAM(LKNT,1)+1
54583 KFR(2)=-IDLAM(LKNT,2)+1
54584 KFR(3)=0
54585C...Calculate width.
54586 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54587 & ,XLAM(LKNT))
54588 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54589C...KINEMATICS CHECK
54590 IF (XLAM(LKNT).EQ.0D0) THEN
54591 LKNT=LKNT-1
54592 ENDIF
54593
54594C * CHI+ -> NU_I + U_J + DBAR_K.
54595 170 LKNT = LKNT+1
54596 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
54597 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
54598 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54599 XLAM(LKNT) = 0D0
54600C...Set coupling, and decay product masses on/off
54601 DCMASS = .FALSE.
54602 RVLAMC = 3. * GW2 * 5D-1 *
54603 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54604 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
54605 & DCMASS = .TRUE.
54606C...Resonance KF codes (1=I,2=J,3=K)
54607 KFR(1)=IDLAM(LKNT,1)-1
54608 KFR(2)=IDLAM(LKNT,2)-1
54609 KFR(3)=0
54610C...Calculate width.
54611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54612 & ,XLAM(LKNT))
54613 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54614C...KINEMATICS CHECK
54615 IF (XLAM(LKNT).EQ.0D0) THEN
54616 LKNT=LKNT-1
54617 ENDIF
54618
54619 180 CONTINUE
54620 ENDIF
54621
54622C...UDD TYPE R-VIOLATION
54623C...These decays need special treatment since more than one BV coupling
54624C...contributes (with interference). Consider e.g. (symbolically)
54625C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
54626C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
54627C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
54628C...The problem is that a single call to PYRVGW would evaluate all
54629C...these terms and sum them, but without the different couplings. The
54630C...way out is to call PYRVGW three times, once for the first line, once
54631C...for the second line, and then once for all the lines (it is
54632C...impossible to get just the last line out) without multiplying by
54633C...couplings. The last line is then obtained as the result of the third
54634C...call minus the results of the two first calls. Each term is then
54635C...multiplied by its respective coupling before the whole thing is
54636C...summed up in XLAM.
54637C...Note that with three interfering resonances, this procedure becomes
54638C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
54639
54640 IF (IMSS(53).GE.1) THEN
54641C...LOOP OVER DECAY MODES
54642 DO 190 ISC=1,25
54643
54644C...CHI+ -> U_I + U_J + D_K
54645C...Decay mode I<->J symmetric.
54646 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
54647 LKNT = LKNT+1
54648 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
54649 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
54650 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54651 XLAM(LKNT) = 0D0
54652C...Set coupling, and decay product masses on/off
54653 RVLAMC= 6. * GW2 * 5D-1
54654 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
54655 & +1)
54656 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
54657 & +1)
54658 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
54659 & * RVLAMC
54660 DCMASS=.FALSE.
54661 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
54662 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
54663C...Resonance KF codes (1=I,2=J,3=K)
54664 KFR(1) = -IDLAM(LKNT,1)+1
54665 KFR(2) = 0
54666 KFR(3) = 0
54667C...Calculate width.
54668 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54669 & IDLAM(LKNT,3),XRESI)
54670C...Resonance KF codes (1=I,2=J,3=K)
54671 KFR(1) = 0
54672 KFR(2) = -IDLAM(LKNT,2)+1
54673 KFR(3) = 0
54674C...Calculate width.
54675 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54676 & IDLAM(LKNT,3),XRESJ)
54677C...Resonance KF codes (1=I,2=J,3=K)
54678 KFR(1) = -IDLAM(LKNT,1)+1
54679 KFR(2) = -IDLAM(LKNT,2)+1
54680 KFR(3) = 0
54681C...Calculate width.
54682 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54683 & IDLAM(LKNT,3),XRESIJ)
54684 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
54685 XRESIJ = XRESIJ-XRESI-XRESJ
54686 ELSE
54687 XRESIJ = 0D0
54688 ENDIF
54689C...CALCULATE TOTAL WIDTH
54690 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
54691 & + RVLJIK*RVLIJK * XRESIJ
54692 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54693C...KINEMATICS CHECK
54694 IF (XLAM(LKNT).EQ.0D0) THEN
54695 LKNT=LKNT-1
54696 ENDIF
54697 ENDIF
54698C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
54699C...Symmetry I<->J<->K.
54700 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
54701 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
54702 LKNT = LKNT+1
54703 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
54704 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54705 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54706 XLAM(LKNT) = 0D0
54707C...Set coupling, and decay product masses on/off
54708 RVLAMC = 6. * GW2 * 5D-1
54709 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
54710 & +1)
54711 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
54712 & +1)
54713 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
54714 & +1)
54715 DCMASS = .FALSE.
54716 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
54717 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
54718C...Collect symmetry factors
54719 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
54720 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
54721 & RVLAMC = 5D-1 * RVLAMC
54722C...Resonance KF codes (1=I,2=J,3=K)
54723 KFR(1) = IDLAM(LKNT,1)-1
54724 KFR(2) = 0
54725 KFR(3) = 0
54726C...Calculate width.
54727 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54728 & IDLAM(LKNT,3),XRESI)
54729C...Resonance KF codes (1=I,2=J,3=K)
54730 KFR(1) = 0
54731 KFR(2) = IDLAM(LKNT,2)-1
54732 KFR(3) = 0
54733C...Calculate width.
54734 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54735 & IDLAM(LKNT,3),XRESJ)
54736C...Resonance KF codes (1=I,2=J,3=K)
54737 KFR(1) = 0
54738 KFR(2) = 0
54739 KFR(3) = IDLAM(LKNT,3)-1
54740C...Calculate width.
54741 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54742 & IDLAM(LKNT,3),XRESK)
54743C...Resonance KF codes (1=I,2=J,3=K)
54744 KFR(1) = IDLAM(LKNT,1)-1
54745 KFR(2) = IDLAM(LKNT,2)-1
54746 KFR(3) = 0
54747C...Calculate width.
54748 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54749 & IDLAM(LKNT,3),XRESIJ)
54750 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
54751 XRESIJ = XRESI+XRESJ-XRESIJ
54752 ELSE
54753 XRESIJ = 0D0
54754 ENDIF
54755C...Resonance KF codes (1=I,2=J,3=K)
54756 KFR(1) = 0
54757 KFR(2) = IDLAM(LKNT,2)-1
54758 KFR(3) = IDLAM(LKNT,3)-1
54759C...Calculate width.
54760 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54761 & IDLAM(LKNT,3),XRESJK)
54762 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
54763 XRESJK = XRESJ+XRESK-XRESJK
54764 ELSE
54765 XRESJK = 0D0
54766 ENDIF
54767C...Resonance KF codes (1=I,2=J,3=K)
54768 KFR(1) = IDLAM(LKNT,1)-1
54769 KFR(2) = 0
54770 KFR(3) = IDLAM(LKNT,3)-1
54771C...Calculate width.
54772 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
54773 & IDLAM(LKNT,3),XRESIK)
54774 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
54775 XRESIK = XRESI+XRESK-XRESIK
54776 ELSE
54777 XRESIK = 0D0
54778 ENDIF
54779C...CALCULATE TOTAL WIDTH
54780 XLAM(LKNT) =
54781 & RVLIJK**2 * XRESI
54782 & + RVLJKI**2 * XRESJ
54783 & + RVLKIJ**2 * XRESK
54784 & + RVLIJK*RVLJKI * XRESIJ
54785 & + RVLIJK*RVLKIJ * XRESIK
54786 & + RVLJKI*RVLKIJ * XRESJK
54787 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
54788C...KINEMATICS CHECK
54789 IF (XLAM(LKNT).EQ.0D0) THEN
54790 LKNT=LKNT-1
54791 ENDIF
54792 ENDIF
54793 190 CONTINUE
54794 ENDIF
54795 ENDIF
54796 ENDIF
54797
54798 RETURN
54799 END
54800
54801C*********************************************************************
54802
54803C...PYRVGL
54804C...Calculates R-violating gluino decay widths.
54805C...See BV part of PYRVCH for comments about the way the BV decay width
54806C...is calculated. Same comments apply here.
54807C...P. Z. Skands
54808
54809 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
54810
54811C...Double precision and integer declarations.
54812 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54813 IMPLICIT INTEGER(I-N)
54814C...Parameter statement to help give large particle numbers.
54815 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54816 &KEXCIT=4000000,KDIMEN=5000000)
54817C...Commonblocks.
54818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54820 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54821 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54822 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54823 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54824C...Local variables.
54825 DOUBLE PRECISION XLAM(0:400)
54826 INTEGER IDLAM(400,3), PYCOMP
54827C...Information from main routine to PYRVGW
54828 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
54829 & ,DCMASS,KFR(3)
54830C...Auxiliary variables needed for BV (RV Gauge STOre)
54831 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
54832 & ,RVLJKI,RVLJIK
54833C...Running quark masses
54834 DOUBLE PRECISION RMQ(6)
54835C...Decay product masses on/off
54836 LOGICAL DCMASS
54837 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
54838 & /RVGSTO/
54839
54840C...IF LQD OR UDD TYPE R-VIOLATION ON.
54841 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
54842 KFSM=KFIN-KSUSY1
54843
54844C... AB(x,y,z):
54845C x=1-2 : Select A or B coupling (1:A ; 2:B)
54846C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
54847C 11-16:e,nu_e,mu,... not used here)
54848C z=1-2 : Mass eigenstate number
54849 DO 100 I = 1,6
54850C...A Couplings
54851 AB(1,I,1) = SFMIX(I,2)
54852 AB(1,I,2) = SFMIX(I,4)
54853C...B Couplings
54854 AB(2,I,1) = -SFMIX(I,1)
54855 AB(2,I,2) = -SFMIX(I,3)
54856 100 CONTINUE
54857 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
54858C...LQD DECAYS.
54859 IF (IMSS(52).GE.1) THEN
54860C...STEP IN I,J,K USING SINGLE COUNTER
54861 DO 120 ISC=0,26
54862C * GLUINO -> NUBAR_I + DBAR_J + D_K.
54863 LKNT = LKNT+1
54864 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
54865 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54866 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54867 XLAM(LKNT)=0D0
54868C...Set coupling, and decay product masses on/off
54869 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
54870 & * 5D-1 * GSTR2
54871 DCMASS = .FALSE.
54872 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
54873C...Resonance KF codes (1=I,2=J,3=K)
54874 KFR(1) = 0
54875 KFR(2) = -IDLAM(LKNT,2)
54876 KFR(3) = -IDLAM(LKNT,3)
54877C...Calculate width.
54878 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54879 & ,XLAM(LKNT))
54880C...Normalize
54881 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54882C...Charge conjugate mode.
54883 110 LKNT = LKNT+1
54884 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
54885 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
54886 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
54887 XLAM(LKNT) = XLAM(LKNT-1)
54888C...KINEMATICS CHECK
54889 IF (XLAM(LKNT).EQ.0D0) THEN
54890 LKNT=LKNT-2
54891 ENDIF
54892
54893C * GLUINO -> LEPTON+_I + UBAR_J + D_K
54894 LKNT = LKNT+1
54895 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
54896 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
54897 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
54898 XLAM(LKNT)=0D0
54899C...Set coupling, and decay product masses on/off
54900 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
54901 & **2* 5D-1 * GSTR2
54902 DCMASS = .FALSE.
54903 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
54904 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
54905C...Resonance KF codes (1=I,2=J,3=K)
54906 KFR(1) = 0
54907 KFR(2) = -IDLAM(LKNT,2)
54908 KFR(3) = -IDLAM(LKNT,3)
54909C...Calculate width.
54910 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54911 & ,XLAM(LKNT))
54912 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
54913C...Charge conjugate mode.
54914 LKNT=LKNT+1
54915 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
54916 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
54917 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
54918 XLAM(LKNT) = XLAM(LKNT-1)
54919C...KINEMATICS CHECK
54920 IF (XLAM(LKNT).EQ.0D0) THEN
54921 LKNT=LKNT-2
54922 ENDIF
54923
54924 120 CONTINUE
54925 ENDIF
54926
54927C...UDD DECAYS.
54928 IF (IMSS(53).GE.1) THEN
54929C...STEP IN I,J,K USING SINGLE COUNTER
54930 DO 130 ISC=0,26
54931C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
54932 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
54933 LKNT = LKNT+1
54934 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
54935 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
54936 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
54937 XLAM(LKNT)=0D0
54938C...Set coupling, and decay product masses on/off. A factor of 2 for
54939C...(N_C-1) has been used to cancel a factor 0.5.
54940 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
54941 & **2 * GSTR2
54942 DCMASS = .FALSE.
54943 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
54944 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
54945C...Resonance KF codes (1=I,2=J,3=K)
54946 KFR(1) = IDLAM(LKNT,1)
54947 KFR(2) = 0
54948 KFR(3) = 0
54949C...Calculate width.
54950 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54951 & ,XRESI)
54952C...Resonance KF codes (1=I,2=J,3=K)
54953 KFR(1) = 0
54954 KFR(2) = IDLAM(LKNT,2)
54955 KFR(3) = 0
54956C...Calculate width.
54957 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54958 & ,XRESJ)
54959C...Resonance KF codes (1=I,2=J,3=K)
54960 KFR(1) = 0
54961 KFR(2) = 0
54962 KFR(3) = IDLAM(LKNT,3)
54963C...Calculate width.
54964 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54965 & ,XRESK)
54966C...Resonance KF codes (1=I,2=J,3=K)
54967 KFR(1) = IDLAM(LKNT,1)
54968 KFR(2) = IDLAM(LKNT,2)
54969 KFR(3) = 0
54970C...Calculate width.
54971 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54972 & ,XRESIJ)
54973C...Calculate interference function. (Factor -1/2 to make up for factor
54974C...-2 in PYRVGW.
54975 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
54976 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
54977 ELSE
54978 XRESIJ = 0D0
54979 ENDIF
54980C...Resonance KF codes (1=I,2=J,3=K)
54981 KFR(1) = 0
54982 KFR(2) = IDLAM(LKNT,2)
54983 KFR(3) = IDLAM(LKNT,3)
54984C...Calculate width.
54985 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54986 & ,XRESJK)
54987 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
54988 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
54989 ELSE
54990 XRESJK = 0D0
54991 ENDIF
54992C...Resonance KF codes (1=I,2=J,3=K)
54993 KFR(1) = IDLAM(LKNT,1)
54994 KFR(2) = 0
54995 KFR(3) = IDLAM(LKNT,3)
54996C...Calculate width.
54997 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
54998 & ,XRESIK)
54999 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
55000 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
55001 ELSE
55002 XRESIK = 0D0
55003 ENDIF
55004C...Calculate total width (factor 1/2 from 1/(N_C-1))
55005 XLAM(LKNT) = XRESI + XRESJ + XRESK
55006 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
55007C...Normalize
55008 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55009C...Charge conjugate mode.
55010 LKNT = LKNT+1
55011 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
55012 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
55013 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
55014 XLAM(LKNT) = XLAM(LKNT-1)
55015C...KINEMATICS CHECK
55016 IF (XLAM(LKNT).EQ.0D0) THEN
55017 LKNT=LKNT-2
55018 ENDIF
55019 ENDIF
55020 130 CONTINUE
55021 ENDIF
55022 ENDIF
55023 RETURN
55024 END
55025
55026C*********************************************************************
55027
55028C...PYRVSB
55029C...Auxiliary function to PYRVSF for calculating R-Violating
55030C...sfermion widths. Though the decay products are most often treated
55031C...as massless in the calculation, the kinematical boundary of phase
55032C...space is tested using the true masses.
55033C...MODE = 1: All decay products massive
55034C...MODE = 2: Decay product 1 massless
55035C...MODE = 3: Decay product 2 massless
55036C...MODE = 4: All decay products massless
55037
55038 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
55039
55040 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55041 IMPLICIT INTEGER (I-N)
55042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55043 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55044 SAVE /PYDAT1/,/PYDAT2/
55045 DOUBLE PRECISION SM(3)
55046 INTEGER PYCOMP, KC(3)
55047 KC(1)=PYCOMP(KFIN)
55048 KC(2)=PYCOMP(ID1)
55049 KC(3)=PYCOMP(ID2)
55050 SM(1)=PMAS(KC(1),1)**2
55051 SM(2)=PMAS(KC(2),1)**2
55052 SM(3)=PMAS(KC(3),1)**2
55053C...Kinematics check
55054 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
55055 PYRVSB=0D0
55056 RETURN
55057 ENDIF
55058C...CM momenta squared
55059 IF (MODE.EQ.1) THEN
55060 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
55061 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
55062 ELSE IF (MODE.EQ.2) THEN
55063 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
55064 ELSE IF (MODE.EQ.3) THEN
55065 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
55066 ELSE
55067 P2CM=SM(1)/4.
55068 ENDIF
55069C...Calculate Width
55070 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
55071 RETURN
55072 END
55073
55074C*********************************************************************
55075
55076C...PYRVGW
55077C...Generalized Matrix Element for R-Violating 3-body widths.
55078C...P. Z. Skands
55079 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
55080
55081 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55082 IMPLICIT INTEGER (I-N)
55083 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55084 &KEXCIT=4000000,KDIMEN=5000000)
55085 PARAMETER (EPS=1D-4)
55086 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55087 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55088 & ,DCMASS,KFR(3)
55089 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55090 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55091 DOUBLE PRECISION XLIM(3,3)
55092 INTEGER KC(0:3), PYCOMP
55093 LOGICAL DCMASS, DCHECK(6)
55094 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
55095
55096 XLAM = 0D0
55097
55098 KC(0) = PYCOMP(KFIN)
55099 KC(1) = PYCOMP(ID1)
55100 KC(2) = PYCOMP(ID2)
55101 KC(3) = PYCOMP(ID3)
55102 RMS(0) = PMAS(KC(0),1)
55103 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
55104 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
55105 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
55106C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
55107 XLIM(1,1)=(RMS(1)+RMS(2))**2
55108 XLIM(1,2)=(RMS(0)-RMS(3))**2
55109 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
55110 XLIM(2,1)=(RMS(2)+RMS(3))**2
55111 XLIM(2,2)=(RMS(0)-RMS(1))**2
55112 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
55113 XLIM(3,1)=(RMS(1)+RMS(3))**2
55114 XLIM(3,2)=(RMS(0)-RMS(2))**2
55115 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
55116C...Check Phase Space
55117 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
55118 RETURN
55119 ENDIF
55120
55121C...INITIALIZE RESONANCE INFORMATION
55122 DO 110 JRES = 1,3
55123 DO 100 IMASS = 1,2
55124 IRES = 2*(JRES-1)+IMASS
55125 INTRES(IRES,1) = 0
55126 DCHECK(IRES) =.FALSE.
55127C...NO RIGHT-HANDED NEUTRINOS
55128 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
55129 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
55130 & .KFR(JRES).EQ.0) GOTO 100
55131 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
55132 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
55133 INTRES(IRES,1) = IABS(KFR(JRES))
55134 INTRES(IRES,2) = IMASS
55135 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
55136 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
55137 100 CONTINUE
55138 110 CONTINUE
55139
55140C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
55141
55142C...RESONANCE CONTRIBUTIONS
55143C...(Only sum contributions where the resonance is off shell).
55144C...Store whether diagram on/off in DCHECK.
55145C...LOOP OVER MASS STATES
55146 DO 120 J=1,2
55147 IDR=J
55148 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
55149 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
55150 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
55151 DCHECK(IDR) =.TRUE.
55152 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
55153 ENDIF
55154
55155 IDR=J+2
55156 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
55157 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
55158 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
55159 DCHECK(IDR) =.TRUE.
55160 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
55161 ENDIF
55162
55163 IDR=J+4
55164 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
55165 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
55166 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
55167 DCHECK(IDR) =.TRUE.
55168 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
55169 ENDIF
55170 120 CONTINUE
55171C... L-R INTERFERENCES
55172C... (Only add contributions where both contributing diagrams
55173C... are non-resonant).
55174 IDR=1
55175 IF (DCHECK(1).AND.DCHECK(2)) THEN
55176C...Bug corrected 11/12 2001. Skands.
55177 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
55178 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
55179 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
55180 ENDIF
55181
55182 IDR=3
55183 IF (DCHECK(3).AND.DCHECK(4)) THEN
55184 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
55185 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
55186 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
55187 ENDIF
55188
55189 IDR=5
55190 IF (DCHECK(5).AND.DCHECK(6)) THEN
55191 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
55192 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
55193 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
55194 ENDIF
55195C... TRUE INTERFERENCES
55196C... (Only add contributions where both contributing diagrams
55197C... are non-resonant).
55198 PREF=-2D0
55199 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
55200 DO 140 IKR1 = 1,2
55201 DO 130 IKR2 = 1,2
55202 IDR = IKR1+2
55203 IDR2 = IKR2
55204 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
55205 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
55206 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
55207 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
55208 ENDIF
55209
55210 IDR = IKR1+4
55211 IDR2 = IKR2
55212 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
55213 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
55214 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
55215 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
55216 ENDIF
55217
55218 IDR = IKR1+4
55219 IDR2 = IKR2+2
55220 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
55221 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
55222 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
55223 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
55224 ENDIF
55225 130 CONTINUE
55226 140 CONTINUE
55227
55228 RETURN
55229 END
55230
55231C*********************************************************************
55232
55233C...PYRVI1
55234C...Function to integrate resonance contributions
55235
55236 FUNCTION PYRVI1(ID1,ID2,ID3)
55237
55238 IMPLICIT NONE
55239 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
55240 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
55241 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
55242 LOGICAL MFLAG,DCMASS
55243 EXTERNAL PYRVG1,PYGAUS
55244 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55245 & ,DCMASS,KFR(3)
55246 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55247 SAVE/PYRVNV/,/PYRVPM/
55248C...Initialize mass and width information
55249 PYRVI1 = 0D0
55250 RM(0) = RMS(0)
55251 RM(1) = RMS(ID1)
55252 RM(2) = RMS(ID2)
55253 RM(3) = RMS(ID3)
55254 RESM(1)= RES(IDR,1)
55255 RESW(1)= RES(IDR,2)
55256C...A->B and B->A for antisparticles
55257 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55258 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55259C...Integration boundaries and mass flag
55260 LO = (RM(1)+RM(2))**2
55261 HI = (RM(0)-RM(3))**2
55262 MFLAG = DCMASS
55263 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
55264 RETURN
55265 END
55266
55267C*********************************************************************
55268
55269C...PYRVI2
55270C...Function to integrate L-R interference contributions
55271
55272 FUNCTION PYRVI2(ID1,ID2,ID3)
55273
55274 IMPLICIT NONE
55275 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
55276 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
55277 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
55278 LOGICAL MFLAG,DCMASS
55279 EXTERNAL PYRVG2,PYGAUS
55280 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55281 & ,DCMASS,KFR(3)
55282 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55283 SAVE/PYRVNV/,/PYRVPM/
55284C...Initialize mass and width information
55285 PYRVI2 = 0D0
55286 RM(0) = RMS(0)
55287 RM(1) = RMS(ID1)
55288 RM(2) = RMS(ID2)
55289 RM(3) = RMS(ID3)
55290 RESM(1)= RES(IDR,1)
55291 RESW(1)= RES(IDR,2)
55292 RESM(2)= RES(IDR+1,1)
55293 RESW(2)= RES(IDR+1,2)
55294C...A->B and B->A for antisparticles
55295 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55296 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55297 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
55298 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
55299C...Boundaries and mass flag
55300 LO = (RM(1)+RM(2))**2
55301 HI = (RM(0)-RM(3))**2
55302 MFLAG = DCMASS
55303 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
55304 RETURN
55305 END
55306
55307C*********************************************************************
55308
55309C...PYRVI3
55310C...Function to integrate true interference contributions
55311
55312 FUNCTION PYRVI3(ID1,ID2,ID3)
55313
55314 IMPLICIT NONE
55315 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
55316 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
55317 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
55318 LOGICAL MFLAG,DCMASS
55319 EXTERNAL PYRVG3,PYGAUS
55320 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55321 & ,DCMASS,KFR(3)
55322 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55323 SAVE/PYRVNV/,/PYRVPM/
55324C...Initialize mass and width information
55325 PYRVI3 = 0D0
55326 RM(0) = RMS(0)
55327 RM(1) = RMS(ID1)
55328 RM(2) = RMS(ID2)
55329 RM(3) = RMS(ID3)
55330 RESM(1)= RES(IDR,1)
55331 RESW(1)= RES(IDR,2)
55332 RESM(2)= RES(IDR2,1)
55333 RESW(2)= RES(IDR2,2)
55334C...A -> B and B -> A for antisparticles
55335 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55336 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
55337 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
55338 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
55339C...Boundaries and mass flag
55340 LO = (RM(1)+RM(2))**2
55341 HI = (RM(0)-RM(3))**2
55342 MFLAG = DCMASS
55343 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
55344 RETURN
55345 END
55346
55347C*********************************************************************
55348
55349C...PYRVG1
55350C...Integrand for resonance contributions
55351
55352 FUNCTION PYRVG1(X)
55353
55354 IMPLICIT NONE
55355 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55356 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
55357 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
55358 LOGICAL MFLAG
55359 SAVE/PYRVPM/
55360 RVR = PYRVR(X,RESM(1),RESW(1))
55361 C1 = 2D0*SQRT(MAX(0D0,X))
55362 IF (.NOT.MFLAG) THEN
55363 E2 = X/C1
55364 E3 = (RM(0)**2-X)/C1
55365 DELTAY = 4D0*E2*E3
55366 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
55367 ELSE
55368 E2 = (X-RM(1)**2+RM(2)**2)/C1
55369 E3 = (RM(0)**2-X-RM(3)**2)/C1
55370 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
55371 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
55372 DELTAY = 4D0*SR1*SR2
55373 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
55374 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
55375 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
55376 ENDIF
55377 RETURN
55378 END
55379
55380C*********************************************************************
55381
55382C...PYRVG2
55383C...Integrand for L-R interference contributions
55384
55385 FUNCTION PYRVG2(X)
55386
55387 IMPLICIT NONE
55388 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55389 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
55390 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
55391 LOGICAL MFLAG
55392 SAVE/PYRVPM/
55393 C1 = 2D0*SQRT(MAX(0D0,X))
55394 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
55395 IF (.NOT.MFLAG) THEN
55396 E2 = X/C1
55397 E3 = (RM(0)**2-X)/C1
55398 DELTAY = 4D0*E2*E3
55399 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
55400 ELSE
55401 E2 = (X-RM(1)**2+RM(2)**2)/C1
55402 E3 = (RM(0)**2-X-RM(3)**2)/C1
55403 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
55404 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
55405 DELTAY = 4D0*SR1*SR2
55406 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
55407 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
55408 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
55409 ENDIF
55410 RETURN
55411 END
55412
55413C*********************************************************************
55414
55415C...PYRVG3
55416C...Function to do Y integration over true interference contributions
55417
55418 FUNCTION PYRVG3(X)
55419
55420 IMPLICIT NONE
55421 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55422C...Second Dalitz variable for PYRVG4
55423 COMMON/PYG2DX/X1
55424 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
55425 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
55426 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
55427 LOGICAL MFLAG
55428 EXTERNAL PYGAU2,PYRVG4
55429 SAVE/PYRVPM/,/PYG2DX/
55430 PYRVG3=0D0
55431 C1=2D0*SQRT(MAX(1D-9,X))
55432 X1=X
55433 IF (.NOT.MFLAG) THEN
55434 E2 = X/C1
55435 E3 = (RM(0)**2-X)/C1
55436 YMIN = 0D0
55437 YMAX = 4D0*E2*E3
55438 ELSE
55439 E2 = (X-RM(1)**2+RM(2)**2)/C1
55440 E3 = (RM(0)**2-X-RM(3)**2)/C1
55441 SQ1 = (E2+E3)**2
55442 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
55443 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
55444 YMIN = SQ1-(SR1+SR2)**2
55445 YMAX = SQ1-(SR1-SR2)**2
55446 ENDIF
55447 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
55448 RETURN
55449 END
55450
55451C*********************************************************************
55452
55453C...PYRVG4
55454C...Integrand for true intereference contributions
55455
55456 FUNCTION PYRVG4(Y)
55457
55458 IMPLICIT NONE
55459 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
55460 COMMON/PYG2DX/X
55461 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
55462 LOGICAL MFLAG
55463 SAVE /PYRVPM/,/PYG2DX/
55464 PYRVG4=0D0
55465 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
55466 IF (.NOT.MFLAG) THEN
55467 PYRVG4 = RVS*B(1)*B(2)*X*Y
55468 ELSE
55469 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
55470 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
55471 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
55472 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
55473 ENDIF
55474 RETURN
55475 END
55476
55477C*********************************************************************
55478
55479C...PYRVR
55480C...Breit-Wigner for resonance contributions
55481
55482 FUNCTION PYRVR(Mab2,RM,RW)
55483
55484 IMPLICIT NONE
55485 DOUBLE PRECISION Mab2,RM,RW,PYRVR
55486 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
55487 RETURN
55488 END
55489
55490C*********************************************************************
55491
55492C...PYRVS
55493C...Interference function
55494
55495 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
55496
55497 IMPLICIT NONE
55498 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
55499 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
55500 & +W1*W2*M1*M2)
55501 RETURN
55502 END
55503
55504C*********************************************************************
55505
55506C...PY1ENT
55507C...Stores one parton/particle in commonblock PYJETS.
55508
55509 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
55510
55511C...Double precision and integer declarations.
55512 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55513 IMPLICIT INTEGER(I-N)
55514 INTEGER PYK,PYCHGE,PYCOMP
55515C...Commonblocks.
55516 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55517 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55518 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55519 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55520
55521C...Standard checks.
55522 MSTU(28)=0
55523 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55524 IPA=MAX(1,IABS(IP))
55525 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
55526 &'(PY1ENT:) writing outside PYJETS memory')
55527 KC=PYCOMP(KF)
55528 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
55529
55530C...Find mass. Reset K, P and V vectors.
55531 PM=0D0
55532 IF(MSTU(10).EQ.1) PM=P(IPA,5)
55533 IF(MSTU(10).GE.2) PM=PYMASS(KF)
55534 DO 100 J=1,5
55535 K(IPA,J)=0
55536 P(IPA,J)=0D0
55537 V(IPA,J)=0D0
55538 100 CONTINUE
55539
55540C...Store parton/particle in K and P vectors.
55541 K(IPA,1)=1
55542 IF(IP.LT.0) K(IPA,1)=2
55543 K(IPA,2)=KF
55544 P(IPA,5)=PM
55545 P(IPA,4)=MAX(PE,PM)
55546 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
55547 P(IPA,1)=PA*SIN(THE)*COS(PHI)
55548 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
55549 P(IPA,3)=PA*COS(THE)
55550
55551C...Set N. Optionally fragment/decay.
55552 N=IPA
55553 IF(IP.EQ.0) CALL PYEXEC
55554
55555 RETURN
55556 END
55557
55558C*********************************************************************
55559
55560C...PY2ENT
55561C...Stores two partons/particles in their CM frame,
55562C...with the first along the +z axis.
55563
55564 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
55565
55566C...Double precision and integer declarations.
55567 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55568 IMPLICIT INTEGER(I-N)
55569 INTEGER PYK,PYCHGE,PYCOMP
55570C...Commonblocks.
55571 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55572 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55573 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55574 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55575
55576C...Standard checks.
55577 MSTU(28)=0
55578 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55579 IPA=MAX(1,IABS(IP))
55580 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
55581 &'(PY2ENT:) writing outside PYJETS memory')
55582 KC1=PYCOMP(KF1)
55583 KC2=PYCOMP(KF2)
55584 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
55585 &'(PY2ENT:) unknown flavour code')
55586
55587C...Find masses. Reset K, P and V vectors.
55588 PM1=0D0
55589 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
55590 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
55591 PM2=0D0
55592 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
55593 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
55594 DO 110 I=IPA,IPA+1
55595 DO 100 J=1,5
55596 K(I,J)=0
55597 P(I,J)=0D0
55598 V(I,J)=0D0
55599 100 CONTINUE
55600 110 CONTINUE
55601
55602C...Check flavours.
55603 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
55604 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
55605 IF(MSTU(19).EQ.1) THEN
55606 MSTU(19)=0
55607 ELSE
55608 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
55609 & '(PY2ENT:) unphysical flavour combination')
55610 ENDIF
55611 K(IPA,2)=KF1
55612 K(IPA+1,2)=KF2
55613
55614C...Store partons/particles in K vectors for normal case.
55615 IF(IP.GE.0) THEN
55616 K(IPA,1)=1
55617 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
55618 K(IPA+1,1)=1
55619
55620C...Store partons in K vectors for parton shower evolution.
55621 ELSE
55622 K(IPA,1)=3
55623 K(IPA+1,1)=3
55624 K(IPA,4)=MSTU(5)*(IPA+1)
55625 K(IPA,5)=K(IPA,4)
55626 K(IPA+1,4)=MSTU(5)*IPA
55627 K(IPA+1,5)=K(IPA+1,4)
55628 ENDIF
55629
55630C...Check kinematics and store partons/particles in P vectors.
55631 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
55632 &'(PY2ENT:) energy smaller than sum of masses')
55633 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
55634 &(2D0*PECM)
55635 P(IPA,3)=PA
55636 P(IPA,4)=SQRT(PM1**2+PA**2)
55637 P(IPA,5)=PM1
55638 P(IPA+1,3)=-PA
55639 P(IPA+1,4)=SQRT(PM2**2+PA**2)
55640 P(IPA+1,5)=PM2
55641
55642C...Set N. Optionally fragment/decay.
55643 N=IPA+1
55644 IF(IP.EQ.0) CALL PYEXEC
55645
55646 RETURN
55647 END
55648
55649C*********************************************************************
55650
55651C...PY3ENT
55652C...Stores three partons or particles in their CM frame,
55653C...with the first along the +z axis and the third in the (x,z)
55654C...plane with x > 0.
55655
55656 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
55657
55658C...Double precision and integer declarations.
55659 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55660 IMPLICIT INTEGER(I-N)
55661 INTEGER PYK,PYCHGE,PYCOMP
55662C...Commonblocks.
55663 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55664 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55665 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55666 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55667
55668C...Standard checks.
55669 MSTU(28)=0
55670 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55671 IPA=MAX(1,IABS(IP))
55672 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
55673 &'(PY3ENT:) writing outside PYJETS memory')
55674 KC1=PYCOMP(KF1)
55675 KC2=PYCOMP(KF2)
55676 KC3=PYCOMP(KF3)
55677 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
55678 &'(PY3ENT:) unknown flavour code')
55679
55680C...Find masses. Reset K, P and V vectors.
55681 PM1=0D0
55682 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
55683 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
55684 PM2=0D0
55685 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
55686 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
55687 PM3=0D0
55688 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
55689 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
55690 DO 110 I=IPA,IPA+2
55691 DO 100 J=1,5
55692 K(I,J)=0
55693 P(I,J)=0D0
55694 V(I,J)=0D0
55695 100 CONTINUE
55696 110 CONTINUE
55697
55698C...Check flavours.
55699 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
55700 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
55701 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
55702 IF(MSTU(19).EQ.1) THEN
55703 MSTU(19)=0
55704 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
55705 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
55706 & KQ1+KQ3.EQ.4)) THEN
55707 ELSE
55708 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
55709 ENDIF
55710 K(IPA,2)=KF1
55711 K(IPA+1,2)=KF2
55712 K(IPA+2,2)=KF3
55713
55714C...Store partons/particles in K vectors for normal case.
55715 IF(IP.GE.0) THEN
55716 K(IPA,1)=1
55717 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
55718 K(IPA+1,1)=1
55719 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
55720 K(IPA+2,1)=1
55721
55722C...Store partons in K vectors for parton shower evolution.
55723 ELSE
55724 K(IPA,1)=3
55725 K(IPA+1,1)=3
55726 K(IPA+2,1)=3
55727 KCS=4
55728 IF(KQ1.EQ.-1) KCS=5
55729 K(IPA,KCS)=MSTU(5)*(IPA+1)
55730 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
55731 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
55732 K(IPA+1,9-KCS)=MSTU(5)*IPA
55733 K(IPA+2,KCS)=MSTU(5)*IPA
55734 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
55735 ENDIF
55736
55737C...Check kinematics.
55738 MKERR=0
55739 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
55740 &0.5D0*X3*PECM.LE.PM3) MKERR=1
55741 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
55742 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
55743 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
55744 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
55745 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
55746 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
55747 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
55748 IF(MKERR.NE.0) CALL PYERRM(13,
55749 &'(PY3ENT:) unphysical kinematical variable setup')
55750
55751C...Store partons/particles in P vectors.
55752 P(IPA,3)=PA1
55753 P(IPA,4)=SQRT(PA1**2+PM1**2)
55754 P(IPA,5)=PM1
55755 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
55756 P(IPA+2,3)=PA3*CTHE3
55757 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
55758 P(IPA+2,5)=PM3
55759 P(IPA+1,1)=-P(IPA+2,1)
55760 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
55761 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
55762 P(IPA+1,5)=PM2
55763
55764C...Set N. Optionally fragment/decay.
55765 N=IPA+2
55766 IF(IP.EQ.0) CALL PYEXEC
55767
55768 RETURN
55769 END
55770
55771C*********************************************************************
55772
55773C...PY4ENT
55774C...Stores four partons or particles in their CM frame, with
55775C...the first along the +z axis, the last in the xz plane with x > 0
55776C...and the second having y < 0 and y > 0 with equal probability.
55777
55778 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
55779
55780C...Double precision and integer declarations.
55781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55782 IMPLICIT INTEGER(I-N)
55783 INTEGER PYK,PYCHGE,PYCOMP
55784C...Commonblocks.
55785 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55786 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55787 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55788 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
55789
55790C...Standard checks.
55791 MSTU(28)=0
55792 IF(MSTU(12).NE.12345) CALL PYLIST(0)
55793 IPA=MAX(1,IABS(IP))
55794 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
55795 &'(PY4ENT:) writing outside PYJETS momory')
55796 KC1=PYCOMP(KF1)
55797 KC2=PYCOMP(KF2)
55798 KC3=PYCOMP(KF3)
55799 KC4=PYCOMP(KF4)
55800 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
55801 &'(PY4ENT:) unknown flavour code')
55802
55803C...Find masses. Reset K, P and V vectors.
55804 PM1=0D0
55805 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
55806 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
55807 PM2=0D0
55808 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
55809 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
55810 PM3=0D0
55811 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
55812 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
55813 PM4=0D0
55814 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
55815 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
55816 DO 110 I=IPA,IPA+3
55817 DO 100 J=1,5
55818 K(I,J)=0
55819 P(I,J)=0D0
55820 V(I,J)=0D0
55821 100 CONTINUE
55822 110 CONTINUE
55823
55824C...Check flavours.
55825 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
55826 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
55827 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
55828 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
55829 IF(MSTU(19).EQ.1) THEN
55830 MSTU(19)=0
55831 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
55832 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
55833 & KQ1+KQ4.EQ.4)) THEN
55834 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
55835 & THEN
55836 ELSE
55837 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
55838 ENDIF
55839 K(IPA,2)=KF1
55840 K(IPA+1,2)=KF2
55841 K(IPA+2,2)=KF3
55842 K(IPA+3,2)=KF4
55843
55844C...Store partons/particles in K vectors for normal case.
55845 IF(IP.GE.0) THEN
55846 K(IPA,1)=1
55847 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
55848 K(IPA+1,1)=1
55849 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
55850 & K(IPA+1,1)=2
55851 K(IPA+2,1)=1
55852 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
55853 K(IPA+3,1)=1
55854
55855C...Store partons for parton shower evolution from q-g-g-qbar or
55856C...g-g-g-g event.
55857 ELSEIF(KQ1+KQ2.NE.0) THEN
55858 K(IPA,1)=3
55859 K(IPA+1,1)=3
55860 K(IPA+2,1)=3
55861 K(IPA+3,1)=3
55862 KCS=4
55863 IF(KQ1.EQ.-1) KCS=5
55864 K(IPA,KCS)=MSTU(5)*(IPA+1)
55865 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
55866 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
55867 K(IPA+1,9-KCS)=MSTU(5)*IPA
55868 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
55869 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
55870 K(IPA+3,KCS)=MSTU(5)*IPA
55871 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
55872
55873C...Store partons for parton shower evolution from q-qbar-q-qbar event.
55874 ELSE
55875 K(IPA,1)=3
55876 K(IPA+1,1)=3
55877 K(IPA+2,1)=3
55878 K(IPA+3,1)=3
55879 K(IPA,4)=MSTU(5)*(IPA+1)
55880 K(IPA,5)=K(IPA,4)
55881 K(IPA+1,4)=MSTU(5)*IPA
55882 K(IPA+1,5)=K(IPA+1,4)
55883 K(IPA+2,4)=MSTU(5)*(IPA+3)
55884 K(IPA+2,5)=K(IPA+2,4)
55885 K(IPA+3,4)=MSTU(5)*(IPA+2)
55886 K(IPA+3,5)=K(IPA+3,4)
55887 ENDIF
55888
55889C...Check kinematics.
55890 MKERR=0
55891 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
55892 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
55893 &MKERR=1
55894 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
55895 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
55896 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
55897 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
55898 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
55899 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
55900 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
55901 STHE4=SQRT(1D0-CTHE4**2)
55902 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
55903 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
55904 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
55905 STHE2=SQRT(1D0-CTHE2**2)
55906 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
55907 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
55908 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
55909 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
55910 IF(MKERR.EQ.1) CALL PYERRM(13,
55911 &'(PY4ENT:) unphysical kinematical variable setup')
55912
55913C...Store partons/particles in P vectors.
55914 P(IPA,3)=PA1
55915 P(IPA,4)=SQRT(PA1**2+PM1**2)
55916 P(IPA,5)=PM1
55917 P(IPA+3,1)=PA4*STHE4
55918 P(IPA+3,3)=PA4*CTHE4
55919 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
55920 P(IPA+3,5)=PM4
55921 P(IPA+1,1)=PA2*STHE2*CPHI2
55922 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
55923 P(IPA+1,3)=PA2*CTHE2
55924 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
55925 P(IPA+1,5)=PM2
55926 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
55927 P(IPA+2,2)=-P(IPA+1,2)
55928 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
55929 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
55930 P(IPA+2,5)=PM3
55931
55932C...Set N. Optionally fragment/decay.
55933 N=IPA+3
55934 IF(IP.EQ.0) CALL PYEXEC
55935
55936 RETURN
55937 END
55938
55939C*********************************************************************
55940
55941C...PY2FRM
55942C...An interface from a two-fermion generator to include
55943C...parton showers and hadronization.
55944
55945 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
55946
55947C...Double precision and integer declarations.
55948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55949 IMPLICIT INTEGER(I-N)
55950 INTEGER PYK,PYCHGE,PYCOMP
55951C...Commonblocks.
55952 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
55953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55954 SAVE /PYJETS/,/PYDAT1/
55955C...Local arrays.
55956 DIMENSION IJOIN(2),INTAU(2)
55957
55958C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
55959 IF(ICOM.EQ.0) THEN
55960 MSTU(28)=0
55961 CALL PYHEPC(2)
55962 ENDIF
55963
55964C...Loop through entries and pick up all final fermions/antifermions.
55965 I1=0
55966 I2=0
55967 DO 100 I=1,N
55968 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
55969 KFA=IABS(K(I,2))
55970 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
55971 IF(K(I,2).GT.0) THEN
55972 IF(I1.EQ.0) THEN
55973 I1=I
55974 ELSE
55975 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
55976 ENDIF
55977 ELSE
55978 IF(I2.EQ.0) THEN
55979 I2=I
55980 ELSE
55981 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
55982 ENDIF
55983 ENDIF
55984 ENDIF
55985 100 CONTINUE
55986
55987C...Check that event is arranged according to conventions.
55988 IF(I1.EQ.0.OR.I2.EQ.0) THEN
55989 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
55990 ENDIF
55991 IF(I2.LT.I1) THEN
55992 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
55993 ENDIF
55994
55995C...Check whether fermion pair is quarks or leptons.
55996 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
55997 IQL12=1
55998 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
55999 IQL12=2
56000 ELSE
56001 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
56002 ENDIF
56003
56004C...Decide whether to allow or not photon radiation in showers.
56005 MSTJ(41)=2
56006 IF(IRAD.EQ.0) MSTJ(41)=1
56007
56008C...Do colour joining and parton showers.
56009 IP1=I1
56010 IP2=I2
56011 IF(IQL12.EQ.1) THEN
56012 IJOIN(1)=IP1
56013 IJOIN(2)=IP2
56014 CALL PYJOIN(2,IJOIN)
56015 ENDIF
56016 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
56017 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
56018 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
56019 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
56020 ENDIF
56021
56022C...Do fragmentation and decays. Possibly except tau decay.
56023 IF(ITAU.EQ.0) THEN
56024 NTAU=0
56025 DO 110 I=1,N
56026 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
56027 NTAU=NTAU+1
56028 INTAU(NTAU)=I
56029 K(I,1)=11
56030 ENDIF
56031 110 CONTINUE
56032 ENDIF
56033 CALL PYEXEC
56034 IF(ITAU.EQ.0) THEN
56035 DO 120 I=1,NTAU
56036 K(INTAU(I),1)=1
56037 120 CONTINUE
56038 ENDIF
56039
56040C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56041 IF(ICOM.EQ.0) THEN
56042 MSTU(28)=0
56043 CALL PYHEPC(1)
56044 ENDIF
56045
56046 END
56047
56048C*********************************************************************
56049
56050C...PY4FRM
56051C...An interface from a four-fermion generator to include
56052C...parton showers and hadronization.
56053
56054 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
56055
56056C...Double precision and integer declarations.
56057 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56058 IMPLICIT INTEGER(I-N)
56059 INTEGER PYK,PYCHGE,PYCOMP
56060C...Commonblocks.
56061 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56063 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56064 COMMON/PYINT1/MINT(400),VINT(400)
56065 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
56066C...Local arrays.
56067 DIMENSION IJOIN(2),INTAU(4)
56068
56069C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
56070 IF(ICOM.EQ.0) THEN
56071 MSTU(28)=0
56072 CALL PYHEPC(2)
56073 ENDIF
56074
56075C...Loop through entries and pick up all final fermions/antifermions.
56076 I1=0
56077 I2=0
56078 I3=0
56079 I4=0
56080 DO 100 I=1,N
56081 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
56082 KFA=IABS(K(I,2))
56083 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
56084 IF(K(I,2).GT.0) THEN
56085 IF(I1.EQ.0) THEN
56086 I1=I
56087 ELSEIF(I3.EQ.0) THEN
56088 I3=I
56089 ELSE
56090 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
56091 ENDIF
56092 ELSE
56093 IF(I2.EQ.0) THEN
56094 I2=I
56095 ELSEIF(I4.EQ.0) THEN
56096 I4=I
56097 ELSE
56098 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
56099 ENDIF
56100 ENDIF
56101 ENDIF
56102 100 CONTINUE
56103
56104C...Check that event is arranged according to conventions.
56105 IF(I3.EQ.0.OR.I4.EQ.0) THEN
56106 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
56107 ENDIF
56108 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
56109 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
56110 ENDIF
56111
56112C...Check which fermion pairs are quarks and which leptons.
56113 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
56114 IQL12=1
56115 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
56116 IQL12=2
56117 ELSE
56118 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
56119 ENDIF
56120 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
56121 IQL34=1
56122 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
56123 IQL34=2
56124 ELSE
56125 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
56126 ENDIF
56127
56128C...Decide whether to allow or not photon radiation in showers.
56129 MSTJ(41)=2
56130 IF(IRAD.EQ.0) MSTJ(41)=1
56131
56132C...Decide on dipole pairing.
56133 IP1=I1
56134 IP2=I2
56135 IP3=I3
56136 IP4=I4
56137 IF(IQL12.EQ.IQL34) THEN
56138 R1SQ=A1SQ
56139 R2SQ=A2SQ
56140 DELTA=ATOTSQ-A1SQ-A2SQ
56141 IF(ISTRAT.EQ.1) THEN
56142 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
56143 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
56144 ELSEIF(ISTRAT.EQ.2) THEN
56145 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
56146 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
56147 ENDIF
56148 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
56149 IP2=I4
56150 IP4=I2
56151 ENDIF
56152 ENDIF
56153
56154C...If colour reconnection then bookkeep W+W- or Z0Z0
56155C...and copy q qbar q qbar consecutively.
56156 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
56157 K(N+1,1)=11
56158 K(N+1,3)=IP1
56159 K(N+1,4)=N+3
56160 K(N+1,5)=N+4
56161 K(N+2,1)=11
56162 K(N+2,3)=IP3
56163 K(N+2,4)=N+5
56164 K(N+2,5)=N+6
56165 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
56166 K(N+1,2)=23
56167 K(N+2,2)=23
56168 MINT(1)=22
56169 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
56170 K(N+1,2)=24
56171 K(N+2,2)=-24
56172 MINT(1)=25
56173 ELSE
56174 K(N+1,2)=-24
56175 K(N+2,2)=24
56176 MINT(1)=25
56177 ENDIF
56178 DO 110 J=1,5
56179 K(N+3,J)=K(IP1,J)
56180 K(N+4,J)=K(IP2,J)
56181 K(N+5,J)=K(IP3,J)
56182 K(N+6,J)=K(IP4,J)
56183 P(N+1,J)=P(IP1,J)+P(IP2,J)
56184 P(N+2,J)=P(IP3,J)+P(IP4,J)
56185 P(N+3,J)=P(IP1,J)
56186 P(N+4,J)=P(IP2,J)
56187 P(N+5,J)=P(IP3,J)
56188 P(N+6,J)=P(IP4,J)
56189 V(N+1,J)=V(IP1,J)
56190 V(N+2,J)=V(IP3,J)
56191 V(N+3,J)=V(IP1,J)
56192 V(N+4,J)=V(IP2,J)
56193 V(N+5,J)=V(IP3,J)
56194 V(N+6,J)=V(IP4,J)
56195 110 CONTINUE
56196 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56197 & P(N+1,3)**2))
56198 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56199 & P(N+2,3)**2))
56200 K(N+3,3)=N+1
56201 K(N+4,3)=N+1
56202 K(N+5,3)=N+2
56203 K(N+6,3)=N+2
56204C...Remove original q qbar q qbar and update counters.
56205 K(IP1,1)=K(IP1,1)+10
56206 K(IP2,1)=K(IP2,1)+10
56207 K(IP3,1)=K(IP3,1)+10
56208 K(IP4,1)=K(IP4,1)+10
56209 IW1=N+1
56210 IW2=N+2
56211 NSD1=N+2
56212 IP1=N+3
56213 IP2=N+4
56214 IP3=N+5
56215 IP4=N+6
56216 N=N+6
56217 ENDIF
56218
56219C...Do colour joinings and parton showers.
56220 IF(IQL12.EQ.1) THEN
56221 IJOIN(1)=IP1
56222 IJOIN(2)=IP2
56223 CALL PYJOIN(2,IJOIN)
56224 ENDIF
56225 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
56226 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
56227 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
56228 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
56229 ENDIF
56230 NAFT1=N
56231 IF(IQL34.EQ.1) THEN
56232 IJOIN(1)=IP3
56233 IJOIN(2)=IP4
56234 CALL PYJOIN(2,IJOIN)
56235 ENDIF
56236 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
56237 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
56238 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
56239 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
56240 ENDIF
56241
56242C...Optionally do colour reconnection.
56243 MINT(32)=0
56244 MSTI(32)=0
56245 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
56246 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
56247 MSTI(32)=MINT(32)
56248 ENDIF
56249
56250C...Do fragmentation and decays. Possibly except tau decay.
56251 IF(ITAU.EQ.0) THEN
56252 NTAU=0
56253 DO 120 I=1,N
56254 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
56255 NTAU=NTAU+1
56256 INTAU(NTAU)=I
56257 K(I,1)=11
56258 ENDIF
56259 120 CONTINUE
56260 ENDIF
56261 CALL PYEXEC
56262 IF(ITAU.EQ.0) THEN
56263 DO 130 I=1,NTAU
56264 K(INTAU(I),1)=1
56265 130 CONTINUE
56266 ENDIF
56267
56268C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56269 IF(ICOM.EQ.0) THEN
56270 MSTU(28)=0
56271 CALL PYHEPC(1)
56272 ENDIF
56273
56274 END
56275
56276C*********************************************************************
56277
56278C...PY6FRM
56279C...An interface from a six-fermion generator to include
56280C...parton showers and hadronization.
56281
56282 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
56283
56284C...Double precision and integer declarations.
56285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56286 IMPLICIT INTEGER(I-N)
56287 INTEGER PYK,PYCHGE,PYCOMP
56288C...Commonblocks.
56289 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56291 SAVE /PYJETS/,/PYDAT1/
56292C...Local arrays.
56293 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
56294
56295C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
56296 IF(ICOM.EQ.0) THEN
56297 MSTU(28)=0
56298 CALL PYHEPC(2)
56299 ENDIF
56300
56301C...Loop through entries and pick up all final fermions/antifermions.
56302 I1=0
56303 I2=0
56304 I3=0
56305 I4=0
56306 I5=0
56307 I6=0
56308 DO 100 I=1,N
56309 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
56310 KFA=IABS(K(I,2))
56311 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
56312 IF(K(I,2).GT.0) THEN
56313 IF(I1.EQ.0) THEN
56314 I1=I
56315 ELSEIF(I3.EQ.0) THEN
56316 I3=I
56317 ELSEIF(I5.EQ.0) THEN
56318 I5=I
56319 ELSE
56320 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
56321 ENDIF
56322 ELSE
56323 IF(I2.EQ.0) THEN
56324 I2=I
56325 ELSEIF(I4.EQ.0) THEN
56326 I4=I
56327 ELSEIF(I6.EQ.0) THEN
56328 I6=I
56329 ELSE
56330 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
56331 ENDIF
56332 ENDIF
56333 ENDIF
56334 100 CONTINUE
56335
56336C...Check that event is arranged according to conventions.
56337 IF(I5.EQ.0.OR.I6.EQ.0) THEN
56338 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
56339 ENDIF
56340 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
56341 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
56342 ENDIF
56343
56344C...Check which fermion pairs are quarks and which leptons.
56345 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
56346 IQL12=1
56347 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
56348 IQL12=2
56349 ELSE
56350 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
56351 ENDIF
56352 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
56353 IQL34=1
56354 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
56355 IQL34=2
56356 ELSE
56357 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
56358 ENDIF
56359 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
56360 IQL56=1
56361 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
56362 IQL56=2
56363 ELSE
56364 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
56365 ENDIF
56366
56367C...Decide whether to allow or not photon radiation in showers.
56368 MSTJ(41)=2
56369 IF(IRAD.EQ.0) MSTJ(41)=1
56370
56371C...Allow dipole pairings only among leptons and quarks separately.
56372 P12D=P12
56373 P13D=0D0
56374 IF(IQL34.EQ.IQL56) P13D=P13
56375 P21D=0D0
56376 IF(IQL12.EQ.IQL34) P21D=P21
56377 P23D=0D0
56378 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
56379 P31D=0D0
56380 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
56381 P32D=0D0
56382 IF(IQL12.EQ.IQL56) P32D=P32
56383
56384C...Decide whether t+tbar.
56385 ITOP=0
56386 IF(PYR(0).LT.PTOP) THEN
56387 ITOP=1
56388
56389C...If t+tbar: reconstruct t's.
56390 IT=N+1
56391 ITB=N+2
56392 DO 110 J=1,5
56393 K(IT,J)=0
56394 K(ITB,J)=0
56395 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
56396 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
56397 V(IT,J)=0D0
56398 V(ITB,J)=0D0
56399 110 CONTINUE
56400 K(IT,1)=1
56401 K(ITB,1)=1
56402 K(IT,2)=6
56403 K(ITB,2)=-6
56404 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
56405 & P(IT,3)**2))
56406 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
56407 & P(ITB,3)**2))
56408 N=N+2
56409
56410C...If t+tbar: colour join t's and let them shower.
56411 IJOIN(1)=IT
56412 IJOIN(2)=ITB
56413 CALL PYJOIN(2,IJOIN)
56414 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
56415 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
56416 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
56417
56418C...If t+tbar: pick up the t's after shower.
56419 ITNEW=IT
56420 ITBNEW=ITB
56421 DO 120 I=ITB+1,N
56422 IF(K(I,2).EQ.6) ITNEW=I
56423 IF(K(I,2).EQ.-6) ITBNEW=I
56424 120 CONTINUE
56425
56426C...If t+tbar: loop over two top systems.
56427 DO 200 IT1=1,2
56428 IF(IT1.EQ.1) THEN
56429 ITO=IT
56430 ITN=ITNEW
56431 IBO=I1
56432 IW1=I3
56433 IW2=I4
56434 ELSE
56435 ITO=ITB
56436 ITN=ITBNEW
56437 IBO=I2
56438 IW1=I5
56439 IW2=I6
56440 ENDIF
56441 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
56442 & '(PY6FRM:) not b in t decay')
56443
56444C...If t+tbar: find boost from original to new top frame.
56445 DO 130 J=1,3
56446 BETAO(J)=P(ITO,J)/P(ITO,4)
56447 BETAN(J)=P(ITN,J)/P(ITN,4)
56448 130 CONTINUE
56449
56450C...If t+tbar: boost copy of b by t shower and connect it in colour.
56451 N=N+1
56452 IB=N
56453 K(IB,1)=3
56454 K(IB,2)=K(IBO,2)
56455 K(IB,3)=ITN
56456 DO 140 J=1,5
56457 P(IB,J)=P(IBO,J)
56458 V(IB,J)=0D0
56459 140 CONTINUE
56460 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
56461 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
56462 K(IB,4)=MSTU(5)*ITN
56463 K(IB,5)=MSTU(5)*ITN
56464 K(ITN,4)=K(ITN,4)+IB
56465 K(ITN,5)=K(ITN,5)+IB
56466 K(ITN,1)=K(ITN,1)+10
56467 K(IBO,1)=K(IBO,1)+10
56468
56469C...If t+tbar: construct W recoiling against b.
56470 N=N+1
56471 IW=N
56472 DO 150 J=1,5
56473 K(IW,J)=0
56474 V(IW,J)=0D0
56475 150 CONTINUE
56476 K(IW,1)=1
56477 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
56478 IF(IABS(KCHW).EQ.3) THEN
56479 K(IW,2)=ISIGN(24,KCHW)
56480 ELSE
56481 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
56482 ENDIF
56483 K(IW,3)=IW1
56484
56485C...If t+tbar: construct W momentum, including boost by t shower.
56486 DO 160 J=1,4
56487 P(IW,J)=P(IW1,J)+P(IW2,J)
56488 160 CONTINUE
56489 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
56490 & P(IW,3)**2))
56491 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
56492 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
56493
56494C...If t+tbar: boost b and W to top rest frame.
56495 DO 170 J=1,3
56496 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
56497 170 CONTINUE
56498 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56499 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56500
56501C...If t+tbar: let b shower and pick up modified W.
56502 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
56503 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
56504 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
56505 DO 180 I=IW,N
56506 IF(IABS(K(I,2)).EQ.24) IWM=I
56507 180 CONTINUE
56508
56509C...If t+tbar: take copy of W decay products.
56510 DO 190 J=1,5
56511 K(N+1,J)=K(IW1,J)
56512 P(N+1,J)=P(IW1,J)
56513 V(N+1,J)=V(IW1,J)
56514 K(N+2,J)=K(IW2,J)
56515 P(N+2,J)=P(IW2,J)
56516 V(N+2,J)=V(IW2,J)
56517 190 CONTINUE
56518 K(IW1,1)=K(IW1,1)+10
56519 K(IW2,1)=K(IW2,1)+10
56520 K(IWM,1)=K(IWM,1)+10
56521 K(IWM,4)=N+1
56522 K(IWM,5)=N+2
56523 K(N+1,3)=IWM
56524 K(N+2,3)=IWM
56525 IF(IT1.EQ.1) THEN
56526 I3=N+1
56527 I4=N+2
56528 ELSE
56529 I5=N+1
56530 I6=N+2
56531 ENDIF
56532 N=N+2
56533
56534C...If t+tbar: boost W decay products, first by effects of t shower,
56535C...then by those of b shower. b and its shower simple boost back.
56536 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
56537 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
56538 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56539 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
56540 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
56541 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
56542 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
56543 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
56544 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
56545 200 CONTINUE
56546 ENDIF
56547
56548C...Decide on dipole pairing.
56549 IP1=I1
56550 IP3=I3
56551 IP5=I5
56552 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
56553 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
56554 IP2=I2
56555 IP4=I4
56556 IP6=I6
56557 ELSEIF(PRN.LT.P12D+P13D) THEN
56558 IP2=I2
56559 IP4=I6
56560 IP6=I4
56561 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
56562 IP2=I4
56563 IP4=I2
56564 IP6=I6
56565 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
56566 IP2=I4
56567 IP4=I6
56568 IP6=I2
56569 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
56570 IP2=I6
56571 IP4=I2
56572 IP6=I4
56573 ELSE
56574 IP2=I6
56575 IP4=I4
56576 IP6=I2
56577 ENDIF
56578
56579C...Do colour joinings and parton showers
56580C...(except ones already made for t+tbar).
56581 IF(ITOP.EQ.0) THEN
56582 IF(IQL12.EQ.1) THEN
56583 IJOIN(1)=IP1
56584 IJOIN(2)=IP2
56585 CALL PYJOIN(2,IJOIN)
56586 ENDIF
56587 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
56588 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
56589 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
56590 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
56591 ENDIF
56592 ENDIF
56593 IF(IQL34.EQ.1) THEN
56594 IJOIN(1)=IP3
56595 IJOIN(2)=IP4
56596 CALL PYJOIN(2,IJOIN)
56597 ENDIF
56598 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
56599 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
56600 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
56601 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
56602 ENDIF
56603 IF(IQL56.EQ.1) THEN
56604 IJOIN(1)=IP5
56605 IJOIN(2)=IP6
56606 CALL PYJOIN(2,IJOIN)
56607 ENDIF
56608 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
56609 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
56610 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
56611 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
56612 ENDIF
56613
56614C...Do fragmentation and decays. Possibly except tau decay.
56615 IF(ITAU.EQ.0) THEN
56616 NTAU=0
56617 DO 210 I=1,N
56618 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
56619 NTAU=NTAU+1
56620 INTAU(NTAU)=I
56621 K(I,1)=11
56622 ENDIF
56623 210 CONTINUE
56624 ENDIF
56625 CALL PYEXEC
56626 IF(ITAU.EQ.0) THEN
56627 DO 220 I=1,NTAU
56628 K(INTAU(I),1)=1
56629 220 CONTINUE
56630 ENDIF
56631
56632C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56633 IF(ICOM.EQ.0) THEN
56634 MSTU(28)=0
56635 CALL PYHEPC(1)
56636 ENDIF
56637
56638 END
56639
56640C*********************************************************************
56641
56642C...PY4JET
56643C...An interface from a four-parton generator to include
56644C...parton showers and hadronization.
56645
56646 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
56647
56648C...Double precision and integer declarations.
56649 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56650 IMPLICIT INTEGER(I-N)
56651 INTEGER PYK,PYCHGE,PYCOMP
56652C...Commonblocks.
56653 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56654 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56655 SAVE /PYJETS/,/PYDAT1/
56656C...Local arrays.
56657 DIMENSION IJOIN(2),PTOT(4),BETA(3)
56658
56659C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
56660 IF(ICOM.EQ.0) THEN
56661 MSTU(28)=0
56662 CALL PYHEPC(2)
56663 ENDIF
56664
56665C...Loop through entries and pick up all final partons.
56666 I1=0
56667 I2=0
56668 I3=0
56669 I4=0
56670 DO 100 I=1,N
56671 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
56672 KFA=IABS(K(I,2))
56673 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
56674 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
56675 IF(I1.EQ.0) THEN
56676 I1=I
56677 ELSEIF(I3.EQ.0) THEN
56678 I3=I
56679 ELSE
56680 CALL PYERRM(16,'(PY4JET:) more than two quarks')
56681 ENDIF
56682 ELSEIF(K(I,2).LT.0) THEN
56683 IF(I2.EQ.0) THEN
56684 I2=I
56685 ELSEIF(I4.EQ.0) THEN
56686 I4=I
56687 ELSE
56688 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
56689 ENDIF
56690 ELSE
56691 IF(I3.EQ.0) THEN
56692 I3=I
56693 ELSEIF(I4.EQ.0) THEN
56694 I4=I
56695 ELSE
56696 CALL PYERRM(16,'(PY4JET:) more than two gluons')
56697 ENDIF
56698 ENDIF
56699 ENDIF
56700 100 CONTINUE
56701
56702C...Check that event is arranged according to conventions.
56703 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
56704 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
56705 ENDIF
56706 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
56707 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
56708 ENDIF
56709
56710C...Check whether second pair are quarks or gluons.
56711 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
56712 IQG34=1
56713 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
56714 IQG34=2
56715 ELSE
56716 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
56717 ENDIF
56718
56719C...Boost partons to their cm frame.
56720 DO 110 J=1,4
56721 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
56722 110 CONTINUE
56723 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
56724 DO 120 J=1,3
56725 BETA(J)=PTOT(J)/PTOT(4)
56726 120 CONTINUE
56727 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56728 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56729 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56730 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
56731 NSAV=N
56732
56733C...Decide and set up shower history for q qbar q' qbar' events.
56734 IF(IQG34.EQ.1) THEN
56735 W1=PY4JTW(0,I1,I3,I4)
56736 W2=PY4JTW(0,I2,I3,I4)
56737 IF(W1.GT.PYR(0)*(W1+W2)) THEN
56738 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
56739 ELSE
56740 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
56741 ENDIF
56742
56743C...Decide and set up shower history for q qbar g g events.
56744 ELSE
56745 W1=PY4JTW(I1,I3,I2,I4)
56746 W2=PY4JTW(I1,I4,I2,I3)
56747 W3=PY4JTW(0,I3,I1,I4)
56748 W4=PY4JTW(0,I4,I1,I3)
56749 W5=PY4JTW(0,I3,I2,I4)
56750 W6=PY4JTW(0,I4,I2,I3)
56751 W7=PY4JTW(0,I1,I3,I4)
56752 W8=PY4JTW(0,I2,I3,I4)
56753 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
56754 IF(W1.GT.WR) THEN
56755 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
56756 ELSEIF(W1+W2.GT.WR) THEN
56757 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
56758 ELSEIF(W1+W2+W3.GT.WR) THEN
56759 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
56760 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
56761 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
56762 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
56763 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
56764 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
56765 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
56766 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
56767 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
56768 ELSE
56769 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
56770 ENDIF
56771 ENDIF
56772
56773C...Boost back original partons and mark them as deleted.
56774 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
56775 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
56776 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
56777 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
56778 K(I1,1)=K(I1,1)+10
56779 K(I2,1)=K(I2,1)+10
56780 K(I3,1)=K(I3,1)+10
56781 K(I4,1)=K(I4,1)+10
56782
56783C...Rotate shower initiating partons to be along z axis.
56784 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
56785 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
56786 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
56787 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
56788
56789C...Set up copy of shower initiating partons as on mass shell.
56790 DO 140 I=N+1,N+2
56791 DO 130 J=1,5
56792 K(I,J)=0
56793 P(I,J)=0D0
56794 V(I,J)=V(I1,J)
56795 130 CONTINUE
56796 K(I,1)=1
56797 K(I,2)=K(I-6,2)
56798 140 CONTINUE
56799 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
56800 K(N+1,3)=I1
56801 P(N+1,5)=P(I1,5)
56802 K(N+2,3)=I2
56803 P(N+2,5)=P(I2,5)
56804 ELSE
56805 K(N+1,3)=I2
56806 P(N+1,5)=P(I2,5)
56807 K(N+2,3)=I1
56808 P(N+2,5)=P(I1,5)
56809 ENDIF
56810 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
56811 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
56812 P(N+1,3)=PABS
56813 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
56814 P(N+2,3)=-PABS
56815 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
56816 N=N+2
56817
56818C...Decide whether to allow or not photon radiation in showers.
56819C...Connect up colours.
56820 MSTJ(41)=2
56821 IF(IRAD.EQ.0) MSTJ(41)=1
56822 IJOIN(1)=N-1
56823 IJOIN(2)=N
56824 CALL PYJOIN(2,IJOIN)
56825
56826C...Decide on maximum virtuality and do parton shower.
56827 IF(PMAX.LT.PARJ(82)) THEN
56828 PQMAX=QMAX
56829 ELSE
56830 PQMAX=PMAX
56831 ENDIF
56832 CALL PYSHOW(NSAV+1,-100,PQMAX)
56833
56834C...Rotate and boost back system.
56835 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
56836
56837C...Do fragmentation and decays.
56838 CALL PYEXEC
56839
56840C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
56841 IF(ICOM.EQ.0) THEN
56842 MSTU(28)=0
56843 CALL PYHEPC(1)
56844 ENDIF
56845
56846 RETURN
56847 END
56848
56849C*********************************************************************
56850
56851C...PY4JTW
56852C...Auxiliary to PY4JET, to evaluate weight of configuration.
56853
56854 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
56855
56856C...Double precision and integer declarations.
56857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56858 IMPLICIT INTEGER(I-N)
56859 INTEGER PYK,PYCHGE,PYCOMP
56860C...Commonblocks.
56861 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56862 SAVE /PYJETS/
56863
56864C...First case: when both original partons radiate.
56865C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
56866 IF(IA1.NE.0) THEN
56867 DO 100 J=1,4
56868 P(N+1,J)=P(IA1,J)+P(IA2,J)
56869 P(N+2,J)=P(IA3,J)+P(IA4,J)
56870 100 CONTINUE
56871 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56872 & P(N+1,3)**2))
56873 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56874 & P(N+2,3)**2))
56875 Z1=P(IA1,4)/P(N+1,4)
56876 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
56877 Z2=P(IA3,4)/P(N+2,4)
56878 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
56879
56880C...Second case: when one original parton radiates to three.
56881C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
56882 ELSE
56883 DO 110 J=1,4
56884 P(N+2,J)=P(IA3,J)+P(IA4,J)
56885 P(N+1,J)=P(N+2,J)+P(IA2,J)
56886 110 CONTINUE
56887 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56888 & P(N+1,3)**2))
56889 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56890 & P(N+2,3)**2))
56891 IF(K(IA2,2).EQ.21) THEN
56892 Z1=P(N+2,4)/P(N+1,4)
56893 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
56894 & P(IA3,5)**2)
56895 ELSE
56896 Z1=P(IA2,4)/P(N+1,4)
56897 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
56898 & P(IA2,5)**2)
56899 ENDIF
56900 Z2=P(IA3,4)/P(N+2,4)
56901 IF(K(IA2,2).EQ.21) THEN
56902 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
56903 & P(IA3,5)**2)
56904 ELSEIF(K(IA3,2).EQ.21) THEN
56905 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
56906 ELSE
56907 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
56908 ENDIF
56909 ENDIF
56910
56911C...Total weight.
56912 PY4JTW=WT1*WT2
56913
56914 RETURN
56915 END
56916
56917C*********************************************************************
56918
56919C...PY4JTS
56920C...Auxiliary to PY4JET, to set up chosen configuration.
56921
56922 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
56923
56924C...Double precision and integer declarations.
56925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56926 IMPLICIT INTEGER(I-N)
56927 INTEGER PYK,PYCHGE,PYCOMP
56928C...Commonblocks.
56929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56930 SAVE /PYJETS/
56931
56932C...Reset info.
56933 DO 110 I=N+1,N+6
56934 DO 100 J=1,5
56935 K(I,J)=0
56936 V(I,J)=V(IA2,J)
56937 100 CONTINUE
56938 K(I,1)=16
56939 110 CONTINUE
56940
56941C...First case: when both original partons radiate.
56942C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
56943 IF(IA1.NE.0) THEN
56944
56945C...Set up flavour and history pointers for new partons.
56946 K(N+1,2)=K(IA1,2)
56947 K(N+2,2)=K(IA3,2)
56948 K(N+3,2)=K(IA1,2)
56949 K(N+4,2)=K(IA2,2)
56950 K(N+5,2)=K(IA3,2)
56951 K(N+6,2)=K(IA4,2)
56952 K(N+1,3)=IA1
56953 K(N+1,4)=N+3
56954 K(N+1,5)=N+4
56955 K(N+2,3)=IA3
56956 K(N+2,4)=N+5
56957 K(N+2,5)=N+6
56958 K(N+3,3)=N+1
56959 K(N+4,3)=N+1
56960 K(N+5,3)=N+2
56961 K(N+6,3)=N+2
56962
56963C...Set up momenta for new partons.
56964 DO 120 J=1,5
56965 P(N+1,J)=P(IA1,J)+P(IA2,J)
56966 P(N+2,J)=P(IA3,J)+P(IA4,J)
56967 P(N+3,J)=P(IA1,J)
56968 P(N+4,J)=P(IA2,J)
56969 P(N+5,J)=P(IA3,J)
56970 P(N+6,J)=P(IA4,J)
56971 120 CONTINUE
56972 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
56973 & P(N+1,3)**2))
56974 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
56975 & P(N+2,3)**2))
56976 QMAX=MIN(P(N+1,5),P(N+2,5))
56977
56978C...Second case: q radiates twice.
56979C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
56980C...IA5=N+2 does not radiate.
56981 ELSEIF(K(IA2,2).EQ.21) THEN
56982
56983C...Set up flavour and history pointers for new partons.
56984 K(N+1,2)=K(IA3,2)
56985 K(N+2,2)=K(IA5,2)
56986 K(N+3,2)=K(IA3,2)
56987 K(N+4,2)=K(IA2,2)
56988 K(N+5,2)=K(IA3,2)
56989 K(N+6,2)=K(IA4,2)
56990 K(N+1,3)=IA3
56991 K(N+1,4)=N+3
56992 K(N+1,5)=N+4
56993 K(N+2,3)=IA5
56994 K(N+3,3)=N+1
56995 K(N+3,4)=N+5
56996 K(N+3,5)=N+6
56997 K(N+4,3)=N+1
56998 K(N+5,3)=N+3
56999 K(N+6,3)=N+3
57000
57001C...Set up momenta for new partons.
57002 DO 130 J=1,5
57003 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
57004 P(N+2,J)=P(IA5,J)
57005 P(N+3,J)=P(IA3,J)+P(IA4,J)
57006 P(N+4,J)=P(IA2,J)
57007 P(N+5,J)=P(IA3,J)
57008 P(N+6,J)=P(IA4,J)
57009 130 CONTINUE
57010 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57011 & P(N+1,3)**2))
57012 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
57013 & P(N+3,3)**2))
57014 QMAX=P(N+3,5)
57015
57016C...Third case: q radiates g, g branches.
57017C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
57018C...IA5=N+2 does not radiate.
57019 ELSE
57020
57021C...Set up flavour and history pointers for new partons.
57022 K(N+1,2)=K(IA2,2)
57023 K(N+2,2)=K(IA5,2)
57024 K(N+3,2)=K(IA2,2)
57025 K(N+4,2)=21
57026 K(N+5,2)=K(IA3,2)
57027 K(N+6,2)=K(IA4,2)
57028 K(N+1,3)=IA2
57029 K(N+1,4)=N+3
57030 K(N+1,5)=N+4
57031 K(N+2,3)=IA5
57032 K(N+3,3)=N+1
57033 K(N+4,3)=N+1
57034 K(N+4,4)=N+5
57035 K(N+4,5)=N+6
57036 K(N+5,3)=N+4
57037 K(N+6,3)=N+4
57038
57039C...Set up momenta for new partons.
57040 DO 140 J=1,5
57041 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
57042 P(N+2,J)=P(IA5,J)
57043 P(N+3,J)=P(IA2,J)
57044 P(N+4,J)=P(IA3,J)+P(IA4,J)
57045 P(N+5,J)=P(IA3,J)
57046 P(N+6,J)=P(IA4,J)
57047 140 CONTINUE
57048 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57049 & P(N+1,3)**2))
57050 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
57051 & P(N+4,3)**2))
57052 QMAX=P(N+4,5)
57053
57054 ENDIF
57055 N=N+6
57056
57057 RETURN
57058 END
57059
57060C*********************************************************************
57061
57062C...PYJOIN
57063C...Connects a sequence of partons with colour flow indices,
57064C...as required for subsequent shower evolution (or other operations).
57065
57066 SUBROUTINE PYJOIN(NJOIN,IJOIN)
57067
57068C...Double precision and integer declarations.
57069 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57070 IMPLICIT INTEGER(I-N)
57071 INTEGER PYK,PYCHGE,PYCOMP
57072C...Commonblocks.
57073 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57074 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57075 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57076 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
57077C...Local array.
57078 DIMENSION IJOIN(*)
57079
57080C...Check that partons are of right types to be connected.
57081 IF(NJOIN.LT.2) GOTO 120
57082 KQSUM=0
57083 DO 100 IJN=1,NJOIN
57084 I=IJOIN(IJN)
57085 IF(I.LE.0.OR.I.GT.N) GOTO 120
57086 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
57087 KC=PYCOMP(K(I,2))
57088 IF(KC.EQ.0) GOTO 120
57089 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
57090 IF(KQ.EQ.0) GOTO 120
57091 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
57092 IF(KQ.NE.2) KQSUM=KQSUM+KQ
57093 IF(IJN.EQ.1) KQS=KQ
57094 100 CONTINUE
57095 IF(KQSUM.NE.0) GOTO 120
57096
57097C...Connect the partons sequentially (closing for gluon loop).
57098 KCS=(9-KQS)/2
57099 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
57100 DO 110 IJN=1,NJOIN
57101 I=IJOIN(IJN)
57102 K(I,1)=3
57103 IF(IJN.NE.1) IP=IJOIN(IJN-1)
57104 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
57105 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
57106 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
57107 K(I,KCS)=MSTU(5)*IN
57108 K(I,9-KCS)=MSTU(5)*IP
57109 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
57110 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
57111 110 CONTINUE
57112
57113C...Error exit: no action taken.
57114 RETURN
57115 120 CALL PYERRM(12,
57116 &'(PYJOIN:) given entries can not be joined by one string')
57117
57118 RETURN
57119 END
57120
57121C*********************************************************************
57122
57123C...PYGIVE
57124C...Sets values of commonblock variables.
57125
57126 SUBROUTINE PYGIVE(CHIN)
57127
57128C...Double precision and integer declarations.
57129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57130 IMPLICIT INTEGER(I-N)
57131 INTEGER PYK,PYCHGE,PYCOMP
57132C...Commonblocks.
57133 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57134 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57135 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57136 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57137 COMMON/PYDAT4/CHAF(500,2)
57138 CHARACTER CHAF*16
57139 COMMON/PYDATR/MRPY(6),RRPY(100)
57140 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
57141 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57142 COMMON/PYINT1/MINT(400),VINT(400)
57143 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
57144 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
57145 COMMON/PYINT4/MWID(500),WIDS(500,5)
57146 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
57147 COMMON/PYINT6/PROC(0:500)
57148 CHARACTER PROC*28
57149 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
57150 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
57151 &XPDIR(-6:6)
57152 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57153 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57154 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
57155 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
57156 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
57157 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
57158C...Local arrays and character variables.
57159 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
57160 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
57161 &CHINR*16,CHDIG*10
57162 DIMENSION MSVAR(54,8)
57163
57164C...For each variable to be translated give: name,
57165C...integer/real/character, no. of indices, lower&upper index bounds.
57166 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
57167 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
57168 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
57169 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
57170 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
57171 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
57172 &'ITCM','RTCM'/
57173 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
57174 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
57175 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
57176 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
57177 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
57178 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
57179 &1,1,1,6,4*0, 2,1,1,100,4*0,
57180 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
57181 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
57182 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
57183 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
57184 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
57185 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
57186 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
57187 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
57188 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
57189 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
57190 &1,1,0,99,4*0, 2,1,0,99,4*0/
57191 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
57192 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
57193
57194C...Length of character variable. Subdivide it into instructions.
57195 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
57196 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
57197 CHBIT=CHIN//' '
57198 LBIT=101
57199 100 LBIT=LBIT-1
57200 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
57201 LTOT=0
57202 DO 110 LCOM=1,LBIT
57203 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
57204 LTOT=LTOT+1
57205 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
57206 110 CONTINUE
57207 LLOW=0
57208 120 LHIG=LLOW+1
57209 130 LHIG=LHIG+1
57210 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
57211 LBIT=LHIG-LLOW-1
57212 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
57213
57214C...Send off decay-mode on/off commands to PYONOF.
57215 IONOF=0
57216 DO 135 LDIG=1,10
57217 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
57218 135 CONTINUE
57219 IF(IONOF.EQ.1) THEN
57220 CALL PYONOF(CHIN)
57221 RETURN
57222 ENDIF
57223
57224C...Peel off any text following exclamation mark.
57225 LHIG2=LBIT
57226 DO 140 LLOW2=LHIG2,1,-1
57227 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
57228 140 CONTINUE
57229 IF(LBIT.EQ.0) RETURN
57230
57231C...Identify commonblock variable.
57232 LNAM=1
57233 150 LNAM=LNAM+1
57234 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
57235 &LNAM.LE.6) GOTO 150
57236 CHNAM=CHBIT(1:LNAM-1)//' '
57237 DO 170 LCOM=1,LNAM-1
57238 DO 160 LALP=1,26
57239 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
57240 & CHALP(2)(LALP:LALP)
57241 160 CONTINUE
57242 170 CONTINUE
57243 IVAR=0
57244 DO 180 IV=1,54
57245 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
57246 180 CONTINUE
57247 IF(IVAR.EQ.0) THEN
57248 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
57249 LLOW=LHIG
57250 IF(LLOW.LT.LTOT) GOTO 120
57251 RETURN
57252 ENDIF
57253
57254C...Identify any indices.
57255 I1=0
57256 I2=0
57257 I3=0
57258 NINDX=0
57259 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
57260 LIND=LNAM
57261 190 LIND=LIND+1
57262 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
57263 CHIND=' '
57264 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
57265 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
57266 & IVAR.EQ.37)) THEN
57267 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
57268 READ(CHIND,'(I8)') KF
57269 I1=PYCOMP(KF)
57270 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
57271 & 'c') THEN
57272 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
57273 & CHNAM)
57274 LLOW=LHIG
57275 IF(LLOW.LT.LTOT) GOTO 120
57276 RETURN
57277 ELSE
57278 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
57279 READ(CHIND,'(I8)') I1
57280 ENDIF
57281 LNAM=LIND
57282 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
57283 NINDX=1
57284 ENDIF
57285 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
57286 LIND=LNAM
57287 200 LIND=LIND+1
57288 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
57289 CHIND=' '
57290 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
57291 READ(CHIND,'(I8)') I2
57292 LNAM=LIND
57293 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
57294 NINDX=2
57295 ENDIF
57296 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
57297 LIND=LNAM
57298 210 LIND=LIND+1
57299 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
57300 CHIND=' '
57301 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
57302 READ(CHIND,'(I8)') I3
57303 LNAM=LIND+1
57304 NINDX=3
57305 ENDIF
57306
57307C...Check that indices allowed.
57308 IERR=0
57309 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
57310 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
57311 &IERR=2
57312 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
57313 &IERR=3
57314 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
57315 &IERR=4
57316 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
57317 IF(IERR.GE.1) THEN
57318 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
57319 & CHBIT(1:LNAM-1))
57320 LLOW=LHIG
57321 IF(LLOW.LT.LTOT) GOTO 120
57322 RETURN
57323 ENDIF
57324
57325C...Save old value of variable.
57326 IF(IVAR.EQ.1) THEN
57327 IOLD=N
57328 ELSEIF(IVAR.EQ.2) THEN
57329 IOLD=K(I1,I2)
57330 ELSEIF(IVAR.EQ.3) THEN
57331 ROLD=P(I1,I2)
57332 ELSEIF(IVAR.EQ.4) THEN
57333 ROLD=V(I1,I2)
57334 ELSEIF(IVAR.EQ.5) THEN
57335 IOLD=MSTU(I1)
57336 ELSEIF(IVAR.EQ.6) THEN
57337 ROLD=PARU(I1)
57338 ELSEIF(IVAR.EQ.7) THEN
57339 IOLD=MSTJ(I1)
57340 ELSEIF(IVAR.EQ.8) THEN
57341 ROLD=PARJ(I1)
57342 ELSEIF(IVAR.EQ.9) THEN
57343 IOLD=KCHG(I1,I2)
57344 ELSEIF(IVAR.EQ.10) THEN
57345 ROLD=PMAS(I1,I2)
57346 ELSEIF(IVAR.EQ.11) THEN
57347 ROLD=PARF(I1)
57348 ELSEIF(IVAR.EQ.12) THEN
57349 ROLD=VCKM(I1,I2)
57350 ELSEIF(IVAR.EQ.13) THEN
57351 IOLD=MDCY(I1,I2)
57352 ELSEIF(IVAR.EQ.14) THEN
57353 IOLD=MDME(I1,I2)
57354 ELSEIF(IVAR.EQ.15) THEN
57355 ROLD=BRAT(I1)
57356 ELSEIF(IVAR.EQ.16) THEN
57357 IOLD=KFDP(I1,I2)
57358 ELSEIF(IVAR.EQ.17) THEN
57359 CHOLD=CHAF(I1,I2)(1:8)
57360 ELSEIF(IVAR.EQ.18) THEN
57361 IOLD=MRPY(I1)
57362 ELSEIF(IVAR.EQ.19) THEN
57363 ROLD=RRPY(I1)
57364 ELSEIF(IVAR.EQ.20) THEN
57365 IOLD=MSEL
57366 ELSEIF(IVAR.EQ.21) THEN
57367 IOLD=MSUB(I1)
57368 ELSEIF(IVAR.EQ.22) THEN
57369 IOLD=KFIN(I1,I2)
57370 ELSEIF(IVAR.EQ.23) THEN
57371 ROLD=CKIN(I1)
57372 ELSEIF(IVAR.EQ.24) THEN
57373 IOLD=MSTP(I1)
57374 ELSEIF(IVAR.EQ.25) THEN
57375 ROLD=PARP(I1)
57376 ELSEIF(IVAR.EQ.26) THEN
57377 IOLD=MSTI(I1)
57378 ELSEIF(IVAR.EQ.27) THEN
57379 ROLD=PARI(I1)
57380 ELSEIF(IVAR.EQ.28) THEN
57381 IOLD=MINT(I1)
57382 ELSEIF(IVAR.EQ.29) THEN
57383 ROLD=VINT(I1)
57384 ELSEIF(IVAR.EQ.30) THEN
57385 IOLD=ISET(I1)
57386 ELSEIF(IVAR.EQ.31) THEN
57387 IOLD=KFPR(I1,I2)
57388 ELSEIF(IVAR.EQ.32) THEN
57389 ROLD=COEF(I1,I2)
57390 ELSEIF(IVAR.EQ.33) THEN
57391 IOLD=ICOL(I1,I2,I3)
57392 ELSEIF(IVAR.EQ.34) THEN
57393 ROLD=XSFX(I1,I2)
57394 ELSEIF(IVAR.EQ.35) THEN
57395 IOLD=ISIG(I1,I2)
57396 ELSEIF(IVAR.EQ.36) THEN
57397 ROLD=SIGH(I1)
57398 ELSEIF(IVAR.EQ.37) THEN
57399 IOLD=MWID(I1)
57400 ELSEIF(IVAR.EQ.38) THEN
57401 ROLD=WIDS(I1,I2)
57402 ELSEIF(IVAR.EQ.39) THEN
57403 IOLD=NGEN(I1,I2)
57404 ELSEIF(IVAR.EQ.40) THEN
57405 ROLD=XSEC(I1,I2)
57406 ELSEIF(IVAR.EQ.41) THEN
57407 CHOLD2=PROC(I1)
57408 ELSEIF(IVAR.EQ.42) THEN
57409 ROLD=SIGT(I1,I2,I3)
57410 ELSEIF(IVAR.EQ.43) THEN
57411 ROLD=XPVMD(I1)
57412 ELSEIF(IVAR.EQ.44) THEN
57413 ROLD=XPANL(I1)
57414 ELSEIF(IVAR.EQ.45) THEN
57415 ROLD=XPANH(I1)
57416 ELSEIF(IVAR.EQ.46) THEN
57417 ROLD=XPBEH(I1)
57418 ELSEIF(IVAR.EQ.47) THEN
57419 ROLD=XPDIR(I1)
57420 ELSEIF(IVAR.EQ.48) THEN
57421 IOLD=IMSS(I1)
57422 ELSEIF(IVAR.EQ.49) THEN
57423 ROLD=RMSS(I1)
57424 ELSEIF(IVAR.EQ.50) THEN
57425 ROLD=RVLAM(I1,I2,I3)
57426 ELSEIF(IVAR.EQ.51) THEN
57427 ROLD=RVLAMP(I1,I2,I3)
57428 ELSEIF(IVAR.EQ.52) THEN
57429 ROLD=RVLAMB(I1,I2,I3)
57430 ELSEIF(IVAR.EQ.53) THEN
57431 IOLD=ITCM(I1)
57432 ELSEIF(IVAR.EQ.54) THEN
57433 ROLD=RTCM(I1)
57434 ENDIF
57435
57436C...Print current value of variable. Loop back.
57437 IF(LNAM.GE.LBIT) THEN
57438 CHBIT(LNAM:14)=' '
57439 CHBIT(15:60)=' has the value '
57440 IF(MSVAR(IVAR,1).EQ.1) THEN
57441 WRITE(CHBIT(51:60),'(I10)') IOLD
57442 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
57443 WRITE(CHBIT(47:60),'(F14.5)') ROLD
57444 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
57445 CHBIT(53:60)=CHOLD
57446 ELSE
57447 CHBIT(33:60)=CHOLD
57448 ENDIF
57449 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57450 LLOW=LHIG
57451 IF(LLOW.LT.LTOT) GOTO 120
57452 RETURN
57453 ENDIF
57454
57455C...Read in new variable value.
57456 IF(MSVAR(IVAR,1).EQ.1) THEN
57457 CHINI=' '
57458 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
57459 READ(CHINI,'(I10)') INEW
57460 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
57461 CHINR=' '
57462 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
57463 READ(CHINR,*) RNEW
57464 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
57465 CHNEW=CHBIT(LNAM+1:LBIT)//' '
57466 ELSE
57467 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
57468 ENDIF
57469
57470C...Store new variable value.
57471 IF(IVAR.EQ.1) THEN
57472 N=INEW
57473 ELSEIF(IVAR.EQ.2) THEN
57474 K(I1,I2)=INEW
57475 ELSEIF(IVAR.EQ.3) THEN
57476 P(I1,I2)=RNEW
57477 ELSEIF(IVAR.EQ.4) THEN
57478 V(I1,I2)=RNEW
57479 ELSEIF(IVAR.EQ.5) THEN
57480 MSTU(I1)=INEW
57481 ELSEIF(IVAR.EQ.6) THEN
57482 PARU(I1)=RNEW
57483 ELSEIF(IVAR.EQ.7) THEN
57484 MSTJ(I1)=INEW
57485 ELSEIF(IVAR.EQ.8) THEN
57486 PARJ(I1)=RNEW
57487 ELSEIF(IVAR.EQ.9) THEN
57488 KCHG(I1,I2)=INEW
57489 ELSEIF(IVAR.EQ.10) THEN
57490 PMAS(I1,I2)=RNEW
57491 ELSEIF(IVAR.EQ.11) THEN
57492 PARF(I1)=RNEW
57493 ELSEIF(IVAR.EQ.12) THEN
57494 VCKM(I1,I2)=RNEW
57495 ELSEIF(IVAR.EQ.13) THEN
57496 MDCY(I1,I2)=INEW
57497 ELSEIF(IVAR.EQ.14) THEN
57498 MDME(I1,I2)=INEW
57499 ELSEIF(IVAR.EQ.15) THEN
57500 BRAT(I1)=RNEW
57501 ELSEIF(IVAR.EQ.16) THEN
57502 KFDP(I1,I2)=INEW
57503 ELSEIF(IVAR.EQ.17) THEN
57504 CHAF(I1,I2)=CHNEW
57505 ELSEIF(IVAR.EQ.18) THEN
57506 MRPY(I1)=INEW
57507 ELSEIF(IVAR.EQ.19) THEN
57508 RRPY(I1)=RNEW
57509 ELSEIF(IVAR.EQ.20) THEN
57510 MSEL=INEW
57511 ELSEIF(IVAR.EQ.21) THEN
57512 MSUB(I1)=INEW
57513 ELSEIF(IVAR.EQ.22) THEN
57514 KFIN(I1,I2)=INEW
57515 ELSEIF(IVAR.EQ.23) THEN
57516 CKIN(I1)=RNEW
57517 ELSEIF(IVAR.EQ.24) THEN
57518 MSTP(I1)=INEW
57519 ELSEIF(IVAR.EQ.25) THEN
57520 PARP(I1)=RNEW
57521 ELSEIF(IVAR.EQ.26) THEN
57522 MSTI(I1)=INEW
57523 ELSEIF(IVAR.EQ.27) THEN
57524 PARI(I1)=RNEW
57525 ELSEIF(IVAR.EQ.28) THEN
57526 MINT(I1)=INEW
57527 ELSEIF(IVAR.EQ.29) THEN
57528 VINT(I1)=RNEW
57529 ELSEIF(IVAR.EQ.30) THEN
57530 ISET(I1)=INEW
57531 ELSEIF(IVAR.EQ.31) THEN
57532 KFPR(I1,I2)=INEW
57533 ELSEIF(IVAR.EQ.32) THEN
57534 COEF(I1,I2)=RNEW
57535 ELSEIF(IVAR.EQ.33) THEN
57536 ICOL(I1,I2,I3)=INEW
57537 ELSEIF(IVAR.EQ.34) THEN
57538 XSFX(I1,I2)=RNEW
57539 ELSEIF(IVAR.EQ.35) THEN
57540 ISIG(I1,I2)=INEW
57541 ELSEIF(IVAR.EQ.36) THEN
57542 SIGH(I1)=RNEW
57543 ELSEIF(IVAR.EQ.37) THEN
57544 MWID(I1)=INEW
57545 ELSEIF(IVAR.EQ.38) THEN
57546 WIDS(I1,I2)=RNEW
57547 ELSEIF(IVAR.EQ.39) THEN
57548 NGEN(I1,I2)=INEW
57549 ELSEIF(IVAR.EQ.40) THEN
57550 XSEC(I1,I2)=RNEW
57551 ELSEIF(IVAR.EQ.41) THEN
57552 PROC(I1)=CHNEW2
57553 ELSEIF(IVAR.EQ.42) THEN
57554 SIGT(I1,I2,I3)=RNEW
57555 ELSEIF(IVAR.EQ.43) THEN
57556 XPVMD(I1)=RNEW
57557 ELSEIF(IVAR.EQ.44) THEN
57558 XPANL(I1)=RNEW
57559 ELSEIF(IVAR.EQ.45) THEN
57560 XPANH(I1)=RNEW
57561 ELSEIF(IVAR.EQ.46) THEN
57562 XPBEH(I1)=RNEW
57563 ELSEIF(IVAR.EQ.47) THEN
57564 XPDIR(I1)=RNEW
57565 ELSEIF(IVAR.EQ.48) THEN
57566 IMSS(I1)=INEW
57567 ELSEIF(IVAR.EQ.49) THEN
57568 RMSS(I1)=RNEW
57569 ELSEIF(IVAR.EQ.50) THEN
57570 RVLAM(I1,I2,I3)=RNEW
57571 ELSEIF(IVAR.EQ.51) THEN
57572 RVLAMP(I1,I2,I3)=RNEW
57573 ELSEIF(IVAR.EQ.52) THEN
57574 RVLAMB(I1,I2,I3)=RNEW
57575 ELSEIF(IVAR.EQ.53) THEN
57576 ITCM(I1)=INEW
57577 ELSEIF(IVAR.EQ.54) THEN
57578 RTCM(I1)=RNEW
57579 ENDIF
57580
57581C...Write old and new value. Loop back.
57582 CHBIT(LNAM:14)=' '
57583 CHBIT(15:60)=' changed from to '
57584 IF(MSVAR(IVAR,1).EQ.1) THEN
57585 WRITE(CHBIT(33:42),'(I10)') IOLD
57586 WRITE(CHBIT(51:60),'(I10)') INEW
57587 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57588 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
57589 WRITE(CHBIT(29:42),'(F14.5)') ROLD
57590 WRITE(CHBIT(47:60),'(F14.5)') RNEW
57591 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57592 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
57593 CHBIT(35:42)=CHOLD
57594 CHBIT(53:60)=CHNEW
57595 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
57596 ELSE
57597 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
57598 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
57599 ENDIF
57600 LLOW=LHIG
57601 IF(LLOW.LT.LTOT) GOTO 120
57602
57603C...Format statement for output on unit MSTU(11) (by default 6).
57604 5000 FORMAT(5X,A60)
57605 5100 FORMAT(5X,A88)
57606
57607 RETURN
57608 END
57609
57610C*********************************************************************
57611
57612C...PYONOF
57613C...Switches on and off decay channel by search for match.
57614
57615 SUBROUTINE PYONOF(CHIN)
57616
57617C...Double precision and integer declarations.
57618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57619 IMPLICIT INTEGER(I-N)
57620 INTEGER PYK,PYCHGE,PYCOMP
57621C...Commonblocks.
57622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57623 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57624 SAVE /PYDAT1/,/PYDAT3/
57625C...Local arrays and character variables.
57626 INTEGER KFCMP(10),KFTMP(10)
57627 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
57628 &CHALP(2)*26
57629 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
57630 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
57631
57632C...Determine length of character variable.
57633 CHTMP=CHIN//' '
57634 LBEG=0
57635 100 LBEG=LBEG+1
57636 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
57637 LEND=LBEG-1
57638 105 LEND=LEND+1
57639 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
57640 110 LEND=LEND-1
57641 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
57642 LEN=1+LEND-LBEG
57643 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
57644
57645C...Find colon separator and particle code.
57646 LCOLON=0
57647 120 LCOLON=LCOLON+1
57648 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
57649 CHCODE=' '
57650 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
57651 READ(CHCODE,'(I8)',ERR=300) KF
57652 KC=PYCOMP(KF)
57653
57654C...Done if unknown code or no decay channels.
57655 IF(KC.EQ.0) THEN
57656 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
57657 RETURN
57658 ENDIF
57659 IDCBEG=MDCY(KC,2)
57660 IDCLEN=MDCY(KC,3)
57661 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
57662 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
57663 RETURN
57664 ENDIF
57665
57666C...Find command name up to blank or equal sign.
57667 LSEP=LCOLON
57668 130 LSEP=LSEP+1
57669 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
57670 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
57671 CHMODE=' '
57672 LMODE=LSEP-LCOLON-1
57673 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
57674
57675C...Convert to uppercase.
57676 DO 150 LCOM=1,LMODE
57677 DO 140 LALP=1,26
57678 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
57679 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
57680 140 CONTINUE
57681 150 CONTINUE
57682
57683C...Identify command. Failed if not identified.
57684 MODE=0
57685 IF(CHMODE.EQ.'ALLOFF') MODE=1
57686 IF(CHMODE.EQ.'ALLON') MODE=2
57687 IF(CHMODE.EQ.'OFFIFANY') MODE=3
57688 IF(CHMODE.EQ.'ONIFANY') MODE=4
57689 IF(CHMODE.EQ.'OFFIFALL') MODE=5
57690 IF(CHMODE.EQ.'ONIFALL') MODE=6
57691 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
57692 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
57693 IF(MODE.EQ.0) THEN
57694 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
57695 RETURN
57696 ENDIF
57697
57698C...Simple cases when all on or all off.
57699 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
57700 WRITE(MSTU(11),1000) KF,CHMODE
57701 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
57702 IF(MDME(IDC,1).LT.0) GOTO 160
57703 MDME(IDC,1)=MODE-1
57704 160 CONTINUE
57705 RETURN
57706 ENDIF
57707
57708C...Identify matching list.
57709 NCMP=0
57710 LBEG=LSEP
57711 170 LBEG=LBEG+1
57712 IF(LBEG.GT.LEN) GOTO 190
57713 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
57714 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
57715 LEND=LBEG-1
57716 180 LEND=LEND+1
57717 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
57718 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
57719 IF(LEND.LT.LEN) LEND=LEND-1
57720 CHCODE=' '
57721 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
57722 READ(CHCODE,'(I8)',ERR=300) KFREAD
57723 NCMP=NCMP+1
57724 KFCMP(NCMP)=IABS(KFREAD)
57725 LBEG=LEND
57726 IF(NCMP.LT.10) GOTO 170
57727 190 CONTINUE
57728 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
57729
57730C...Only one matching required.
57731 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
57732 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
57733 IF(MDME(IDC,1).LT.0) GOTO 220
57734 DO 210 IKF=1,5
57735 KFNOW=IABS(KFDP(IDC,IKF))
57736 IF(KFNOW.EQ.0) GOTO 210
57737 DO 200 ICMP=1,NCMP
57738 IF(KFCMP(ICMP).EQ.KFNOW) THEN
57739 MDME(IDC,1)=MODE-3
57740 GOTO 220
57741 ENDIF
57742 200 CONTINUE
57743 210 CONTINUE
57744 220 CONTINUE
57745 RETURN
57746 ENDIF
57747
57748C...Multiple matchings required.
57749 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
57750 IF(MDME(IDC,1).LT.0) GOTO 260
57751 NTMP=NCMP
57752 DO 230 ITMP=1,NTMP
57753 KFTMP(ITMP)=KFCMP(ITMP)
57754 230 CONTINUE
57755 NFIN=0
57756 DO 250 IKF=1,5
57757 KFNOW=IABS(KFDP(IDC,IKF))
57758 IF(KFNOW.EQ.0) GOTO 250
57759 NFIN=NFIN+1
57760 DO 240 ITMP=1,NTMP
57761 IF(KFTMP(ITMP).EQ.KFNOW) THEN
57762 KFTMP(ITMP)=KFTMP(NTMP)
57763 NTMP=NTMP-1
57764 GOTO 250
57765 ENDIF
57766 240 CONTINUE
57767 250 CONTINUE
57768 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
57769 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
57770 & MDME(IDC,1)=MODE-7
57771 260 CONTINUE
57772 RETURN
57773
57774C...Error exit for impossible read of particle code.
57775 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
57776 &//CHCODE)
57777
57778C...Formats for output.
57779 1000 FORMAT(' Decays for',I8,' set ',A10)
57780 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
57781
57782 RETURN
57783 END
57784
57785C*********************************************************************
57786
57787C...PYTUNE
57788C...Presets for a few specific underlying-event and min-bias tunes
57789C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
57790C...others require particular versions of pythia (e.g. the SCI and GAL
57791C...models). See below for details.
57792 SUBROUTINE PYTUNE(ITUNE)
57793C
57794C ITUNE NAME (detailed descriptions below)
57795C 0 Default : No settings changed => linked Pythia version's defaults.
57796C ====== Old UE, Q2-ordered showers ==========================================
57797C 100 A : Rick Field's Tune A
57798C 101 AW : Rick Field's Tune AW
57799C 102 BW : Rick Field's Tune BW
57800C 103 DW : Rick Field's Tune DW
57801C 104 DWT : Rick Field's Tune DW with slower UE energy scaling
57802C 105 QW : Rick Field's Tune QW (NB: needs CTEQ6.1 pdfs externally)
57803C 106 ATLAS : Arthur Moraes' ATLAS tune
57804C 107 ACR : Tune A modified with annealing CR
57805C ====== New UE, Q2-ordered showers ==========================================
57806C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
57807C ====== New UE, interleaved pT-ordered showers, annealing CR ================
57808C 300 S0 : Sandhoff-Skands Tune 0
57809C 301 S1 : Sandhoff-Skands Tune 1
57810C 302 S2 : Sandhoff-Skands Tune 2
57811C 303 S0A : S0 with "Tune A" UE energy scaling
57812C 304 NOCR : New UE "best try" without colour reconnections.
57813C 305 Old : New UE, original (primitive) colour reconnections
57814C ======= The Uppsala models =================================================
57815C ( NB! must be run with special modified Pythia 6.215 version )
57816C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
57817C 400 GAL 0 : Generalized area-law model. Old parameters.
57818C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters.
57819C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned.
57820C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned.
57821C
57822C More details;
57823C
57824C Quick Dictionary:
57825C BE : Bose-Einstein
57826C BR : Beam Remnants
57827C CR : Colour Reconnections
57828C HAD: Hadronization
57829C ISR/FSR: Initial-State Radiation / Final-State Radiation
57830C FSI: Final-State Interactions (=CR+BE)
57831C MB : Minimum-bias
57832C MI : Multiple Interactions
57833C UE : Underlying Event
57834C
57835C A (100) and AW (101). Old UE model, Q2-ordered showers.
57836C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57837C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57838C...Key feature: extensively compared to CDF data (R.D. Field).
57839C...* Large starting scale for ISR (PARP(67)=4)
57840C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
57841C...* See: http://www.phys.ufl.edu/~rfield/cdf/
57842C
57843C BW (102). Old UE model, Q2-ordered showers.
57844C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57845C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57846C...Key feature: extensively compared to CDF data (R.D. Field).
57847C...NB: Can also be run with Pythia 6.2 or 6.312+
57848C...* Small starting scale for ISR (PARP(67)=1)
57849C...* BW has more radiation due to smaller mu_R choice in alpha_s.
57850C...* See: http://www.phys.ufl.edu/~rfield/cdf/
57851C
57852C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
57853C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57854C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57855C...Key feature: extensively compared to CDF data (R.D. Field).
57856C...NB: Can also be run with Pythia 6.2 or 6.312+
57857C...* Intermediate starting scale for ISR (PARP(67)=2.5)
57858C...* DWT has a different reference energy, the same as the "S" models
57859C... below, leading to more UE activity at the LHC, but less at RHIC.
57860C...* See: http://www.phys.ufl.edu/~rfield/cdf/
57861C
57862C QW (105). Old UE model, Q2-ordered showers.
57863C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57864C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57865C...Key feature: uses CTEQ61 (external pdf library must be linked)
57866C
57867C ATLAS (106). Old UE model, Q2-ordered showers.
57868C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
57869C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
57870C...Key feature: tune used by the ATLAS collaboration.
57871C
57872C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
57873C...*** NB : SHOULD BE RUN WITH PYTHIA 6.408+ ***
57874C...Key feature: Tune A modified to use annealing CR.
57875C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
57876C
57877C...IM1 (200). Intermediate model, Q2-ordered showers.
57878C...Key feature: new UE model with Q2-ordered showers and no interleaving.
57879C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
57880C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
57881C
57882C S0 (300) and S0A (303). New UE model, pT-ordered showers.
57883C...Key feature: large amount of multiple interactions
57884C...* Somewhat faster than the other colour annealing scenarios.
57885C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
57886C... from Tune A, leading to less UE at the LHC, but more at RHIC.
57887C...* Small amount of radiation.
57888C...* Large amount of low-pT MI
57889C...* Low degree of proton lumpiness (broad matter dist.)
57890C...* CR Type S (driven by free triplets), of medium strength.
57891C...* See: Pythia6402 update notes or later.
57892C
57893C S1 (301). New UE model, pT-ordered showers.
57894C...Key feature: large amount of radiation.
57895C...* Large amount of low-pT perturbative ISR
57896C...* Large amount of FSR off ISR partons
57897C...* Small amount of low-pT multiple interactions
57898C...* Moderate degree of proton lumpiness
57899C...* Least aggressive CR type (S+S Type I), but with large strength
57900C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
57901C
57902C S2 (302). New UE model, pT-ordered showers.
57903C...Key feature: very lumpy proton + gg string cluster formation allowed
57904C...* Small amount of radiation
57905C...* Moderate amount of low-pT MI
57906C...* High degree of proton lumpiness (more spiky matter distribution)
57907C...* Most aggressive CR type (S+S Type II), but with small strength
57908C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
57909C
57910C NOCR (304). New UE model, pT-ordered showers.
57911C...Key feature: no colour reconnections (NB: "Best fit" only).
57912C...* NB: <pT>(Nch) problematic in this tune.
57913C...* Small amount of radiation
57914C...* Small amount of low-pT MI
57915C...* Low degree of proton lumpiness
57916C...* Large BR composite x enhancement factor
57917C...* Most clever colour flow without CR ("Lambda ordering")
57918C
57919C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
57920C...with an unmodified Pythia distribution.
57921C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
57922C
57923C ::: + Future improvements?
57924C Include also QCD K-factor a la M. Heinz / ATLAS TDR ?
57925C (problem: K-factor affects everything so only works as
57926C intended for min-bias, not for UE ... probably need a
57927C better long-term solution to handle UE as well. Anyway,
57928C Mark uses MSTP(33) and PARP(31)-PARP(33).)
57929
57930C...Global statements
57931 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57932 INTEGER PYK,PYCHGE,PYCOMP
57933
57934C...Commonblocks.
57935 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57936 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57937
57938C...SCI and GAL Commonblocks
57939 COMMON /SCIPAR/MSWI(2),PARSCI(2)
57940
57941C...Internal parameters
57942 PARAMETER(MXTUNS=500)
57943 CHARACTER*8 CHVERS, CHDOC
57944 PARAMETER (CHVERS='1.000 ',CHDOC='Oct 2006')
57945 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
57946 CHARACTER*40 CHMSTJ(20), CHMSTP(51:100), CHPARP(61:100),
57947 & CHPARJ(41:100), CH40
57948 CHARACTER*60 CH60
57949 CHARACTER*70 CH70
57950 DATA (CHNAMS(I),I=0,1)/'Default',' '/
57951 DATA (CHNAMS(I),I=100,110)/
57952 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
57953 & 'ATLAS Tune','Tune ACR',3*' '/
57954 DATA (CHNAMS(I),I=300,310)/
57955 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',5*' '/
57956 DATA (CHNAMS(I),I=200,210)/
57957 & 'IM Tune 1',10*' '/
57958 DATA (CHNAMS(I),I=400,410)/
57959 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
57960 DATA (CHMSTJ(I),I=11,20)/
57961 & 5*' ','HAD treatment of small-mass systems',4*' '/
57962 DATA (CHMSTP(I),I=51,100)/
57963 5 'PDF set','PDF set internal (=1) or pdflib (=2)',
57964 6 8*' ','ISR master switch',8*' ',
57965 7 'ISR IR regularization scheme',' ',
57966 7 'ISR scheme for FSR off ISR',8*' ',
57967 8 'UE model',
57968 8 'UE hadron transverse mass distribution',5*' ',
57969 8 'BR composite scheme','BR colour scheme',1*' ',
57970 9 'BR primordial kT distribution',
57971 9 'BR energy partitioning scheme',2*' ',
57972 9 'FSI colour (re-)connection model',5*' '/
57973 DATA (CHPARP(I),I=61,100)/
57974 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
57975 6 2*' ','ISR Q2max factor',3*' ',
57976 7 'FSR Q2max factor for non-s-channel procs',5*' ',
57977 7 'FSI colour reconnection turnoff scale',
57978 7 'FSI colour reconnection strength',
57979 7 'BR composite x enhancement','BR breakup suppression',
57980 8 2*'UE IR cutoff at reference ecm',
57981 8 2*'UE mass distribution parameter',
57982 8 'UE gg colour correlated fraction','UE total gg fraction',
57983 8 2*' ',
57984 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
57985 9 'BR primordial kT width <|kT|>',' ',
57986 9 'BR primordial kT UV cutoff',7*' '/
57987 DATA (CHPARJ(I),I=41,90)/
57988 4 ' ','HAD string parameter b',8*' ',10*' ',10*' ',10*' ',
57989 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
57990 SAVE /PYDAT1/,/PYPARS/
57991 SAVE /SCIPAR/
57992
57993C...1) Shorthand notation
57994 M13=MSTU(13)
57995 M11=MSTU(11)
57996 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
57997 CHNAME=CHNAMS(ITUNE)
57998 IF (ITUNE.EQ.0) GOTO 9999
57999 ELSE
58000 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
58001 GOTO 9999
58002 ENDIF
58003
58004C...2) Hello World
58005 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
58006
58007C...3) Tune parameters
58008
58009C=============================================================================
58010C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
58011 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
58012 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
58013 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
58014 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
58015 & ' with tune.')
58016 ENDIF
58017
58018C...PDFs
58019 MSTP(52)=1
58020 MSTP(51)=7
58021C...ISR
58022 PARP(64)=1D0
58023C...UE on, new model.
58024 MSTP(81)=21
58025C...Slow IR cutoff energy scaling by default
58026 PARP(89)=1800D0
58027 PARP(90)=0.16D0
58028C...Switch off trial joinings
58029 MSTP(96)=0
58030C...Primordial kT cutoff
58031 PARP(93)=5D0
58032
58033C...S0 (300), S0A (303)
58034 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
58035 IF (M13.GE.1) THEN
58036 CH60='see PYTHIA 6.402+ update notes,'
58037 WRITE(M11,5030) CH60
58038 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120,'
58039 WRITE(M11,5030) CH60
58040 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
58041 WRITE(M11,5030) CH60
58042 ENDIF
58043C...Smooth ISR, low FSR
58044 MSTP(70)=2
58045 MSTP(72)=0
58046C...pT0
58047 PARP(82)=1.85D0
58048C...Transverse density profile.
58049 MSTP(82)=5
58050 PARP(83)=1.6D0
58051C...Colour Reconnections
58052 MSTP(95)=6
58053 PARP(78)=0.20D0
58054 PARP(77)=0.0D0
58055C... Reference energy for pT0 and energy scaling pace.
58056 IF (ITUNE.EQ.303) PARP(90)=0.25D0
58057C...Lambda_FSR scale.
58058 PARJ(81)=0.14D0
58059C...FSR activity.
58060 PARP(71)=4D0
58061C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
58062 MSTP(89)=1
58063 MSTP(88)=0
58064 PARP(79)=2D0
58065 PARP(80)=0.01D0
58066
58067C... S1 (301)
58068 ELSEIF(ITUNE.EQ.301) THEN
58069 IF (M13.GE.1) THEN
58070 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
58071 WRITE(M11,5030) CH60
58072 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
58073 WRITE(M11,5030) CH60
58074 ENDIF
58075C... Sharp ISR, high FSR
58076 MSTP(70)=0
58077 MSTP(72)=1
58078C... pT0
58079 PARP(82)=2.1D0
58080C... Colour Reconnections
58081 MSTP(95)=2
58082 PARP(78)=0.35D0
58083C... Transverse density profile.
58084 MSTP(82)=5
58085 PARP(83)=1.4D0
58086C... Lambda_FSR scale.
58087 PARJ(81)=0.14D0
58088C... FSR activity.
58089 PARP(71)=4D0
58090C... Rap order, Valence qq, qq x enhc, BR-g-BR supp
58091 MSTP(89)=1
58092 MSTP(88)=0
58093 PARP(79)=2D0
58094 PARP(80)=0.01D0
58095
58096C... S2 (302)
58097 ELSEIF(ITUNE.EQ.302) THEN
58098 IF (M13.GE.1) THEN
58099 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
58100 WRITE(M11,5030) CH60
58101 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
58102 WRITE(M11,5030) CH60
58103 ENDIF
58104C... Smooth ISR, low FSR
58105 MSTP(70)=2
58106 MSTP(72)=0
58107C... pT0
58108 PARP(82)=1.9D0
58109C... Transverse density profile.
58110 MSTP(82)=5
58111 PARP(83)=1.2D0
58112C... Colour Reconnections
58113 MSTP(95)=4
58114 PARP(78)=0.15D0
58115C... Lambda_FSR scale.
58116 PARJ(81)=0.14D0
58117C... FSR activity.
58118 PARP(71)=4D0
58119C... Rap order, Valence qq, qq x enhc, BR-g-BR supp
58120 MSTP(89)=1
58121 MSTP(88)=0
58122 PARP(79)=2D0
58123 PARP(80)=0.01D0
58124
58125C... NOCR (304)
58126 ELSEIF(ITUNE.EQ.304) THEN
58127 IF (M13.GE.1) THEN
58128 CH60='"best try" without colour reconnections'
58129 WRITE(M11,5030) CH60
58130 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
58131 WRITE(M11,5030) CH60
58132 ENDIF
58133C... Smooth ISR, low FSR
58134 MSTP(70)=2
58135 MSTP(72)=0
58136C... pT0
58137 PARP(82)=2.05D0
58138C... Transverse density profile.
58139 MSTP(82)=5
58140 PARP(83)=1.8D0
58141C... Colour Reconnections
58142 MSTP(95)=0
58143C... Lambda_FSR scale.
58144 PARJ(81)=0.14D0
58145C... FSR activity.
58146 PARP(71)=4D0
58147C... Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
58148 MSTP(89)=2
58149 MSTP(88)=0
58150 PARP(79)=3D0
58151 PARP(80)=0.01D0
58152
58153C..."Lo FSR" retune (305)
58154 ELSEIF(ITUNE.EQ.305) THEN
58155 IF (M13.GE.1) THEN
58156 CH60='"Lo FSR retune" with primitive colour reconnections'
58157 WRITE(M11,5030) CH60
58158 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
58159 WRITE(M11,5030) CH60
58160 ENDIF
58161C... Smooth ISR, low FSR
58162 MSTP(70)=2
58163 MSTP(72)=0
58164C... pT0
58165 PARP(82)=1.9D0
58166C... Transverse density profile.
58167 MSTP(82)=5
58168 PARP(83)=2.0D0
58169C... Colour Reconnections
58170 MSTP(95)=1
58171 PARP(78)=1.0D0
58172C... Lambda_FSR scale.
58173 PARJ(81)=0.14D0
58174C... FSR activity.
58175 PARP(71)=4D0
58176C... Rap order, Valence qq, qq x enhc, BR-g-BR supp
58177 MSTP(89)=1
58178 MSTP(88)=0
58179 PARP(79)=2D0
58180 PARP(80)=0.01D0
58181 ENDIF
58182C... Output
58183 IF (M13.GE.1) THEN
58184 WRITE(M11,5030) ' '
58185 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58186 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58187 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58188 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
58189 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
58190 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58191 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58192 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58193 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58194 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58195 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58196 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58197 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58198 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
58199 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
58200 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
58201 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
58202 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58203 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
58204 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
58205 ENDIF
58206
58207C=============================================================================
58208C...Tunes A, AW, BW, DW, DWT, and QW (by R.D. Field, CDF) (100-105)
58209C...and ATLAS Tune (by A. Moraes, ATLAS) (106)
58210 ELSEIF (ITUNE.GE.100.AND.ITUNE.LE.106) THEN
58211 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
58212 WRITE(M11,5010) ITUNE, CHNAME
58213 CH60='see R.D. Field (CDF), in hep-ph/0610012'
58214 WRITE(M11,5030) CH60
58215 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58216 WRITE(M11,5030) CH60
58217 ENDIF
58218C...Multiple interactions on, old framework
58219 MSTP(81)=1
58220C...Fast IR cutoff energy scaling by default
58221 PARP(89)=1800D0
58222 PARP(90)=0.25D0
58223C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
58224 MSTP(51)=7
58225 MSTP(52)=1
58226 IF (ITUNE.EQ.105) THEN
58227 MSTP(51)=10150
58228 MSTP(52)=2
58229 ENDIF
58230C...Double Gaussian matter distribution.
58231 MSTP(82)=4
58232 PARP(83)=0.5D0
58233 PARP(84)=0.4D0
58234C...FSR activity.
58235 PARP(71)=4D0
58236C...Lambda_FSR scale.
58237 PARJ(81)=0.29D0
58238
58239C...Tune A and AW
58240 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
58241C...pT0.
58242 PARP(82)=2.0D0
58243c...String drawing almost completely minimizes string length.
58244 PARP(85)=0.9D0
58245 PARP(86)=0.95D0
58246C...ISR cutoff, muR scale factor, and phase space size
58247 PARP(62)=1D0
58248 PARP(64)=1D0
58249 PARP(67)=4D0
58250C...Intrinsic kT, size, and max
58251 MSTP(91)=1
58252 PARP(91)=1D0
58253 PARP(93)=5D0
58254C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
58255 IF (ITUNE.EQ.101) THEN
58256 PARP(62)=1.25D0
58257 PARP(64)=0.2D0
58258 PARP(91)=2.1D0
58259 PARP(92)=15.0D0
58260 ENDIF
58261
58262C... Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
58263 ELSEIF (ITUNE.EQ.102) THEN
58264C... pT0.
58265 PARP(82)=1.9D0
58266c... String drawing completely minimizes string length.
58267 PARP(85)=1.0D0
58268 PARP(86)=1.0D0
58269C... ISR cutoff, muR scale factor, and phase space size
58270 PARP(62)=1.25D0
58271 PARP(64)=0.2D0
58272 PARP(67)=1D0
58273C... Intrinsic kT, size, and max
58274 MSTP(91)=1
58275 PARP(91)=2.1D0
58276 PARP(93)=15D0
58277
58278C... Tune DW
58279 ELSEIF (ITUNE.EQ.103) THEN
58280C... pT0.
58281 PARP(82)=1.9D0
58282c... String drawing completely minimizes string length.
58283 PARP(85)=1.0D0
58284 PARP(86)=1.0D0
58285C... ISR cutoff, muR scale factor, and phase space size
58286 PARP(62)=1.25D0
58287 PARP(64)=0.2D0
58288 PARP(67)=2.5D0
58289C... Intrinsic kT, size, and max
58290 MSTP(91)=1
58291 PARP(91)=2.1D0
58292 PARP(93)=15D0
58293
58294C... Tune DWT
58295 ELSEIF (ITUNE.EQ.104) THEN
58296C... pT0.
58297 PARP(82)=1.9409D0
58298C... Run II ref scale and slow scaling
58299 PARP(89)=1960D0
58300 PARP(90)=0.16D0
58301c... String drawing completely minimizes string length.
58302 PARP(85)=1.0D0
58303 PARP(86)=1.0D0
58304C... ISR cutoff, muR scale factor, and phase space size
58305 PARP(62)=1.25D0
58306 PARP(64)=0.2D0
58307 PARP(67)=2.5D0
58308C... Intrinsic kT, size, and max
58309 MSTP(91)=1
58310 PARP(91)=2.1D0
58311 PARP(93)=15D0
58312
58313C...Tune QW
58314 ELSEIF(ITUNE.EQ.105) THEN
58315 IF (M13.GE.1) THEN
58316 WRITE(M11,5030) ' '
58317 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
58318 & 'externally linked and'
58319 WRITE(M11,5035) CH70
58320 CH70='MSTP(51) should be set manually according to '//
58321 & 'the library used'
58322 WRITE(M11,5035) CH70
58323 ENDIF
58324C... pT0.
58325 PARP(82)=1.1D0
58326c... String drawing completely minimizes string length.
58327 PARP(85)=1.0D0
58328 PARP(86)=1.0D0
58329C... ISR cutoff, muR scale factor, and phase space size
58330 PARP(62)=1.25D0
58331 PARP(64)=0.2D0
58332 PARP(67)=2.5D0
58333C... Intrinsic kT, size, and max
58334 MSTP(91)=1
58335 PARP(91)=2.1D0
58336 PARP(93)=15D0
58337
58338C...ATLAS Tune
58339 ELSEIF(ITUNE.EQ.106) THEN
58340 IF (M13.GE.1) THEN
58341 WRITE(M11,5010) ITUNE, CHNAME
58342 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
58343 WRITE(M11,5030) CH60
58344 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58345 WRITE(M11,5030) CH60
58346 ENDIF
58347C... pT0.
58348 PARP(82)=1.8D0
58349C... Different ref and rescaling pacee
58350 PARP(89)=1000D0
58351 PARP(90)=0.16D0
58352C... Parameters of mass distribution
58353 PARP(83)=0.5D0
58354 PARP(84)=0.5D0
58355C... Old default string drawing
58356 PARP(85)=0.33D0
58357 PARP(86)=0.66D0
58358C... ISR, phase space equivalent to Tune B
58359 PARP(62)=1D0
58360 PARP(64)=1D0
58361 PARP(67)=1D0
58362C... FSR
58363 PARP(71)=4D0
58364 PARJ(81)=0.29D0
58365C... Intrinsic kT
58366 MSTP(91)=1
58367 PARP(91)=1D0
58368 PARP(93)=5D0
58369 ENDIF
58370
58371C... Output
58372 IF (M13.GE.1) THEN
58373 WRITE(M11,5030) ' '
58374 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58375 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58376 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58377 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58378 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
58379 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58380 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58381 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58382 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58383 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58384 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58385 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58386 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58387 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
58388 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
58389 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
58390 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
58391 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
58392 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58393 ENDIF
58394
58395C=============================================================================
58396C... ACR, tune A with new CR (107)
58397 ELSEIF(ITUNE.EQ.107) THEN
58398 IF (M13.GE.1) THEN
58399 WRITE(M11,5010) ITUNE, CHNAME
58400 CH60='Tune A modified with new colour reconnections'
58401 WRITE(M11,5030) CH60
58402 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
58403 WRITE(M11,5030) CH60
58404 ENDIF
58405 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
58406 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
58407 & ' with tune. Using defaults.')
58408 GOTO 9998
58409 ENDIF
58410 MSTP(81)=1
58411 PARP(89)=1800D0
58412 PARP(90)=0.25D0
58413 MSTP(82)=4
58414 PARP(83)=0.5D0
58415 PARP(84)=0.4D0
58416 MSTP(51)=7
58417 MSTP(52)=1
58418 PARP(71)=4D0
58419 PARJ(81)=0.29D0
58420 PARP(82)=2.0D0
58421 PARP(85)=0.0D0
58422 PARP(86)=0.66D0
58423 PARP(62)=1D0
58424 PARP(64)=1D0
58425 PARP(67)=4D0
58426 MSTP(91)=1
58427 PARP(91)=1D0
58428 PARP(93)=5D0
58429 MSTP(95)=6
58430 PARP(78)=0.25D0
58431C...Output
58432 IF (M13.GE.1) THEN
58433 WRITE(M11,5030) ' '
58434 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58435 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58436 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58437 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58438 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
58439 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58440 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58441 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58442 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58443 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58444 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58445 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58446 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58447 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
58448 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
58449 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
58450 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
58451 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
58452 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58453 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
58454 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
58455 ENDIF
58456
58457C=============================================================================
58458C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
58459 ELSEIF(ITUNE.EQ.200) THEN
58460 IF (M13.GE.1) THEN
58461 WRITE(M11,5010) ITUNE, CHNAME
58462 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
58463 WRITE(M11,5030) CH60
58464 ENDIF
58465 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
58466 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
58467 & ' with tune.')
58468 ENDIF
58469C...PDF
58470 MSTP(51)=7
58471 MSTP(52)=1
58472C...ISR
58473 PARP(62)=1D0
58474 PARP(64)=1D0
58475 PARP(67)=4D0
58476C...FSR
58477 PARP(71)=4D0
58478 PARJ(81)=0.29D0
58479C...UE
58480 MSTP(81)=11
58481 PARP(82)=2.25D0
58482 PARP(89)=1800D0
58483 PARP(90)=0.25D0
58484C... ExpOfPow(1.8) overlap profile
58485 MSTP(82)=5
58486 PARP(83)=1.8D0
58487C... Valence qq
58488 MSTP(88)=0
58489C... Rap Tune
58490 MSTP(89)=1
58491C... Default diquark, BR-g-BR supp
58492 PARP(79)=2D0
58493 PARP(80)=0.01D0
58494C... Final state reconnect.
58495 MSTP(95)=1
58496 PARP(78)=0.55D0
58497C... Output
58498 IF (M13.GE.1) THEN
58499 WRITE(M11,5030) ' '
58500 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
58501 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
58502 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58503 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
58504 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
58505 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
58506 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
58507 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58508 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58509 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
58510 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
58511 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58512 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58513 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
58514 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
58515 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
58516 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
58517 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
58518 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
58519 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
58520 ENDIF
58521
58522C=============================================================================
58523C...Uppsala models: Generalized Area Law and Soft Colour Interactions
58524 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
58525 IF (M13.GE.1) THEN
58526 WRITE(M11,5010) ITUNE, CHNAME
58527 CH60='see J. Rathsman, PLB452(1999)364'
58528 WRITE(M11,5030) CH60
58529C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
58530C ? WRITE(M11,5030)
58531 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58532 WRITE(M11,5030) CH60
58533 WRITE(M11,5030) ' '
58534 CH70='NB! The GAL model must be run with modified '//
58535 & 'Pythia v6.215:'
58536 WRITE(M11,5035) CH70
58537 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
58538 WRITE(M11,5035) CH70
58539 WRITE(M11,5030) ' '
58540 ENDIF
58541C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
58542 MSWI(2) = 3
58543 PARSCI(2) = 0.10
58544 MSWI(1) = 2
58545 PARSCI(1) = 0.44
58546 MSTJ(16) = 0
58547 PARJ(42) = 0.45
58548 PARJ(82) = 2.0
58549 PARP(62) = 2.0
58550 MSTP(81) = 1
58551 MSTP(82) = 1
58552 PARP(81) = 1.9
58553 MSTP(92) = 1
58554 IF(CHNAME.EQ.'GAL Tune 1') THEN
58555C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
58556 MSTP(82)=4
58557 PARP(83)=0.25D0
58558 PARP(84)=0.5D0
58559 PARP(82) = 1.75
58560 IF (M13.GE.1) THEN
58561 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58562 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58563 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58564 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58565 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
58566 ENDIF
58567 ELSE
58568 IF (M13.GE.1) THEN
58569 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58570 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
58571 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58572 ENDIF
58573 ENDIF
58574C...Output
58575 IF (M13.GE.1) THEN
58576 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58577 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
58578 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
58579 CH40='FSI SCI/GAL selection'
58580 WRITE(M11,6040) 1, MSWI(1), CH40
58581 CH40='FSI SCI/GAL sea quark treatment'
58582 WRITE(M11,6040) 2, MSWI(2), CH40
58583 CH40='FSI SCI/GAL sea quark treatment parm'
58584 WRITE(M11,6050) 1, PARSCI(1), CH40
58585 CH40='FSI SCI/GAL string reco probability R_0'
58586 WRITE(M11,6050) 2, PARSCI(2), CH40
58587 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
58588 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
58589 ENDIF
58590 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
58591 IF (M13.GE.1) THEN
58592 WRITE(M11,5010) ITUNE, CHNAME
58593 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
58594 WRITE(M11,5030) CH60
58595 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
58596 WRITE(M11,5030) CH60
58597 WRITE(M11,5030) ' '
58598 CH70='NB! The SCI model must be run with modified '//
58599 & 'Pythia v6.215:'
58600 WRITE(M11,5035) CH70
58601 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
58602 WRITE(M11,5035) CH70
58603 WRITE(M11,5030) ' '
58604 ENDIF
58605C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
58606 MSTP(81)=1
58607 MSTP(82)=1
58608 PARP(81)=2.2
58609 MSTP(92)=1
58610 MSWI(2)=2
58611 PARSCI(2)=0.50
58612 MSWI(1)=2
58613 PARSCI(1)=0.44
58614 MSTJ(16)=0
58615 IF (CHNAME.EQ.'SCI Tune 1') THEN
58616C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
58617 MSTP(81) = 1
58618 MSTP(82) = 3
58619 PARP(82) = 2.4
58620 PARP(83) = 0.5D0
58621 PARP(62) = 1.5
58622 PARP(84)=0.25D0
58623 IF (M13.GE.1) THEN
58624 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58625 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
58626 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58627 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
58628 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
58629 ENDIF
58630 ELSE
58631 IF (M13.GE.1) THEN
58632 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
58633 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
58634 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
58635 ENDIF
58636 ENDIF
58637C...Output
58638 IF (M13.GE.1) THEN
58639 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
58640 CH40='FSI SCI/GAL selection'
58641 WRITE(M11,6040) 1, MSWI(1), CH40
58642 CH40='FSI SCI/GAL sea quark treatment'
58643 WRITE(M11,6040) 2, MSWI(2), CH40
58644 CH40='FSI SCI/GAL sea quark treatment parm'
58645 WRITE(M11,6050) 1, PARSCI(1), CH40
58646 CH40='FSI SCI/GAL string reco probability R_0'
58647 WRITE(M11,6050) 2, PARSCI(2), CH40
58648 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
58649 ENDIF
58650
58651 ELSE
58652 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
58653
58654 ENDIF
58655
58656 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
58657
58658 9999 RETURN
58659
58660 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
58661 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
58662 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
58663 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
58664 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
58665 5030 FORMAT(' *',3x,10x,A60,3x,'*')
58666 5035 FORMAT(' *',3x,A70,3x,'*')
58667 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A40,5x,'*')
58668 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
58669 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
58670 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
58671 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
58672 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
58673 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
58674 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
58675 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
58676
58677 END
58678
58679C*********************************************************************
58680
58681C...PYEXEC
58682C...Administrates the fragmentation and decay chain.
58683
58684 SUBROUTINE PYEXEC
58685
58686C...Double precision and integer declarations.
58687 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58688 IMPLICIT INTEGER(I-N)
58689 INTEGER PYK,PYCHGE,PYCOMP
58690C...Commonblocks.
58691 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58692 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58693 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58694 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58695 COMMON/PYINT1/MINT(400),VINT(400)
58696 COMMON/PYINT4/MWID(500),WIDS(500,5)
58697 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
58698C...Local array.
58699 DIMENSION PS(2,6),IJOIN(100)
58700
58701C...Initialize and reset.
58702 MSTU(24)=0
58703 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58704 MSTU(29)=0
58705 MSTU(31)=MSTU(31)+1
58706 MSTU(1)=0
58707 MSTU(2)=0
58708 MSTU(3)=0
58709 IF(MSTU(17).LE.0) MSTU(90)=0
58710 MCONS=1
58711
58712C...Sum up momentum, energy and charge for starting entries.
58713 NSAV=N
58714 DO 110 I=1,2
58715 DO 100 J=1,6
58716 PS(I,J)=0D0
58717 100 CONTINUE
58718 110 CONTINUE
58719 DO 130 I=1,N
58720 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
58721 DO 120 J=1,4
58722 PS(1,J)=PS(1,J)+P(I,J)
58723 120 CONTINUE
58724 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
58725 130 CONTINUE
58726 PARU(21)=PS(1,4)
58727
58728C...Start by all decays of coloured resonances involved in shower.
58729 NORIG=N
58730 DO 140 I=1,NORIG
58731 IF(K(I,1).EQ.3) THEN
58732 KC=PYCOMP(K(I,2))
58733 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
58734 ENDIF
58735 140 CONTINUE
58736
58737C...Prepare system for subsequent fragmentation/decay.
58738 CALL PYPREP(0)
58739 IF(MINT(51).NE.0) RETURN
58740
58741C...Loop through jet fragmentation and particle decays.
58742 MBE=0
58743 150 MBE=MBE+1
58744 IP=0
58745 160 IP=IP+1
58746 KC=0
58747 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
58748 IF(KC.EQ.0) THEN
58749
58750C...Deal with any remaining undecayed resonance
58751C...(normally the task of PYEVNT, so seldom used).
58752 ELSEIF(MWID(KC).NE.0) THEN
58753 IBEG=IP
58754 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
58755 IBEG=IP+1
58756 170 IBEG=IBEG-1
58757 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
58758 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
58759 IEND=IP-1
58760 180 IEND=IEND+1
58761 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
58762 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
58763 NJOIN=0
58764 DO 190 I=IBEG,IEND
58765 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
58766 NJOIN=NJOIN+1
58767 IJOIN(NJOIN)=I
58768 ENDIF
58769 190 CONTINUE
58770 ENDIF
58771 CALL PYRESD(IP)
58772 CALL PYPREP(IBEG)
58773 IF(MINT(51).NE.0) RETURN
58774
58775C...Particle decay if unstable and allowed. Save long-lived particle
58776C...decays until second pass after Bose-Einstein effects.
58777 ELSEIF(KCHG(KC,2).EQ.0) THEN
58778 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
58779 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
58780 & CALL PYDECY(IP)
58781
58782C...Decay products may develop a shower.
58783 IF(MSTJ(92).GT.0) THEN
58784 IP1=MSTJ(92)
58785 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
58786 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
58787 MINT(33)=0
58788 CALL PYSHOW(IP1,IP1+1,QMAX)
58789 CALL PYPREP(IP1)
58790 IF(MINT(51).NE.0) RETURN
58791 MSTJ(92)=0
58792 ELSEIF(MSTJ(92).LT.0) THEN
58793 IP1=-MSTJ(92)
58794 MINT(33)=0
58795 CALL PYSHOW(IP1,-3,P(IP,5))
58796 CALL PYPREP(IP1)
58797 IF(MINT(51).NE.0) RETURN
58798 MSTJ(92)=0
58799 ENDIF
58800
58801C...Jet fragmentation: string or independent fragmentation.
58802 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
58803 MFRAG=MSTJ(1)
58804 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
58805 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
58806 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
58807 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
58808 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
58809 ENDIF
58810 ENDIF
58811 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
58812 IF(MFRAG.EQ.2) CALL PYINDF(IP)
58813 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
58814 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
58815 ENDIF
58816
58817C...Loop back if enough space left in PYJETS and no error abort.
58818 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
58819 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
58820 GOTO 160
58821 ELSEIF(IP.LT.N) THEN
58822 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
58823 ENDIF
58824
58825C...Include simple Bose-Einstein effect parametrization if desired.
58826 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
58827 CALL PYBOEI(NSAV)
58828 GOTO 150
58829 ENDIF
58830
58831C...Check that momentum, energy and charge were conserved.
58832 DO 210 I=1,N
58833 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
58834 DO 200 J=1,4
58835 PS(2,J)=PS(2,J)+P(I,J)
58836 200 CONTINUE
58837 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
58838 210 CONTINUE
58839 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
58840 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
58841 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
58842 &'(PYEXEC:) four-momentum was not conserved')
58843 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
58844 &'(PYEXEC:) charge was not conserved')
58845
58846 RETURN
58847 END
58848
58849C*********************************************************************
58850
58851C...PYPREP
58852C...Rearranges partons along strings.
58853C...Special considerations for systems with junctions, with
58854C...possibility of junction-antijunction annihilation.
58855C...Allows small systems to collapse into one or two particles.
58856C...Checks flavours and colour singlet invariant masses.
58857
58858 SUBROUTINE PYPREP(IP)
58859
58860C...Double precision and integer declarations.
58861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58862 INTEGER PYK,PYCHGE,PYCOMP
58863C...Commonblocks.
58864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58866 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58868 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58869 COMMON/PYINT1/MINT(400),VINT(400)
58870C...The common block of colour tags.
58871 COMMON/PYCTAG/NCT,MCT(4000,2)
58872 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
58873 &/PYPARS/
58874 DATA NERRPR/0/
58875 SAVE NERRPR
58876C...Local arrays.
58877 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
58878 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
58879 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
58880 &IJCP(0:6),TJUOLD(5)
58881 CHARACTER CHTMP*6
58882
58883C...Function to give four-product.
58884 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)
58885
58886C...Rearrange parton shower product listing along strings: begin loop.
58887 MSTU(24)=0
58888 NOLD=N
58889 I1=N
58890 NJUNC=0
58891 NPIECE=0
58892 NJJSTR=0
58893 MSTU32=MSTU(32)+1
58894 DO 100 I=MAX(1,IP),N
58895C...First store junction positions.
58896 IF(K(I,1).EQ.42) THEN
58897 NJUNC=NJUNC+1
58898 IJUNC(NJUNC,0)=I
58899 IJUNC(NJUNC,4)=0
58900 ENDIF
58901 100 CONTINUE
58902
58903 DO 250 MQGST=1,3
58904 DO 240 I=MAX(1,IP),N
58905C...Special treatment for junctions
58906 IF (K(I,1).LE.0) GOTO 240
58907 IF(K(I,1).EQ.42) THEN
58908C...MQGST=2: Look for junction-junction strings (not detected in the
58909C...main search below).
58910 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
58911 IF (NJJSTR.EQ.0) THEN
58912 NJJSTR = (3*NJUNC-NPIECE)/2
58913 ENDIF
58914C...Check how many already identified strings end on this junction
58915 ILC=0
58916 DO 110 J=1,NPIECE
58917 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
58918 110 CONTINUE
58919C...If less than 3, remaining must be to another junction
58920 IF (ILC.LT.3) THEN
58921 IF (ILC.NE.2) THEN
58922C...Multiple j-j connections not handled yet.
58923 CALL PYERRM(2,
58924 & '(PYPREP:) Too many junction-junction strings.')
58925 MINT(51)=1
58926 RETURN
58927 ENDIF
58928C...The colour information in the junction is unreadable for the
58929C...colour space search further down in this routine, so we must
58930C...start on the colour mother of this junction and then "artificially"
58931C...prevent the colour mother from connecting here again.
58932 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
58933 KCS=4
58934 IF (MOD(ITJUNC,2).EQ.0) KCS=5
58935C...Switch colour if the junction-junction leg is presumably a
58936C...junction mother leg rather than a junction daughter leg.
58937 IF (ITJUNC.GE.3) KCS=9-KCS
58938 IF (MINT(33).EQ.0) THEN
58939C...Find the unconnected leg and reorder junction daughter pointers so
58940C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
58941C...piece.
58942 IA=MOD(K(I,4),MSTU(5))
58943 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
58944 ITMP=MOD(K(I,5),MSTU(5))
58945 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
58946 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
58947 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
58948 ELSE
58949 K(I,5)=K(I,5)+(IA-ITMP)
58950 ENDIF
58951 K(I,4)=K(I,4)+(ITMP-IA)
58952 IA=ITMP
58953 ENDIF
58954 IF (ITJUNC.LE.2) THEN
58955C...Beam baryon junction
58956 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
58957 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
58958C...Else 1 -> 2 decay junction
58959 ELSE
58960 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
58961 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
58962 ENDIF
58963 I1BEG = I1
58964 NSTP = 0
58965 GOTO 170
58966C...Alternatively use colour tag information.
58967 ELSE
58968C...Find a final state parton with appropriate dangling colour tag.
58969 JCT=0
58970 IA=0
58971 IJUMO=K(I,3)
58972 DO 140 J1=MAX(1,IP),N
58973 IF (K(J1,1).NE.3) GOTO 140
58974C...Check for matching final-state colour tag
58975 IMATCH=0
58976 DO 120 J2=MAX(1,IP),N
58977 IF (K(J2,1).NE.3) GOTO 120
58978 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
58979 120 CONTINUE
58980 IF (IMATCH.EQ.1) GOTO 140
58981C...Check whether this colour tag belongs to the present junction
58982C...by seeing whether any parton with this colour tag has the same
58983C...mother as the junction.
58984 JCT=MCT(J1,KCS-3)
58985 IMATCH=0
58986 DO 130 J2=MINT(84)+1,N
58987 IMO2=K(J2,3)
58988C...First scattering partons have IMO1 = 3 and 4.
58989 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
58990 & IMO2=IMO2-2
58991 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
58992 & IMATCH=1
58993 130 CONTINUE
58994 IF (IMATCH.EQ.0) GOTO 140
58995 IA=J1
58996 140 CONTINUE
58997C...Check for junction-junction strings without intermediate final state
58998C...glue (not detected above).
58999 IF (IA.EQ.0) THEN
59000 DO 160 MJU=1,NJUNC
59001 IJU2=IJUNC(MJU,0)
59002 IF (IJU2.EQ.I) GOTO 160
59003 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
59004C...Only opposite types of junctions can connect to each other.
59005 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
59006 IS=0
59007 DO 150 J=1,NPIECE
59008 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
59009 150 CONTINUE
59010 IF (IS.EQ.3) GOTO 160
59011 IB=I
59012 IA=IJU2
59013 160 CONTINUE
59014 ENDIF
59015C...Switch to other side of adjacent parton and step from there.
59016 KCS=9-KCS
59017 I1BEG = I1
59018 NSTP = 0
59019 GOTO 170
59020 ENDIF
59021 ELSE IF (ILC.NE.3) THEN
59022 ENDIF
59023 ENDIF
59024 ENDIF
59025
59026C...Look for coloured string endpoint, or (later) leftover gluon.
59027 IF(K(I,1).NE.3) GOTO 240
59028 KC=PYCOMP(K(I,2))
59029 IF(KC.EQ.0) GOTO 240
59030 KQ=KCHG(KC,2)
59031 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
59032
59033C...Pick up loose string end.
59034 KCS=4
59035 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
59036 IA=I
59037 IB=I
59038 I1BEG=I1
59039 NSTP=0
59040 170 NSTP=NSTP+1
59041 IF(NSTP.GT.4*N) THEN
59042 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
59043 MINT(51)=1
59044 RETURN
59045 ENDIF
59046
59047C...Copy undecayed parton. Finished if reached string endpoint.
59048 IF(K(IA,1).EQ.3) THEN
59049 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
59050 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
59051 MINT(51)=1
59052 MSTU(24)=1
59053 RETURN
59054 ENDIF
59055 I1=I1+1
59056 K(I1,1)=2
59057 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
59058 K(I1,2)=K(IA,2)
59059 K(I1,3)=IA
59060 K(I1,4)=0
59061 K(I1,5)=0
59062 DO 180 J=1,5
59063 P(I1,J)=P(IA,J)
59064 V(I1,J)=V(IA,J)
59065 180 CONTINUE
59066 K(IA,1)=K(IA,1)+10
59067 IF(K(I1,1).EQ.1) GOTO 240
59068 ENDIF
59069
59070C...Also finished (for now) if reached junction; then copy to end.
59071 IF(K(IA,1).EQ.42) THEN
59072 NCOPY=I1-I1BEG
59073 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
59074 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
59075 MINT(51)=1
59076 MSTU(24)=1
59077 RETURN
59078 ENDIF
59079 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
59080 DO 200 ICOPY=1,NCOPY
59081 DO 190 J=1,5
59082 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
59083 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
59084 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
59085 190 CONTINUE
59086 200 CONTINUE
59087 ENDIF
59088C...For junction-junction strings, find end leg and reorder junction
59089C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
59090C...junction-junction string piece.
59091 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
59092 ITMP=MOD(K(IA,4),MSTU(5))
59093 IF (ITMP.NE.IB) THEN
59094 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
59095 K(IA,5)=K(IA,5)+(ITMP-IB)
59096 ELSE
59097 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
59098 ENDIF
59099 K(IA,4)=K(IA,4)+(IB-ITMP)
59100 ENDIF
59101 ENDIF
59102 NPIECE=NPIECE+1
59103C...IPIECE:
59104C...0: endpoint in original ER
59105C...1:
59106C...2:
59107C...3: Parton immediately next to junction
59108C...4: Junction
59109 IPIECE(NPIECE,0)=I
59110 IPIECE(NPIECE,1)=MSTU32+1
59111 IPIECE(NPIECE,2)=MSTU32+NCOPY
59112 IPIECE(NPIECE,3)=IB
59113 IPIECE(NPIECE,4)=IA
59114 MSTU32=MSTU32+NCOPY
59115 I1=I1BEG
59116 GOTO 240
59117 ENDIF
59118
59119C...GOTO next parton in colour space.
59120 IB=IA
59121 IF (MINT(33).EQ.0) THEN
59122 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
59123 & )).NE.0) THEN
59124 IA=MOD(K(IB,KCS),MSTU(5))
59125 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
59126 MREV=0
59127 ELSE
59128 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
59129 & MSTU(5)).EQ.0) KCS=9-KCS
59130 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
59131 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
59132 MREV=1
59133 ENDIF
59134 IF(IA.LE.0.OR.IA.GT.N) THEN
59135 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
59136 IF(NERRPR.LT.5) THEN
59137 NERRPR=NERRPR+1
59138 WRITE(MSTU(11),*) 'started at:', I
59139 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
59140 WRITE(MSTU(11),*) 'MQGST =',MQGST
59141 CALL PYLIST(4)
59142 ENDIF
59143 MINT(51)=1
59144 RETURN
59145 ENDIF
59146 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
59147 & ,MSTU(5)).EQ.IB) THEN
59148 IF(MREV.EQ.1) KCS=9-KCS
59149 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
59150 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
59151 ELSE
59152 IF(MREV.EQ.0) KCS=9-KCS
59153 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
59154 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
59155 ENDIF
59156 IF(IA.NE.I) GOTO 170
59157C...Use colour tag information
59158 ELSE
59159C...First create colour tags starting on IB if none already present.
59160 IF (MCT(IB,KCS-3).EQ.0) THEN
59161 CALL PYCTTR(IB,KCS,IB)
59162 IF(MINT(51).NE.0) RETURN
59163 ENDIF
59164 JCT=MCT(IB,KCS-3)
59165 IFOUND=0
59166C...Find final state tag partner
59167 DO 210 IT=MAX(1,IP),N
59168 IF (IT.EQ.IB) GOTO 210
59169 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
59170 & .0) THEN
59171 IFOUND=IFOUND+1
59172 IA=IT
59173 ENDIF
59174 210 CONTINUE
59175C...Just copy and goto next if exactly one partner found.
59176 IF (IFOUND.EQ.1) THEN
59177 GOTO 170
59178C...When no match found, match is presumably junction.
59179 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
59180C...Check whether this colour tag matches a junction
59181C...by seeing whether any parton with this colour tag has the same
59182C...mother as a junction.
59183C...NB: Only type 1 and 2 junctions handled presently.
59184 DO 230 IJU=1,NJUNC
59185 IJUMO=K(IJUNC(IJU,0),3)
59186 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
59187C...Colours only connect to junctions, anti-colours to antijunctions:
59188 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
59189 IMATCH=0
59190 DO 220 J1=MAX(1,IP),N
59191 IF (K(J1,1).LE.0) GOTO 220
59192C...First scattering partons have IMO1 = 3 and 4.
59193 IMO=K(J1,3)
59194 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
59195 & IMO=IMO-2
59196 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
59197 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
59198 & IMATCH=1
59199C...Attempt at handling type > 3 junctions also. Not tested.
59200 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
59201 & .IJUMO) IMATCH=1
59202 220 CONTINUE
59203 IF (IMATCH.EQ.0) GOTO 230
59204 IA=IJUNC(IJU,0)
59205 IFOUND=IFOUND+1
59206 230 CONTINUE
59207
59208 IF (IFOUND.EQ.1) THEN
59209 GOTO 170
59210 ELSEIF (IFOUND.EQ.0) THEN
59211 WRITE(CHTMP,*) JCT
59212 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
59213 & //CHTMP)
59214 IF(NERRPR.LT.5) THEN
59215 NERRPR=NERRPR+1
59216 CALL PYLIST(4)
59217 ENDIF
59218 MINT(51)=1
59219 RETURN
59220 ENDIF
59221 ELSEIF (IFOUND.GE.2) THEN
59222 WRITE(CHTMP,*) JCT
59223 CALL PYERRM(12
59224 & ,'(PYPREP:) too many occurences of colour line: '//
59225 & CHTMP)
59226 IF(NERRPR.LT.5) THEN
59227 NERRPR=NERRPR+1
59228 CALL PYLIST(4)
59229 ENDIF
59230 MINT(51)=1
59231 RETURN
59232 ENDIF
59233 ENDIF
59234 K(I1,1)=1
59235 240 CONTINUE
59236 250 CONTINUE
59237
59238C...Junction systems remain.
59239 IJU=0
59240 IJUS=0
59241 IJUCNT=0
59242 MREV=0
59243 IJJSTR=0
59244 260 IJUCNT=IJUCNT+1
59245 IF (IJUCNT.LE.NJUNC) THEN
59246C...If we are not processing a j-j string, treat this junction as new.
59247 IF (IJJSTR.EQ.0) THEN
59248 IJU=IJUNC(IJUCNT,0)
59249 MREV=0
59250C...If junction has already been read, ignore it.
59251 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
59252C...If we are on a j-j string, goto second j-j junction.
59253 ELSE
59254 IJUCNT=IJUCNT-1
59255 IJU=IJUS
59256 ENDIF
59257C...Mark selected junction read.
59258 DO 270 J=1,NJUNC
59259 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
59260 270 CONTINUE
59261C...Determine junction type
59262 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
59263C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
59264C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
59265C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
59266 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
59267 IHK=0
59268 280 IHK=IHK+1
59269C...Find which quarks belong to given junction.
59270 IHF=0
59271 DO 290 IPC=1,NPIECE
59272 IF (IPIECE(IPC,4).EQ.IJU) THEN
59273 IHF=IHF+1
59274 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
59275 ENDIF
59276 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
59277 290 CONTINUE
59278C...IHK = 3 is special. Either normal string piece, or j-j string.
59279 IF(IHK.EQ.3) THEN
59280 IF (MREV.NE.1) THEN
59281 DO 300 IPC=1,NPIECE
59282C...If there is a j-j string starting on the present junction which has
59283C...zero length, insert next junction immediately.
59284 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
59285 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
59286 IJJSTR = 1
59287 GOTO 340
59288 ENDIF
59289 300 CONTINUE
59290 MREV = 1
59291C...If MREV is 1 and IHK is 3 we are finished with this system.
59292 ELSE
59293 MREV=0
59294 GOTO 260
59295 ENDIF
59296 ENDIF
59297
59298C...If we've gotten this far, then either IHK < 3, or
59299C...an interjunction string exists, or just a third normal string.
59300 IJUNC(IJUCNT,IHK)=0
59301 IJJSTR = 0
59302C..Order pieces belonging to this junction. Also look for j-j.
59303 DO 310 IPC=1,NPIECE
59304 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
59305 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
59306 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
59307 IJUNC(IJUCNT,IHK)=IPC
59308 IJJSTR = 1
59309 MREV = 0
59310 ENDIF
59311 310 CONTINUE
59312C...Copy back chains in proper order. MREV=0/1 : descending/ascending
59313 IPC=IJUNC(IJUCNT,IHK)
59314C...Temporary solution to cover for bug.
59315 IF(IPC.LE.0) THEN
59316 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
59317 MINT(51)=1
59318 RETURN
59319 ENDIF
59320 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
59321 I1=I1+1
59322 DO 320 J=1,5
59323 K(I1,J)=K(MSTU(4)-ICP,J)
59324 P(I1,J)=P(MSTU(4)-ICP,J)
59325 V(I1,J)=V(MSTU(4)-ICP,J)
59326 320 CONTINUE
59327 330 CONTINUE
59328 K(I1,1)=2
59329C...Mark last quark.
59330 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
59331C...Do not insert junctions at wrong places.
59332 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
59333C...Insert junction.
59334 340 IJUS = IJU
59335 IF (IHK.EQ.3) THEN
59336C...Shift to end junction if a j-j string has been processed.
59337 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
59338 MREV= 1
59339 ENDIF
59340 I1=I1+1
59341 DO 350 J=1,5
59342 K(I1,J)=0
59343 P(I1,J)=0.
59344 V(I1,J)=0.
59345 350 CONTINUE
59346 K(I1,1)=41
59347 K(IJUS,1)=K(IJUS,1)+10
59348 K(I1,2)=K(IJUS,2)
59349 K(I1,3)=IJUS
59350 360 IF (IHK.LT.3) GOTO 280
59351 ELSE
59352 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
59353 MINT(51)=1
59354 RETURN
59355 ENDIF
59356 IF (IJUCNT.NE.NJUNC) GOTO 260
59357 ENDIF
59358 N=I1
59359
59360C...Rearrange three strings from junction, e.g. in case one has been
59361C...shortened by shower, so the last is the largest-energy one.
59362 IF(NJUNC.GE.1) THEN
59363C...Find systems with exactly one junction.
59364 MJUN1=0
59365 NBEG=NOLD+1
59366 DO 470 I=NOLD+1,N
59367 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
59368 ELSEIF(K(I,1).EQ.41) THEN
59369 MJUN1=MJUN1+1
59370 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
59371 MJUN1=0
59372 NBEG=I+1
59373 ELSE
59374 NEND=I
59375C...Sum up energy-momentum in each junction string.
59376 DO 370 J=1,5
59377 PJU(1,J)=0D0
59378 PJU(2,J)=0D0
59379 PJU(3,J)=0D0
59380 370 CONTINUE
59381 NJU=0
59382 DO 390 I1=NBEG,NEND
59383 IF(K(I1,2).NE.21) THEN
59384 NJU=NJU+1
59385 IJUR(NJU)=I1
59386 ENDIF
59387 DO 380 J=1,5
59388 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
59389 380 CONTINUE
59390 390 CONTINUE
59391C...Find which of them has highest energy (minus mass) in rest frame.
59392 DO 400 J=1,5
59393 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
59394 400 CONTINUE
59395 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
59396 & PJU(4,3)**2))
59397 DO 410 I2=1,3
59398 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
59399 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
59400 410 CONTINUE
59401 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
59402C...Decide how to rearrange so that new last has highest energy.
59403 IF(PJU(1,6).LT.PJU(2,6)) THEN
59404 IRNG(1,1)=IJUR(1)
59405 IRNG(1,2)=IJUR(2)-1
59406 IRNG(2,1)=IJUR(4)
59407 IRNG(2,2)=IJUR(3)+1
59408 IRNG(4,1)=IJUR(3)-1
59409 IRNG(4,2)=IJUR(2)
59410 ELSE
59411 IRNG(1,1)=IJUR(4)
59412 IRNG(1,2)=IJUR(3)+1
59413 IRNG(2,1)=IJUR(2)
59414 IRNG(2,2)=IJUR(3)-1
59415 IRNG(4,1)=IJUR(2)-1
59416 IRNG(4,2)=IJUR(1)
59417 ENDIF
59418 IRNG(3,1)=IJUR(3)
59419 IRNG(3,2)=IJUR(3)
59420C...Copy in correct order below bottom of current event record.
59421 I2=N
59422 DO 440 II=1,4
59423 DO 430 I1=IRNG(II,1),IRNG(II,2),
59424 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
59425 I2=I2+1
59426 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
59427 CALL PYERRM(11,
59428 & '(PYPREP:) no more memory left in PYJETS')
59429 MINT(51)=1
59430 MSTU(24)=1
59431 RETURN
59432 ENDIF
59433 DO 420 J=1,5
59434 K(I2,J)=K(I1,J)
59435 P(I2,J)=P(I1,J)
59436 V(I2,J)=V(I1,J)
59437 420 CONTINUE
59438 IF(K(I2,1).EQ.1) K(I2,1)=2
59439 430 CONTINUE
59440 440 CONTINUE
59441 K(I2,1)=1
59442C...Copy back up, overwriting but now in correct order.
59443 DO 460 I1=NBEG,NEND
59444 I2=I1-NBEG+N+1
59445 DO 450 J=1,5
59446 K(I1,J)=K(I2,J)
59447 P(I1,J)=P(I2,J)
59448 V(I1,J)=V(I2,J)
59449 450 CONTINUE
59450 460 CONTINUE
59451 ENDIF
59452 MJUN1=0
59453 NBEG=I+1
59454 ENDIF
59455 470 CONTINUE
59456
59457C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
59458C...to two q-qbar systems.
59459C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
59460 IF (MSTJ(19).NE.1) THEN
59461 MJUN1 = 0
59462 JJGLUE = 0
59463 NBEG = NOLD+1
59464C...Force collapse when MSTJ(19)=2.
59465 IF (MSTJ(19).EQ.2) THEN
59466 DELMJJ = 1D9
59467 DELMQQ = 0D0
59468 ENDIF
59469C...Find systems with exactly two junctions.
59470 DO 700 I=NOLD+1,N
59471C...Count junctions
59472 IF (K(I,1).EQ.41) THEN
59473 MJUN1 = MJUN1+1
59474C...Check for interjunction gluons
59475 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
59476 JJGLUE = 1
59477 ENDIF
59478 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
59479C...If end of system reached with either zero or one junction, restart
59480C...with next system.
59481 MJUN1 = 0
59482 JJGLUE = 0
59483 NBEG = I+1
59484 ELSEIF(K(I,1).EQ.1) THEN
59485C...If end of system reached with exactly two junctions, compute string
59486C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
59487C...length measure for the (q-qbar)(q-qbar) topology.
59488 NEND=I
59489C...Loop down through chain.
59490 ISID=0
59491 DO 480 I1=NBEG,NEND
59492C...Store string piece division locations in event record
59493 IF (K(I1,2).NE.21) THEN
59494 ISID = ISID+1
59495 IJCP(ISID) = I1
59496 ENDIF
59497 480 CONTINUE
59498C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
59499 ISW=0
59500 IF (PYR(0).LT.0.5D0) ISW=1
59501C...Randomly choose which qqbar string gets the jj gluons.
59502 IGS=1
59503 IF (PYR(0).GT.0.5D0) IGS=2
59504C...Only compute string lengths when no topology forced.
59505 IF (MSTJ(19).EQ.0) THEN
59506C...Repeat following for each junction
59507 DO 570 IJU=1,2
59508C...Initialize iterative procedure for finding JRF
59509 IJRFIT=0
59510 DO 490 IX=1,3
59511 TJUOLD(IX)=0D0
59512 490 CONTINUE
59513 TJUOLD(4)=1D0
59514C...Start iteration. Sum up momenta in string pieces
59515 500 DO 540 IJS=1,3
59516C...JD=-1 for first junction, +1 for second junction.
59517C...Find out where piece starts and ends and which direction to go.
59518 JD=2*IJU-3
59519 IF (IJS.LE.2) THEN
59520 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
59521 IB = IJCP((IJU-1)*7 - JD*IJS)
59522 ELSEIF (IJS.EQ.3) THEN
59523 JD =-JD
59524 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
59525 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
59526 ENDIF
59527C...Initialize junction pull 4-vector.
59528 DO 510 J=1,5
59529 PUL(IJS,J)=0D0
59530 510 CONTINUE
59531C...Initialize weight
59532 PWT = 0D0
59533 PWTOLD = 0D0
59534C...Sum up (weighted) momenta along each string piece
59535 DO 530 ISP=IA,IB,JD
59536C...If present parton not last in chain
59537 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
59538C...If last parton was a junction, store present weight
59539 IF (K(ISP-JD,2).EQ.88) THEN
59540 PWTOLD = PWT
59541C...If last parton was a quark, reset to stored weight.
59542 ELSEIF (K(ISP-JD,2).NE.21) THEN
59543 PWT = PWTOLD
59544 ENDIF
59545 ENDIF
59546C...Skip next parton if weight already large
59547 IF (PWT.GT.10D0) GOTO 530
59548C...Compute momentum in TJUOLD frame:
59549 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
59550 & )*P(ISP,3)
59551 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
59552 DO 520 J=1,3
59553 TMP=P(ISP,J)+TJUOLD(J)*BFC
59554 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
59555 520 CONTINUE
59556C...Boosted energy
59557 TMP=TJUOLD(4)*P(ISP,4)+TDP
59558 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
59559C...Update weight
59560 PWT=PWT+TMP/PARJ(48)
59561C...Put |p| rather than m in 5th slot
59562 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
59563 & +PUL(IJS,3)**2)
59564 530 CONTINUE
59565 540 CONTINUE
59566C...Compute boost
59567 IJRFIT=IJRFIT+1
59568 CALL PYJURF(PUL,T)
59569C...Combine new boost (T) with old boost (TJUOLD)
59570 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
59571 DO 550 IX=1,3
59572 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
59573 & ))
59574 550 CONTINUE
59575 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
59576 & **2)
59577C...If last boost small, accept JRF, else iterate.
59578C...Also prevent possibility of infinite loop.
59579 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
59580 & IJRFIT.LT.MSTJ(18))THEN
59581 GOTO 500
59582 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
59583 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
59584 ENDIF
59585C...Store final boost, with change of sign since TJJ motion vector.
59586 DO 560 IX=1,3
59587 TJJ(IJU,IX)=-TJUOLD(IX)
59588 560 CONTINUE
59589 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
59590 & +TJJ(IJU,3)**2)
59591 570 CONTINUE
59592C...String length measure for (q-qbar)(q-qbar) topology.
59593C...Note only momenta of nearest partons used (since rest of system
59594C...identical).
59595 IF (JJGLUE.EQ.0) THEN
59596 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
59597 & -1,IJCP(5-ISW)+1)
59598 ELSE
59599C...Put jj gluons on selected string (IGS selected randomly above).
59600 IF (IGS.EQ.1) THEN
59601 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
59602 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
59603 ELSE
59604 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
59605 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
59606 & ,IJCP(5-ISW)+1)
59607 ENDIF
59608 ENDIF
59609C...String length measure for q-q-j-j-q-q topology.
59610 T1G1=0D0
59611 T2G2=0D0
59612 T1T2=0D0
59613 T1P1=0D0
59614 T1P2=0D0
59615 T2P3=0D0
59616 T2P4=0D0
59617 ISGN=-1
59618C...Note only momenta of nearest partons used (since rest of system
59619C...identical).
59620 DO 580 IX=1,4
59621 IF (IX.EQ.4) ISGN=1
59622 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
59623 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
59624 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
59625 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
59626 IF (JJGLUE.EQ.0) THEN
59627C...Junction motion vector dot product gives length when inter-junction
59628C...gluons absent.
59629 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
59630 ELSE
59631C...Junction motion vector dot products with gluon momenta give length
59632C...when inter-junction gluons present.
59633 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
59634 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
59635 ENDIF
59636 580 CONTINUE
59637 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
59638 IF (JJGLUE.EQ.0) THEN
59639 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
59640 ELSE
59641 DELMJJ=DELMJJ*4D0*T1G1*T2G2
59642 ENDIF
59643 ENDIF
59644C...If delmjj > delmqq collapse string system to q-qbar q-qbar
59645C...(Always the case for MSTJ(19)=2 due to initialization above)
59646 IF (DELMJJ.GT.DELMQQ) THEN
59647C...Put new system at end of event record
59648 NCOP=N
59649 DO 650 IST=1,2
59650 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
59651 NCOP=NCOP+1
59652 DO 590 IX=1,5
59653 P(NCOP,IX)=P(ICOP,IX)
59654 K(NCOP,IX)=K(ICOP,IX)
59655 590 CONTINUE
59656 600 CONTINUE
59657 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
59658C...Insert inter-junction gluon string piece (reversed)
59659 NJJGL=0
59660 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
59661 NJJGL=NJJGL+1
59662 NCOP=NCOP+1
59663 DO 610 IX=1,5
59664 P(NCOP,IX)=P(ICOP,IX)
59665 K(NCOP,IX)=K(ICOP,IX)
59666 610 CONTINUE
59667 620 CONTINUE
59668 ENDIF
59669 IFC=-2*IST+3
59670 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
59671 NCOP=NCOP+1
59672 DO 630 IX=1,5
59673 P(NCOP,IX)=P(ICOP,IX)
59674 K(NCOP,IX)=K(ICOP,IX)
59675 630 CONTINUE
59676 640 CONTINUE
59677 K(NCOP,1)=1
59678 650 CONTINUE
59679C...Copy system back in right order
59680 DO 670 ICOP=NBEG,NEND-2
59681 DO 660 IX=1,5
59682 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
59683 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
59684 660 CONTINUE
59685 670 CONTINUE
59686C...Shift down rest of event record
59687 DO 690 ICOP=NEND+1,N
59688 DO 680 IX=1,5
59689 P(ICOP-2,IX)=P(ICOP,IX)
59690 K(ICOP-2,IX)=K(ICOP,IX)
59691 680 CONTINUE
59692 690 CONTINUE
59693C...Update length of event record.
59694 N=N-2
59695 ENDIF
59696 MJUN1=0
59697 NBEG=I+1
59698 ENDIF
59699 700 CONTINUE
59700 ENDIF
59701 ENDIF
59702
59703C...Done if no checks on small-mass systems.
59704 IF(MSTJ(14).LT.0) RETURN
59705 IF(MSTJ(14).EQ.0) GOTO 1140
59706
59707C...Find lowest-mass colour singlet jet system.
59708 NS=N
59709 710 NSIN=N-NS
59710 PDMIN=1D0+PARJ(32)
59711 IC=0
59712 DO 770 I=MAX(1,IP),N
59713 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
59714 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
59715 NSIN=NSIN+1
59716 IC=I
59717 DO 720 J=1,4
59718 DPS(J)=P(I,J)
59719 720 CONTINUE
59720 MSTJ(93)=1
59721 DPS(5)=PYMASS(K(I,2))
59722 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
59723 DO 730 J=1,4
59724 DPS(J)=DPS(J)+P(I,J)
59725 730 CONTINUE
59726 MSTJ(93)=1
59727 DPS(5)=DPS(5)+PYMASS(K(I,2))
59728 ELSEIF(K(I,1).EQ.2) THEN
59729 DO 740 J=1,4
59730 DPS(J)=DPS(J)+P(I,J)
59731 740 CONTINUE
59732 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
59733 DO 750 J=1,4
59734 DPS(J)=DPS(J)+P(I,J)
59735 750 CONTINUE
59736 MSTJ(93)=1
59737 DPS(5)=DPS(5)+PYMASS(K(I,2))
59738 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
59739 & DPS(5)
59740 IF(PD.LT.PDMIN) THEN
59741 PDMIN=PD
59742 DO 760 J=1,5
59743 DPC(J)=DPS(J)
59744 760 CONTINUE
59745 IC1=IC
59746 IC2=I
59747 ENDIF
59748 IC=0
59749 ELSE
59750 NSIN=NSIN+1
59751 ENDIF
59752 770 CONTINUE
59753
59754C...Done if lowest-mass system above threshold for string frag.
59755 IF(PDMIN.GE.PARJ(32)) GOTO 1140
59756
59757C...Fill small-mass system as cluster.
59758 NSAV=N
59759 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
59760 K(N+1,1)=11
59761 K(N+1,2)=91
59762 K(N+1,3)=IC1
59763 P(N+1,1)=DPC(1)
59764 P(N+1,2)=DPC(2)
59765 P(N+1,3)=DPC(3)
59766 P(N+1,4)=DPC(4)
59767 P(N+1,5)=PECM
59768
59769C...Set up history, assuming cluster -> 2 hadrons.
59770 NBODY=2
59771 K(N+1,4)=N+2
59772 K(N+1,5)=N+3
59773 K(N+2,1)=1
59774 K(N+3,1)=1
59775 IF(MSTU(16).NE.2) THEN
59776 K(N+2,3)=N+1
59777 K(N+3,3)=N+1
59778 ELSE
59779 K(N+2,3)=IC1
59780 K(N+3,3)=IC2
59781 ENDIF
59782 K(N+2,4)=0
59783 K(N+3,4)=0
59784 K(N+2,5)=0
59785 K(N+3,5)=0
59786 V(N+1,5)=0D0
59787 V(N+2,5)=0D0
59788 V(N+3,5)=0D0
59789
59790C...Find total flavour content - complicated by presence of junctions.
59791 NQ=0
59792 NDIQ=0
59793 DO 780 I=IC1,IC2
59794 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
59795 NQ=NQ+1
59796 KFQ(NQ)=K(I,2)
59797 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
59798 ENDIF
59799 780 CONTINUE
59800
59801C...If several diquarks, split up one to give even number of flavours.
59802 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
59803 I1=3
59804 IF(IABS(KFQ(3)).LT.1000) I1=1
59805 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
59806 KFQ(I1)=KFQ(I1)/1000
59807 NQ=4
59808 NDIQ=NDIQ-1
59809 ENDIF
59810
59811C...If four quark ends, join two to diquark.
59812 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
59813 I1=1
59814 I2=2
59815 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
59816 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
59817 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
59818 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
59819 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
59820 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
59821 KFQ(I2)=KFQ(4)
59822 NQ=3
59823 NDIQ=1
59824 ENDIF
59825
59826C...If two quark ends, plus quark or diquark, join quarks to diquark.
59827 IF(NQ.EQ.3) THEN
59828 I1=1
59829 I2=2
59830 IF(IABS(KFQ(I1)).GT.1000) I1=3
59831 IF(IABS(KFQ(I2)).GT.1000) I2=3
59832 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
59833 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
59834 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
59835 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
59836 KFQ(I2)=KFQ(3)
59837 NQ=2
59838 NDIQ=NDIQ+1
59839 ENDIF
59840
59841C...Form two particles from flavours of lowest-mass system, if feasible.
59842 NTRY = 0
59843 790 NTRY = NTRY + 1
59844
59845C...Open string with two specified endpoint flavours.
59846 IF(NQ.EQ.2) THEN
59847 KC1=PYCOMP(KFQ(1))
59848 KC2=PYCOMP(KFQ(2))
59849 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
59850 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
59851 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
59852 IF(KQ1+KQ2.NE.0) GOTO 1140
59853C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
59854 800 K1=KFQ(1)
59855 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
59856 MSTU(125)=0
59857 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
59858 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
59859 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
59860
59861C...Open string with four specified flavours.
59862 ELSEIF(NQ.EQ.4) THEN
59863 KC1=PYCOMP(KFQ(1))
59864 KC2=PYCOMP(KFQ(2))
59865 KC3=PYCOMP(KFQ(3))
59866 KC4=PYCOMP(KFQ(4))
59867 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
59868 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
59869 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
59870 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
59871 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
59872 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
59873C...Combine flavours pairwise to form two hadrons.
59874 810 I1=1
59875 I2=2
59876 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
59877 & IABS(KFQ(2)).GT.1000)) I2=3
59878 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
59879 & IABS(KFQ(3)).GT.1000))) I2=4
59880 I3=3
59881 IF(I2.EQ.3) I3=2
59882 I4=10-I1-I2-I3
59883 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
59884 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
59885 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
59886
59887C...Closed string.
59888 ELSE
59889 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
59890C...No room for popcorn mesons in closed string -> 2 hadrons.
59891 MSTU(125)=0
59892 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
59893 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
59894 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
59895 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
59896 ENDIF
59897 P(N+2,5)=PYMASS(K(N+2,2))
59898 P(N+3,5)=PYMASS(K(N+3,2))
59899
59900C...If it does not work: try again (a number of times), give up (if no
59901C...place to shuffle momentum or too many flavours), or form one hadron.
59902 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
59903 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
59904 GOTO 790
59905 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
59906 GOTO 1140
59907 ELSE
59908 GOTO 890
59909 END IF
59910 END IF
59911
59912C...Perform two-particle decay of jet system.
59913C...First step: find reference axis in decaying system rest frame.
59914C...(Borrow slot N+2 for temporary direction.)
59915 DO 830 J=1,4
59916 P(N+2,J)=P(IC1,J)
59917 830 CONTINUE
59918 DO 850 I=IC1+1,IC2-1
59919 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
59920 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
59921 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
59922 DO 840 J=1,4
59923 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
59924 840 CONTINUE
59925 ENDIF
59926 850 CONTINUE
59927 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
59928 &-DPC(3)/DPC(4))
59929 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
59930 PHI1=PYANGL(P(N+2,1),P(N+2,2))
59931
59932C...Second step: generate isotropic/anisotropic decay.
59933 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
59934 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
59935 860 UE(3)=PYR(0)
59936 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
59937 PT2=(1D0-UE(3)**2)*PA**2
59938 IF(MSTJ(16).LE.0) THEN
59939 PREV=0.5D0
59940 ELSE
59941 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
59942 PR1=P(N+2,5)**2+PT2
59943 PR2=P(N+3,5)**2+PT2
59944 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
59945 PREVCF=PARJ(42)
59946 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
59947 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
59948 ENDIF
59949 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
59950 PHI=PARU(2)*PYR(0)
59951 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
59952 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
59953 DO 870 J=1,3
59954 P(N+2,J)=PA*UE(J)
59955 P(N+3,J)=-PA*UE(J)
59956 870 CONTINUE
59957 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
59958 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
59959
59960C...Third step: move back to event frame and set production vertex.
59961 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
59962 &DPC(3)/DPC(4))
59963 DO 880 J=1,4
59964 V(N+1,J)=V(IC1,J)
59965 V(N+2,J)=V(IC1,J)
59966 V(N+3,J)=V(IC2,J)
59967 880 CONTINUE
59968 N=N+3
59969 GOTO 1120
59970
59971C...Else form one particle, if possible.
59972 890 NBODY=1
59973 K(N+1,5)=N+2
59974 DO 900 J=1,4
59975 V(N+1,J)=V(IC1,J)
59976 V(N+2,J)=V(IC1,J)
59977 900 CONTINUE
59978
59979C...Select hadron flavour from available quark flavours.
59980 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
59981 GOTO 1140
59982 ELSEIF(NQ.EQ.2) THEN
59983 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
59984 ELSE
59985 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
59986 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
59987 ENDIF
59988 IF(K(N+2,2).EQ.0) GOTO 910
59989 P(N+2,5)=PYMASS(K(N+2,2))
59990
59991C...Use old algorithm for E/p conservation? (EN)
59992 IF (MSTJ(16).LE.0) GOTO 1080
59993
59994C...Find the string piece closest to the cluster by a loop
59995C...over the undecayed partons not in present cluster. (EN)
59996 DGLOMI=1D30
59997 IBEG=0
59998 I0=0
59999 NJUNC=0
60000 DO 940 I1=MAX(1,IP),N-1
60001 IF(K(I1,1).EQ.1) NJUNC=0
60002 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
60003 IF(K(I1,1).EQ.41) GOTO 940
60004 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
60005 I0=0
60006 ELSEIF(K(I1,1).EQ.2) THEN
60007 IF(I0.EQ.0) I0=I1
60008 I2=I1
60009 920 I2=I2+1
60010 IF(K(I2,1).EQ.41) GOTO 940
60011 IF(K(I2,1).GT.10) GOTO 920
60012 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
60013 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
60014 & NJUNC.EQ.0) GOTO 940
60015 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
60016 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
60017 & K(I2,1).NE.1)) GOTO 940
60018
60019C...Define velocity vectors e1, e2, ecl and differences e3, e4.
60020 DO 930 J=1,3
60021 E1(J)=P(I1,J)/P(I1,4)
60022 E2(J)=P(I2,J)/P(I2,4)
60023 ECL(J)=P(N+1,J)/P(N+1,4)
60024 E3(J)=E2(J)-E1(J)
60025 E4(J)=ECL(J)-E1(J)
60026 930 CONTINUE
60027
60028C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
60029 E3S=E3(1)**2+E3(2)**2+E3(3)**2
60030 E4S=E4(1)**2+E4(2)**2+E4(3)**2
60031 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
60032 IF(E34.LE.0D0) THEN
60033 DDMIN=E4S
60034 ELSEIF(E34.LT.E3S) THEN
60035 DDMIN=E4S-E34**2/E3S
60036 ELSE
60037 DDMIN=E4S-2D0*E34+E3S
60038 ENDIF
60039
60040C...Is this the smallest so far?
60041 IF(DDMIN.LT.DGLOMI) THEN
60042 DGLOMI=DDMIN
60043 IBEG=I0
60044 IPCS=I1
60045 ENDIF
60046 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
60047 I0=0
60048 ENDIF
60049 940 CONTINUE
60050
60051C... Check if there are any strings to connect to the new gluon. (EN)
60052 IF (IBEG.EQ.0) GOTO 1080
60053
60054C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
60055 IF (P(N+1,5).GE.P(N+2,5)) THEN
60056
60057C...Construct 'gluon' that is needed to put hadron on the mass shell.
60058 FRAC=P(N+2,5)/P(N+1,5)
60059 DO 950 J=1,5
60060 P(N+2,J)=FRAC*P(N+1,J)
60061 PG(J)=(1D0-FRAC)*P(N+1,J)
60062 950 CONTINUE
60063
60064C... Copy string with new gluon put in.
60065 N=N+2
60066 I=IBEG-1
60067 960 I=I+1
60068 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
60069 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
60070 N=N+1
60071 DO 970 J=1,5
60072 K(N,J)=K(I,J)
60073 P(N,J)=P(I,J)
60074 V(N,J)=V(I,J)
60075 970 CONTINUE
60076 K(I,1)=K(I,1)+10
60077 K(I,4)=N
60078 K(I,5)=N
60079 K(N,3)=I
60080 IF(I.EQ.IPCS) THEN
60081 N=N+1
60082 DO 980 J=1,5
60083 K(N,J)=K(N-1,J)
60084 P(N,J)=PG(J)
60085 V(N,J)=V(N-1,J)
60086 980 CONTINUE
60087 K(N,2)=21
60088 K(N,3)=NSAV+1
60089 ENDIF
60090 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
60091 GOTO 1120
60092
60093C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
60094C...from string piece endpoints.
60095 ELSE
60096
60097C...Begin by copying string that should give energy to cluster.
60098 N=N+2
60099 I=IBEG-1
60100 990 I=I+1
60101 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
60102 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
60103 N=N+1
60104 DO 1000 J=1,5
60105 K(N,J)=K(I,J)
60106 P(N,J)=P(I,J)
60107 V(N,J)=V(I,J)
60108 1000 CONTINUE
60109 K(I,1)=K(I,1)+10
60110 K(I,4)=N
60111 K(I,5)=N
60112 K(N,3)=I
60113 IF(I.EQ.IPCS) I1=N
60114 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
60115 I2=I1+1
60116
60117C...Set initial Phad.
60118 DO 1010 J=1,4
60119 P(NSAV+2,J)=P(NSAV+1,J)
60120 1010 CONTINUE
60121
60122C...Calculate Pg, a part of which will be added to Phad later. (EN)
60123 1020 IF(MSTJ(16).EQ.1) THEN
60124 ALPHA=1D0
60125 BETA=1D0
60126 ELSE
60127 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
60128 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
60129 ENDIF
60130 DO 1030 J=1,4
60131 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
60132 1030 CONTINUE
60133 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
60134
60135C..Solve 2nd order equation, use the best (smallest) solution. (EN)
60136 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
60137 & P(NSAV+2,3)**2
60138 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
60139 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
60140 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
60141
60142C...If all gluon energy eaten, zero it and take a step back.
60143 ITER=0
60144 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
60145 ITER=1
60146 DO 1040 J=1,4
60147 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
60148 P(I1,J)=0D0
60149 1040 CONTINUE
60150 P(I1,5)=0D0
60151 K(I1,1)=K(I1,1)+10
60152 I1=I1-1
60153 IF(K(I1,1).EQ.41) ITER=-1
60154 ENDIF
60155 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
60156 ITER=1
60157 DO 1050 J=1,4
60158 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
60159 P(I2,J)=0D0
60160 1050 CONTINUE
60161 P(I2,5)=0D0
60162 K(I2,1)=K(I2,1)+10
60163 I2=I2+1
60164 IF(K(I2,1).EQ.41) ITER=-1
60165 ENDIF
60166 IF(ITER.EQ.1) GOTO 1020
60167
60168C...If also all endpoint energy eaten, revert to old procedure.
60169 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
60170 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
60171 DO 1060 I=NSAV+3,N
60172 IM=K(I,3)
60173 K(IM,1)=K(IM,1)-10
60174 K(IM,4)=0
60175 K(IM,5)=0
60176 1060 CONTINUE
60177 N=NSAV
60178 GOTO 1080
60179 ENDIF
60180
60181C... Construct the collapsed hadron and modified string partons.
60182 DO 1070 J=1,4
60183 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
60184 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
60185 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
60186 1070 CONTINUE
60187 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
60188 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
60189
60190C...Finished with string collapse in new scheme.
60191 GOTO 1120
60192 ENDIF
60193
60194C... Use old algorithm; by choice or when in trouble.
60195 1080 CONTINUE
60196C...Find parton/particle which combines to largest extra mass.
60197 IR=0
60198 HA=0D0
60199 HSM=0D0
60200 DO 1100 MCOMB=1,3
60201 IF(IR.NE.0) GOTO 1100
60202 DO 1090 I=MAX(1,IP),N
60203 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
60204 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
60205 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
60206 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
60207 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
60208 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
60209 & GOTO 1090
60210 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
60211 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
60212 IF(HSR.GT.HSM) THEN
60213 IR=I
60214 HA=HCR
60215 HSM=HSR
60216 ENDIF
60217 1090 CONTINUE
60218 1100 CONTINUE
60219
60220C...Shuffle energy and momentum to put new particle on mass shell.
60221 IF(IR.NE.0) THEN
60222 HB=PECM**2+HA
60223 HC=P(N+2,5)**2+HA
60224 HD=P(IR,5)**2+HA
60225 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
60226 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
60227 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
60228 DO 1110 J=1,4
60229 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
60230 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
60231 1110 CONTINUE
60232 N=N+2
60233 ELSE
60234 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
60235 RETURN
60236 ENDIF
60237
60238C...Mark collapsed system and store daughter pointers. Iterate.
60239 1120 DO 1130 I=IC1,IC2
60240 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
60241 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
60242 K(I,1)=K(I,1)+10
60243 IF(MSTU(16).NE.2) THEN
60244 K(I,4)=NSAV+1
60245 K(I,5)=NSAV+1
60246 ELSE
60247 K(I,4)=NSAV+2
60248 K(I,5)=NSAV+1+NBODY
60249 ENDIF
60250 ENDIF
60251 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
60252 1130 CONTINUE
60253 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
60254
60255C...Check flavours and invariant masses in parton systems.
60256 1140 NP=0
60257 KFN=0
60258 KQS=0
60259 NJU=0
60260 DO 1150 J=1,5
60261 DPS(J)=0D0
60262 1150 CONTINUE
60263 DO 1180 I=MAX(1,IP),N
60264 IF(K(I,1).EQ.41) NJU=NJU+1
60265 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
60266 KC=PYCOMP(K(I,2))
60267 IF(KC.EQ.0) GOTO 1180
60268 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60269 IF(KQ.EQ.0) GOTO 1180
60270 NP=NP+1
60271 IF(KQ.NE.2) THEN
60272 KFN=KFN+1
60273 KQS=KQS+KQ
60274 MSTJ(93)=1
60275 DPS(5)=DPS(5)+PYMASS(K(I,2))
60276 ENDIF
60277 DO 1160 J=1,4
60278 DPS(J)=DPS(J)+P(I,J)
60279 1160 CONTINUE
60280 IF(K(I,1).EQ.1) THEN
60281 NFERR=0
60282 IF(NJU.EQ.0.AND.NP.NE.1) THEN
60283 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
60284 ELSEIF(NJU.EQ.1) THEN
60285 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
60286 ELSEIF(NJU.EQ.2) THEN
60287 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
60288 ELSEIF(NJU.GE.3) THEN
60289 NFERR=1
60290 ENDIF
60291 IF(NFERR.EQ.1) THEN
60292 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
60293 MINT(51)=1
60294 RETURN
60295 ENDIF
60296 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
60297 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
60298 & '(PYPREP:) too small mass in jet system')
60299 NP=0
60300 KFN=0
60301 KQS=0
60302 NJU=0
60303 DO 1170 J=1,5
60304 DPS(J)=0D0
60305 1170 CONTINUE
60306 ENDIF
60307 1180 CONTINUE
60308
60309 RETURN
60310 END
60311
60312C*********************************************************************
60313
60314C...PYSTRF
60315C...Handles the fragmentation of an arbitrary colour singlet
60316C...jet system according to the Lund string fragmentation model.
60317
60318 SUBROUTINE PYSTRF(IP)
60319
60320C...Double precision and integer declarations.
60321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60322 IMPLICIT INTEGER(I-N)
60323 INTEGER PYK,PYCHGE,PYCOMP
60324C...Commonblocks.
60325 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60326 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60327 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60328 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60329C...Local arrays. All MOPS variables ends with MO
60330 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
60331 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
60332 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
60333 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
60334 &PBST(3,5),TJUOLD(5)
60335
60336C...Function: four-product of two vectors.
60337 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)
60338 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
60339 &DP(I,3)*DP(J,3)
60340
60341C...Reset counters.
60342 MSTJ(91)=0
60343 NSAV=N
60344 MSTU90=MSTU(90)
60345 NP=0
60346 KQSUM=0
60347 DO 100 J=1,5
60348 DPS(J)=0D0
60349 100 CONTINUE
60350 MJU(1)=0
60351 MJU(2)=0
60352 NTRYFN=0
60353 IJUORI(1)=0
60354 IJUORI(2)=0
60355
60356C...Identify parton system.
60357 I=IP-1
60358 110 I=I+1
60359 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
60360 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
60361 IF(MSTU(21).GE.1) RETURN
60362 ENDIF
60363 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
60364 KC=PYCOMP(K(I,2))
60365 IF(KC.EQ.0) GOTO 110
60366 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60367 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
60368 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
60369 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
60370 IF(MSTU(21).GE.1) RETURN
60371 ENDIF
60372
60373C...Take copy of partons to be considered. Check flavour sum.
60374 NP=NP+1
60375 DO 120 J=1,5
60376 K(N+NP,J)=K(I,J)
60377 P(N+NP,J)=P(I,J)
60378 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
60379 120 CONTINUE
60380 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
60381 K(N+NP,3)=I
60382 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60383 IF(K(I,1).EQ.41) THEN
60384 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
60385 MJU(1)=N+NP
60386 IJUORI(1)=I
60387 ELSE
60388 MJU(2)=N+NP
60389 IJUORI(2)=I
60390 ENDIF
60391 ENDIF
60392 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
60393 IF(MOD(KQSUM,3).NE.0) THEN
60394 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
60395 IF(MSTU(21).GE.1) RETURN
60396 ENDIF
60397 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
60398
60399C...Boost copied system to CM frame (for better numerical precision).
60400 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
60401 MBST=0
60402 MSTU(33)=1
60403 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
60404 & -DPS(3)/DPS(4))
60405 ELSE
60406 MBST=1
60407 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
60408 DO 130 I=N+1,N+NP
60409 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
60410 IF(P(I,3).GT.0D0) THEN
60411 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
60412 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
60413 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
60414 ELSE
60415 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
60416 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
60417 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
60418 ENDIF
60419 130 CONTINUE
60420 ENDIF
60421
60422C...Search for very nearby partons that may be recombined.
60423 NTRYR=0
60424 NTRYWR=0
60425 PARU12=PARU(12)
60426 PARU13=PARU(13)
60427 MJU(3)=MJU(1)
60428 MJU(4)=MJU(2)
60429 NR=NP
60430 NRMIN=2
60431 IF(MJU(1).GT.0) NRMIN=NRMIN+2
60432 IF(MJU(2).GT.0) NRMIN=NRMIN+2
60433 140 IF(NR.GT.NRMIN) THEN
60434 PDRMIN=2D0*PARU12
60435 DO 150 I=N+1,N+NR
60436 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
60437 I1=I+1
60438 IF(I.EQ.N+NR) I1=N+1
60439 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
60440 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
60441 & GOTO 150
60442 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
60443 & GOTO 150
60444 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
60445 & P(I1,2)**2+P(I1,3)**2))
60446 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
60447 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
60448 IF(PDR.LT.PDRMIN) THEN
60449 IR=I
60450 PDRMIN=PDR
60451 ENDIF
60452 150 CONTINUE
60453
60454C...Recombine very nearby partons to avoid machine precision problems.
60455 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
60456 DO 160 J=1,4
60457 P(N+1,J)=P(N+1,J)+P(N+NR,J)
60458 160 CONTINUE
60459 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60460 & P(N+1,3)**2))
60461 NR=NR-1
60462 GOTO 140
60463 ELSEIF(PDRMIN.LT.PARU12) THEN
60464 DO 170 J=1,4
60465 P(IR,J)=P(IR,J)+P(IR+1,J)
60466 170 CONTINUE
60467 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
60468 & P(IR,3)**2))
60469 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
60470 DO 190 I=IR+1,N+NR-1
60471 K(I,1)=K(I+1,1)
60472 K(I,2)=K(I+1,2)
60473 DO 180 J=1,5
60474 P(I,J)=P(I+1,J)
60475 180 CONTINUE
60476 190 CONTINUE
60477 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
60478 NR=NR-1
60479 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
60480 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
60481 GOTO 140
60482 ENDIF
60483 ENDIF
60484 NTRYR=NTRYR+1
60485
60486C...Reset particle counter. Skip ahead if no junctions are present;
60487C...this is usually the case!
60488 NRS=MAX(5*NR+11,NP)
60489 NTRY=0
60490 200 NTRY=NTRY+1
60491 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
60492 PARU12=4D0*PARU12
60493 PARU13=2D0*PARU13
60494 GOTO 140
60495 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
60496 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
60497 IF(MSTU(21).GE.1) RETURN
60498 ENDIF
60499 I=N+NRS
60500 MSTU(90)=MSTU90
60501 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
60502 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
60503 & ' junction strings not handled by MSTJ(12)>3 options')
60504 DO 640 JT=1,2
60505 NJS(JT)=0
60506 IF(MJU(JT).EQ.0) GOTO 640
60507 JS=3-2*JT
60508
60509C++SKANDS
60510C...Find and sum up momentum on three sides of junction.
60511C...Begin with previous boost = zero.
60512 IJRFIT=0
60513 DO 210 IX=1,3
60514 TJUOLD(IX)=0D0
60515 210 CONTINUE
60516 TJUOLD(4)=1D0
60517 220 IU=0
60518C...Beginning and end of string system in event record.
60519 I1BEG=N+1+(JT-1)*(NR-1)
60520 I1END=N+NR+(JT-1)*(1-NR)
60521C...Look for junction string piece end points
60522 DO 230 I1=I1BEG,I1END,JS
60523 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
60524C...Store junction string piece end points.
60525C 1-junction systems 2-junction systems
60526C IU : 1 2 3 4 1 2 3 4 5 6
60527C 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
60528 IU=IU+1
60529 IJU(IU)=I1
60530 ENDIF
60531C...Sum over momenta, from junction outwards.
60532 230 CONTINUE
60533 DO 280 IU=1,3
60534 PWT=0D0
60535C...Initialize junction drag and string piece 4-vectors.
60536 DO 240 J=1,5
60537 PBST(IU,J)=0D0
60538 PJU(IU,J)=0D0
60539 240 CONTINUE
60540C...First two branches. Inwards out means opposite direction to JS.
60541C...(JS is 1 for JT=1, -1 for JT=2)
60542 IF (IU.LT.3) THEN
60543 I1A=IJU(IU+1)-JS
60544 I1B=IJU(IU)
60545 IDIR=-JS
60546C...Last branch (gq or gjgqgq). Direction now reversed.
60547 ELSE
60548 I1A=IJU(IU)+JS
60549 I1B=I1END
60550 IDIR=JS
60551 ENDIF
60552 DO 270 I1=I1A,I1B,IDIR
60553C...Sum up momentum directions with exponential suppression
60554C...for use in finding junction rest frame below.
60555 IF (K(I1,2).EQ.88) THEN
60556C...gjgqgq type system encountered. Use current PWT as start
60557C...for both strings.
60558 PWTOLD=PWT
60559 ELSE
60560 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
60561C...Sum up string piece (boosted) 4-momenta.
60562 DO 250 J=1,4
60563 PJU(IU,J)=PJU(IU,J)+P(I1,J)
60564 250 CONTINUE
60565C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
60566C...boost is zero, see above). Skip parton if suppression factor large.
60567 IF (PWT.GT.10D0) GOTO 270
60568C...Compute momentum in current frame:
60569 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
60570 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
60571 DO 260 J=1,3
60572 PTMP=P(I1,J)+TJUOLD(J)*BFC
60573 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
60574 260 CONTINUE
60575C...Boosted energy
60576 PTMP=TJUOLD(4)*P(I1,4)+TDP
60577 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
60578 PWT=PWT+PTMP/PARJ(48)
60579 ENDIF
60580 270 CONTINUE
60581C...Put |p| rather than m in 5th slot.
60582 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
60583 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
60584 280 CONTINUE
60585
60586C...Calculate boost from present frame to next JRF candidate.
60587 IJRFIT=IJRFIT+1
60588 CALL PYJURF(PBST,TJU)
60589
60590C...After some iterations do not take full step in new direction.
60591 IF(IJRFIT.GT.5) THEN
60592 REDUCE=0.8D0**(IJRFIT-5)
60593 TJU(1)=REDUCE*TJU(1)
60594 TJU(2)=REDUCE*TJU(2)
60595 TJU(3)=REDUCE*TJU(3)
60596 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
60597 ENDIF
60598
60599C...Combine new boost (TJU) with old boost (TJUOLD)
60600 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
60601 DO 290 IX=1,3
60602 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
60603 290 CONTINUE
60604 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
60605
60606C...If last boost small, accept JRF, else iterate.
60607C...Also prevent possibility of infinite loop.
60608 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
60609 & IJRFIT.LT.MSTJ(18)) THEN
60610 GOTO 220
60611 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
60612 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
60613 ENDIF
60614
60615C...Now store total boost in TJU and change perception.
60616C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
60617C...TJU = junction motion vector in string CM, so the sign changes.
60618 DO 300 J=1,3
60619 TJU(J)=-TJUOLD(J)
60620 300 CONTINUE
60621 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
60622
60623C--SKANDS
60624
60625C...Calculate string piece energies in junction rest frame.
60626 DO 310 IU=1,3
60627 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
60628 & TJU(3)*PJU(IU,3)
60629 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
60630 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
60631 310 CONTINUE
60632
60633C...Start preparing for fragmentation of two strings from junction.
60634 ISTA=I
60635 NTRYER=0
60636 320 NTRYER=NTRYER+1
60637 I=ISTA
60638 DO 620 IU=1,2
60639 NS=IABS(IJU(IU+1)-IJU(IU))
60640
60641C...Junction strings: find longitudinal string directions.
60642 DO 350 IS=1,NS
60643 IS1=IJU(IU)+JS*(IS-1)
60644 IS2=IJU(IU)+JS*IS
60645 DO 330 J=1,5
60646 DP(1,J)=0.5D0*P(IS1,J)
60647 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
60648 DP(2,J)=0.5D0*P(IS2,J)
60649 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
60650 & (PJU(IU,5)/PBST(IU,5))
60651 330 CONTINUE
60652 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
60653 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
60654 DP(3,5)=DFOUR(1,1)
60655 DP(4,5)=DFOUR(2,2)
60656 DHKC=DFOUR(1,2)
60657 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
60658 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
60659 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
60660 DP(3,5)=0D0
60661 DP(4,5)=0D0
60662 DHKC=DFOUR(1,2)
60663 ENDIF
60664 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
60665 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
60666 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
60667 IN1=N+NR+4*IS-3
60668 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
60669 DO 340 J=1,4
60670 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
60671 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
60672 340 CONTINUE
60673 350 CONTINUE
60674
60675C...Junction strings: initialize flavour, momentum and starting pos.
60676 ISAV=I
60677 MSTU91=MSTU(90)
60678 360 NTRY=NTRY+1
60679 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
60680 PARU12=4D0*PARU12
60681 PARU13=2D0*PARU13
60682 GOTO 140
60683 ELSEIF(NTRY.GT.100) THEN
60684 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
60685 IF(MSTU(21).GE.1) RETURN
60686 ENDIF
60687 I=ISAV
60688 MSTU(90)=MSTU91
60689 IRANKJ=0
60690 IE(1)=K(N+1+(JT/2)*(NP-1),3)
60691 IF (MOD(JT+IU,2).NE.0) THEN
60692 IE(1)=K(IJU(IU),3)
60693 IF (NP-NR.NE.0) THEN
60694C...If gluons have disappeared. Original IJU must be used.
60695 IT=IP
60696 NE=1
60697 370 IT=IT+1
60698 IF (K(IT,2).NE.21) THEN
60699 NE=NE+1
60700 ENDIF
60701 IF (NE.EQ.IU+4*(JT-1)) THEN
60702 IE(1)=IT
60703 ELSEIF (IT.LE.IP+NP) THEN
60704 GOTO 370
60705 ELSE
60706 CALL PYERRM(14,'(PYSTRF:) '//
60707 & 'Original IJU could not be reconstructed!')
60708 ENDIF
60709 ENDIF
60710 ENDIF
60711 IN(4)=N+NR+1
60712 IN(5)=IN(4)+1
60713 IN(6)=N+NR+4*NS+1
60714 DO 390 JQ=1,2
60715 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
60716 P(IN1,1)=2-JQ
60717 P(IN1,2)=JQ-1
60718 P(IN1,3)=1D0
60719 380 CONTINUE
60720 390 CONTINUE
60721 KFL(1)=K(IJU(IU),2)
60722 PX(1)=0D0
60723 PY(1)=0D0
60724 GAM(1)=0D0
60725 DO 400 J=1,5
60726 PJU(IU+3,J)=0D0
60727 400 CONTINUE
60728
60729C...Junction strings: find initial transverse directions.
60730 DO 410 J=1,4
60731 DP(1,J)=P(IN(4),J)
60732 DP(2,J)=P(IN(4)+1,J)
60733 DP(3,J)=0D0
60734 DP(4,J)=0D0
60735 410 CONTINUE
60736 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
60737 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
60738 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
60739 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
60740 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
60741 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
60742 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
60743 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
60744 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
60745 DHC12=DFOUR(1,2)
60746 DHCX1=DFOUR(3,1)/DHC12
60747 DHCX2=DFOUR(3,2)/DHC12
60748 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
60749 DHCY1=DFOUR(4,1)/DHC12
60750 DHCY2=DFOUR(4,2)/DHC12
60751 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
60752 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
60753 DO 420 J=1,4
60754 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
60755 P(IN(6),J)=DP(3,J)
60756 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
60757 & DHCYX*DP(3,J))
60758 420 CONTINUE
60759
60760C...Junction strings: produce new particle, origin.
60761 430 I=I+1
60762 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
60763 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
60764 IF(MSTU(21).GE.1) RETURN
60765 ENDIF
60766 IRANKJ=IRANKJ+1
60767 K(I,1)=1
60768 K(I,3)=IE(1)
60769 K(I,4)=0
60770 K(I,5)=0
60771
60772C...Junction strings: generate flavour, hadron, pT, z and Gamma.
60773 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
60774 IF(K(I,2).EQ.0) GOTO 360
60775 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
60776 & IABS(KFL(3)).GT.10) THEN
60777 IF(PYR(0).GT.PARJ(19)) GOTO 440
60778 ENDIF
60779 P(I,5)=PYMASS(K(I,2))
60780 CALL PYPTDI(KFL(1),PX(3),PY(3))
60781 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
60782 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
60783 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
60784 & MSTU(90).LT.8) THEN
60785 MSTU(90)=MSTU(90)+1
60786 MSTU(90+MSTU(90))=I
60787 PARU(90+MSTU(90))=Z
60788 ENDIF
60789 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
60790 DO 450 J=1,3
60791 IN(J)=IN(3+J)
60792 450 CONTINUE
60793
60794C...Junction strings: stepping within 'low' string region.
60795 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
60796 & P(IN(1),5)**2.GE.PR(1)) THEN
60797 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
60798 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
60799 DO 460 J=1,4
60800 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
60801 460 CONTINUE
60802 GOTO 560
60803C...Has used up energy of junction string, i.e. no more hadrons in it.
60804 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
60805 DO 470 J=1,5
60806 P(I,J)=0D0
60807 470 CONTINUE
60808 GOTO 600
60809C...Stepping from 'low' string region
60810 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
60811 P(IN(2)+2,4)=P(IN(2)+2,3)
60812 P(IN(2)+2,1)=1D0
60813 IN(2)=IN(2)+4
60814 IF(IN(2).GT.N+NR+4*NS) GOTO 360
60815 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
60816 P(IN(1)+2,4)=P(IN(1)+2,3)
60817 P(IN(1)+2,1)=0D0
60818 IN(1)=IN(1)+4
60819 ENDIF
60820 ENDIF
60821
60822C...Junction strings: find new transverse directions.
60823 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
60824 & IN(1).GT.IN(2)) GOTO 360
60825 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
60826 DO 490 J=1,4
60827 DP(1,J)=P(IN(1),J)
60828 DP(2,J)=P(IN(2),J)
60829 DP(3,J)=0D0
60830 DP(4,J)=0D0
60831 490 CONTINUE
60832 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
60833 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
60834 DHC12=DFOUR(1,2)
60835 IF(DHC12.LE.1D-2) THEN
60836 P(IN(1)+2,4)=P(IN(1)+2,3)
60837 P(IN(1)+2,1)=0D0
60838 IN(1)=IN(1)+4
60839 GOTO 480
60840 ENDIF
60841 IN(3)=N+NR+4*NS+5
60842 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
60843 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
60844 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
60845 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
60846 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
60847 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
60848 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
60849 DHCX1=DFOUR(3,1)/DHC12
60850 DHCX2=DFOUR(3,2)/DHC12
60851 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
60852 DHCY1=DFOUR(4,1)/DHC12
60853 DHCY2=DFOUR(4,2)/DHC12
60854 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
60855 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
60856 DO 500 J=1,4
60857 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
60858 P(IN(3),J)=DP(3,J)
60859 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
60860 & DHCYX*DP(3,J))
60861 500 CONTINUE
60862C...Express pT with respect to new axes, if sensible.
60863 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
60864 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
60865 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
60866 PX(3)=PXP
60867 PY(3)=PYP
60868 ENDIF
60869 ENDIF
60870
60871C...Junction strings: sum up known four-momentum, coefficients for m2.
60872 DO 530 J=1,4
60873 DHG(J)=0D0
60874 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
60875 & PY(3)*P(IN(3)+1,J)
60876 DO 510 IN1=IN(4),IN(1)-4,4
60877 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
60878 510 CONTINUE
60879 DO 520 IN2=IN(5),IN(2)-4,4
60880 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
60881 520 CONTINUE
60882 530 CONTINUE
60883 DHM(1)=FOUR(I,I)
60884 DHM(2)=2D0*FOUR(I,IN(1))
60885 DHM(3)=2D0*FOUR(I,IN(2))
60886 DHM(4)=2D0*FOUR(IN(1),IN(2))
60887
60888C...Junction strings: find coefficients for Gamma expression.
60889 DO 550 IN2=IN(1)+1,IN(2),4
60890 DO 540 IN1=IN(1),IN2-1,4
60891 DHC=2D0*FOUR(IN1,IN2)
60892 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
60893 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
60894 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
60895 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
60896 540 CONTINUE
60897 550 CONTINUE
60898
60899C...Junction strings: solve (m2, Gamma) equation system for energies.
60900 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
60901 IF(ABS(DHS1).LT.1D-4) GOTO 360
60902 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
60903 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
60904 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
60905 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
60906 & ABS(DHS1)-DHS2/DHS1)
60907 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
60908 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
60909 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
60910
60911C...Junction strings: step to new region if necessary.
60912 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
60913 P(IN(2)+2,4)=P(IN(2)+2,3)
60914 P(IN(2)+2,1)=1D0
60915 IN(2)=IN(2)+4
60916 IF(IN(2).GT.N+NR+4*NS) GOTO 360
60917 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
60918 P(IN(1)+2,4)=P(IN(1)+2,3)
60919 P(IN(1)+2,1)=0D0
60920 IN(1)=IN(1)+4
60921 ENDIF
60922 GOTO 480
60923 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
60924 P(IN(1)+2,4)=P(IN(1)+2,3)
60925 P(IN(1)+2,1)=0D0
60926 IN(1)=IN(1)+4
60927 GOTO 480
60928 ENDIF
60929
60930C...Junction strings: particle four-momentum, remainder, loop back.
60931 560 DO 570 J=1,4
60932 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
60933 & P(IN(2)+2,4)*P(IN(2),J)
60934 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
60935 570 CONTINUE
60936 IF(P(I,4).LT.P(I,5)) GOTO 360
60937 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
60938 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
60939 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
60940 KFL(1)=-KFL(3)
60941 PX(1)=-PX(3)
60942 PY(1)=-PY(3)
60943 GAM(1)=GAM(3)
60944 IF(IN(3).NE.IN(6)) THEN
60945 DO 580 J=1,4
60946 P(IN(6),J)=P(IN(3),J)
60947 P(IN(6)+1,J)=P(IN(3)+1,J)
60948 580 CONTINUE
60949 ENDIF
60950 DO 590 JQ=1,2
60951 IN(3+JQ)=IN(JQ)
60952 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
60953 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
60954 590 CONTINUE
60955 GOTO 430
60956 ENDIF
60957
60958C...Junction strings: save quantities left after each string.
60959 IF(IABS(KFL(1)).GT.10) GOTO 360
60960 600 I=I-1
60961 KFJH(IU)=KFL(1)
60962 DO 610 J=1,4
60963 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
60964 610 CONTINUE
60965
60966C...Junction strings: loopback if much unused energy in both strings.
60967 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
60968 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
60969 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
60970 620 CONTINUE
60971 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
60972 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
60973 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
60974 & .AND.NTRYER.LT.10) GOTO 320
60975
60976C...Junction strings: put together to new effective string endpoint.
60977 NJS(JT)=I-ISTA
60978 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
60979 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
60980 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
60981 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
60982 DO 630 J=1,4
60983 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
60984 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
60985 630 CONTINUE
60986 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
60987 & PJS(JT,3)**2))
60988 PJS(JT+2,5)=0D0
60989 640 CONTINUE
60990
60991C...Open versus closed strings. Choose breakup region for latter.
60992 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
60993 NS=MJU(2)-MJU(1)
60994 NB=MJU(1)-N
60995 ELSEIF(MJU(1).NE.0) THEN
60996 NS=N+NR-MJU(1)
60997 NB=MJU(1)-N
60998 ELSEIF(MJU(2).NE.0) THEN
60999 NS=MJU(2)-N
61000 NB=1
61001 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
61002 NS=NR-1
61003 NB=1
61004 ELSE
61005 NS=NR+1
61006 W2SUM=0D0
61007 DO 660 IS=1,NR
61008 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
61009 W2SUM=W2SUM+P(N+NR+IS,1)
61010 660 CONTINUE
61011 W2RAN=PYR(0)*W2SUM
61012 NB=0
61013 670 NB=NB+1
61014 W2SUM=W2SUM-P(N+NR+NB,1)
61015 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
61016 ENDIF
61017
61018C...Find longitudinal string directions (i.e. lightlike four-vectors).
61019 DO 700 IS=1,NS
61020 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
61021 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
61022 DO 680 J=1,5
61023 DP(1,J)=P(IS1,J)
61024 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
61025 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
61026 DP(2,J)=P(IS2,J)
61027 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
61028 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
61029 680 CONTINUE
61030 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
61031 & DP(1,2)**2-DP(1,3)**2))
61032 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
61033 & DP(2,2)**2-DP(2,3)**2))
61034 DP(3,5)=DFOUR(1,1)
61035 DP(4,5)=DFOUR(2,2)
61036 DHKC=DFOUR(1,2)
61037 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
61038 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
61039 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
61040 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
61041 IN1=N+NR+4*IS-3
61042 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
61043 DO 690 J=1,4
61044 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
61045 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
61046 690 CONTINUE
61047 700 CONTINUE
61048
61049C...Begin initialization: sum up energy, set starting position.
61050 ISAV=I
61051 MSTU91=MSTU(90)
61052 710 NTRY=NTRY+1
61053 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61054 PARU12=4D0*PARU12
61055 PARU13=2D0*PARU13
61056 GOTO 140
61057 ELSEIF(NTRY.GT.100) THEN
61058 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61059 IF(MSTU(21).GE.1) RETURN
61060 ENDIF
61061 I=ISAV
61062 MSTU(90)=MSTU91
61063 DO 730 J=1,4
61064 P(N+NRS,J)=0D0
61065 DO 720 IS=1,NR
61066 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
61067 720 CONTINUE
61068 730 CONTINUE
61069 DO 750 JT=1,2
61070 IRANK(JT)=0
61071 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
61072 IF(NS.GT.NR) IRANK(JT)=1
61073 IBARRK(JT)=0
61074 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
61075 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
61076 IN(3*JT+2)=IN(3*JT+1)+1
61077 IN(3*JT+3)=N+NR+4*NS+2*JT-1
61078 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
61079 P(IN1,1)=2-JT
61080 P(IN1,2)=JT-1
61081 P(IN1,3)=1D0
61082 740 CONTINUE
61083 750 CONTINUE
61084
61085C.. MOPS variables and switches
61086 NRVMO=0
61087 XBMO=1D0
61088 MSTU(121)=0
61089 MSTU(122)=0
61090
61091C...Initialize flavour and pT variables for open string.
61092 IF(NS.LT.NR) THEN
61093 PX(1)=0D0
61094 PY(1)=0D0
61095 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
61096 PX(2)=-PX(1)
61097 PY(2)=-PY(1)
61098 DO 760 JT=1,2
61099 KFL(JT)=K(IE(JT),2)
61100 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
61101 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
61102 MSTJ(93)=1
61103 PMQ(JT)=PYMASS(KFL(JT))
61104 GAM(JT)=0D0
61105 760 CONTINUE
61106
61107C...Closed string: random initial breakup flavour, pT and vertex.
61108 ELSE
61109 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
61110 IBMO=0
61111 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
61112C.. Closed string: first vertex diq attempt => enforced second
61113C.. vertex diq
61114 IF(IABS(KFL(1)).GT.10)THEN
61115 IBMO=1
61116 MSTU(121)=0
61117 GOTO 770
61118 ENDIF
61119 IF(IBMO.EQ.1) MSTU(121)=-1
61120 KFL(2)=-KFL(1)
61121 CALL PYPTDI(KFL(1),PX(1),PY(1))
61122 PX(2)=-PX(1)
61123 PY(2)=-PY(1)
61124 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
61125 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
61126 ZR=PR3/(Z*P(N+NR+1,5)**2)
61127 IF(ZR.GE.1D0) GOTO 780
61128 DO 790 JT=1,2
61129 MSTJ(93)=1
61130 PMQ(JT)=PYMASS(KFL(JT))
61131 GAM(JT)=PR3*(1D0-Z)/Z
61132 IN1=N+NR+3+4*(JT/2)*(NS-1)
61133 P(IN1,JT)=1D0-Z
61134 P(IN1,3-JT)=JT-1
61135 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
61136 P(IN1+1,JT)=ZR
61137 P(IN1+1,3-JT)=2-JT
61138 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
61139 790 CONTINUE
61140 ENDIF
61141C.. MOPS variables
61142 DO 800 JT=1,2
61143 XTMO(JT)=1D0
61144 PM2QMO(JT)=PMQ(JT)**2
61145 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
61146 800 CONTINUE
61147
61148C...Find initial transverse directions (i.e. spacelike four-vectors).
61149 DO 840 JT=1,2
61150 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
61151 IN1=IN(3*JT+1)
61152 IN3=IN(3*JT+3)
61153 DO 810 J=1,4
61154 DP(1,J)=P(IN1,J)
61155 DP(2,J)=P(IN1+1,J)
61156 DP(3,J)=0D0
61157 DP(4,J)=0D0
61158 810 CONTINUE
61159 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
61160 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
61161 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
61162 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
61163 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
61164 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
61165 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
61166 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
61167 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
61168 DHC12=DFOUR(1,2)
61169 DHCX1=DFOUR(3,1)/DHC12
61170 DHCX2=DFOUR(3,2)/DHC12
61171 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
61172 DHCY1=DFOUR(4,1)/DHC12
61173 DHCY2=DFOUR(4,2)/DHC12
61174 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
61175 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
61176 DO 820 J=1,4
61177 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
61178 P(IN3,J)=DP(3,J)
61179 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
61180 & DHCYX*DP(3,J))
61181 820 CONTINUE
61182 ELSE
61183 DO 830 J=1,4
61184 P(IN3+2,J)=P(IN3,J)
61185 P(IN3+3,J)=P(IN3+1,J)
61186 830 CONTINUE
61187 ENDIF
61188 840 CONTINUE
61189
61190C...Remove energy used up in junction string fragmentation.
61191 IF(MJU(1)+MJU(2).GT.0) THEN
61192 DO 860 JT=1,2
61193 IF(NJS(JT).EQ.0) GOTO 860
61194 DO 850 J=1,4
61195 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
61196 850 CONTINUE
61197 860 CONTINUE
61198 PARJST=PARJ(33)
61199 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
61200 WMIN=PARJST+PMQ(1)+PMQ(2)
61201 WREM2=FOUR(N+NRS,N+NRS)
61202 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
61203 NTRYWR=NTRYWR+1
61204 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
61205 GOTO 140
61206 ENDIF
61207 ENDIF
61208
61209C...Produce new particle: side, origin.
61210 870 I=I+1
61211 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
61212 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61213 IF(MSTU(21).GE.1) RETURN
61214 ENDIF
61215C.. New side priority for popcorn systems
61216 IF(MSTU(121).LE.0)THEN
61217 JT=1.5D0+PYR(0)
61218 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
61219 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
61220 ENDIF
61221 JR=3-JT
61222 JS=3-2*JT
61223 IRANK(JT)=IRANK(JT)+1
61224 K(I,1)=1
61225 K(I,4)=0
61226 K(I,5)=0
61227
61228C...Generate flavour, hadron and pT.
61229 880 K(I,3)=IE(JT)
61230 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
61231 IF(K(I,2).EQ.0) GOTO 710
61232 MU90MO=MSTU(90)
61233 IF(MSTU(121).EQ.-1) GOTO 910
61234 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
61235 &IABS(KFL(3)).GT.10) THEN
61236 IF(PYR(0).GT.PARJ(19)) GOTO 880
61237 ENDIF
61238 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61239 &K(I,3)=IJUORI(JT)
61240 P(I,5)=PYMASS(K(I,2))
61241 CALL PYPTDI(KFL(JT),PX(3),PY(3))
61242 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
61243
61244C...Final hadrons for small invariant mass.
61245 MSTJ(93)=1
61246 PMQ(3)=PYMASS(KFL(3))
61247 PARJST=PARJ(33)
61248 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
61249 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
61250 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
61251 &WMIN-0.5D0*PARJ(36)*PMQ(3)
61252 WREM2=FOUR(N+NRS,N+NRS)
61253 IF(WREM2.LT.0.10D0) GOTO 710
61254 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
61255 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
61256
61257C...Choose z, which gives Gamma. Shift z for heavy flavours.
61258 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
61259 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
61260 &MSTU(90).LT.8) THEN
61261 MSTU(90)=MSTU(90)+1
61262 MSTU(90+MSTU(90))=I
61263 PARU(90+MSTU(90))=Z
61264 ENDIF
61265 KFL1A=IABS(KFL(1))
61266 KFL2A=IABS(KFL(2))
61267 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
61268 &MOD(KFL2A/1000,10)).GE.4) THEN
61269 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
61270 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
61271 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
61272 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
61273 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
61274 ENDIF
61275 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
61276
61277C.. MOPS baryon model modification
61278 XTMO3=(1D0-Z)*XTMO(JT)
61279 IF(IABS(KFL(3)).LE.10) NRVMO=0
61280 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
61281 GTSTMO=1D0
61282 PTSTMO=1D0
61283 RTSTMO=PYR(0)
61284 IF(IABS(KFL(JT)).LE.10)THEN
61285 XBMO=MIN(XTMO3,1D0-(2D-10))
61286 GBMO=GAM(3)
61287 PMMO=0D0
61288 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
61289 GTSTMO=1D0-PARF(192)**PGMO
61290 ELSE
61291 IF(IRANK(JT).EQ.1) THEN
61292 GBMO=GAM(JT)
61293 PMMO=0D0
61294 XBMO=1D0
61295 ENDIF
61296 IF(XBMO.LT.1D0-(1D-10))THEN
61297 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
61298 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
61299 PGMO=PGNMO
61300 ENDIF
61301 IF(MSTJ(12).GE.5)THEN
61302 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
61303 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
61304 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
61305 PMMO=PMNMO
61306 ENDIF
61307 ENDIF
61308
61309C.. MOPS Accepting popcorn system hadron.
61310 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
61311 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
61312 NRVMO=I-N-NR
61313 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
61314 CALL PYERRM(11,
61315 & '(PYSTRF:) no more memory left in PYJETS')
61316 IF(MSTU(21).GE.1) RETURN
61317 ENDIF
61318 IMO=I
61319 KFLMO=KFL(JT)
61320 PMQMO=PMQ(JT)
61321 PXMO=PX(JT)
61322 PYMO=PY(JT)
61323 GAMMO=GAM(JT)
61324 IRMO=IRANK(JT)
61325 XMO=XTMO(JT)
61326 DO 900 J=1,9
61327 IF(J.LE.5) THEN
61328 DO 890 LINE=1,I-N-NR
61329 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
61330 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
61331 890 CONTINUE
61332 ENDIF
61333 INMO(J)=IN(J)
61334 900 CONTINUE
61335 ENDIF
61336 ELSE
61337C..Reject popcorn system, flag=-1 if enforcing new one
61338 MSTU(121)=-1
61339 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
61340 ENDIF
61341 ENDIF
61342
61343
61344C..Lift restoring string outside MOPS block
61345 910 IF(MSTU(121).LT.0) THEN
61346 IF(MSTU(121).EQ.-2) MSTU(121)=0
61347 MSTU(90)=MU90MO
61348 NRVMO=0
61349 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
61350 I=IMO
61351 KFL(JT)=KFLMO
61352 PMQ(JT)=PMQMO
61353 PX(JT)=PXMO
61354 PY(JT)=PYMO
61355 GAM(JT)=GAMMO
61356 IRANK(JT)=IRMO
61357 XTMO(JT)=XMO
61358 DO 930 J=1,9
61359 IF(J.LE.5) THEN
61360 DO 920 LINE=1,I-N-NR
61361 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
61362 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
61363 920 CONTINUE
61364 ENDIF
61365 IN(J)=INMO(J)
61366 930 CONTINUE
61367 GOTO 880
61368 ENDIF
61369 XTMO(JT)=XTMO3
61370C.. MOPS end of modification
61371
61372 DO 940 J=1,3
61373 IN(J)=IN(3*JT+J)
61374 940 CONTINUE
61375
61376C...Stepping within or from 'low' string region easy.
61377 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
61378 &P(IN(1),5)**2.GE.PR(JT)) THEN
61379 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
61380 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
61381 DO 950 J=1,4
61382 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
61383 950 CONTINUE
61384 GOTO 1040
61385 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
61386 P(IN(JR)+2,4)=P(IN(JR)+2,3)
61387 P(IN(JR)+2,JT)=1D0
61388 IN(JR)=IN(JR)+4*JS
61389 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
61390 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
61391 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61392 P(IN(JT)+2,JT)=0D0
61393 IN(JT)=IN(JT)+4*JS
61394 ENDIF
61395 ENDIF
61396
61397C...Find new transverse directions (i.e. spacelike string vectors).
61398 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
61399 &IN(1).GT.IN(2)) GOTO 710
61400 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
61401 DO 970 J=1,4
61402 DP(1,J)=P(IN(1),J)
61403 DP(2,J)=P(IN(2),J)
61404 DP(3,J)=0D0
61405 DP(4,J)=0D0
61406 970 CONTINUE
61407 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
61408 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
61409 DHC12=DFOUR(1,2)
61410 IF(DHC12.LE.1D-2) THEN
61411 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61412 P(IN(JT)+2,JT)=0D0
61413 IN(JT)=IN(JT)+4*JS
61414 GOTO 960
61415 ENDIF
61416 IN(3)=N+NR+4*NS+5
61417 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
61418 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
61419 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
61420 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
61421 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
61422 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
61423 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
61424 DHCX1=DFOUR(3,1)/DHC12
61425 DHCX2=DFOUR(3,2)/DHC12
61426 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
61427 DHCY1=DFOUR(4,1)/DHC12
61428 DHCY2=DFOUR(4,2)/DHC12
61429 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
61430 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
61431 DO 980 J=1,4
61432 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
61433 P(IN(3),J)=DP(3,J)
61434 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
61435 & DHCYX*DP(3,J))
61436 980 CONTINUE
61437C...Express pT with respect to new axes, if sensible.
61438 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
61439 & FOUR(IN(3*JT+3)+1,IN(3)))
61440 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
61441 & FOUR(IN(3*JT+3)+1,IN(3)+1))
61442 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
61443 PX(3)=PXP
61444 PY(3)=PYP
61445 ENDIF
61446 ENDIF
61447
61448C...Sum up known four-momentum. Gives coefficients for m2 expression.
61449 DO 1010 J=1,4
61450 DHG(J)=0D0
61451 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
61452 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
61453 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
61454 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
61455 990 CONTINUE
61456 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
61457 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
61458 1000 CONTINUE
61459 1010 CONTINUE
61460 DHM(1)=FOUR(I,I)
61461 DHM(2)=2D0*FOUR(I,IN(1))
61462 DHM(3)=2D0*FOUR(I,IN(2))
61463 DHM(4)=2D0*FOUR(IN(1),IN(2))
61464
61465C...Find coefficients for Gamma expression.
61466 DO 1030 IN2=IN(1)+1,IN(2),4
61467 DO 1020 IN1=IN(1),IN2-1,4
61468 DHC=2D0*FOUR(IN1,IN2)
61469 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
61470 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
61471 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
61472 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
61473 1020 CONTINUE
61474 1030 CONTINUE
61475
61476C...Solve (m2, Gamma) equation system for energies taken.
61477 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
61478 IF(ABS(DHS1).LT.1D-4) GOTO 710
61479 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
61480 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
61481 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
61482 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
61483 &ABS(DHS1)-DHS2/DHS1)
61484 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
61485 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
61486 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
61487
61488C...Step to new region if necessary.
61489 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
61490 P(IN(JR)+2,4)=P(IN(JR)+2,3)
61491 P(IN(JR)+2,JT)=1D0
61492 IN(JR)=IN(JR)+4*JS
61493 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
61494 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
61495 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61496 P(IN(JT)+2,JT)=0D0
61497 IN(JT)=IN(JT)+4*JS
61498 ENDIF
61499 GOTO 960
61500 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
61501 P(IN(JT)+2,4)=P(IN(JT)+2,3)
61502 P(IN(JT)+2,JT)=0D0
61503 IN(JT)=IN(JT)+4*JS
61504 GOTO 960
61505 ENDIF
61506
61507C...Four-momentum of particle. Remaining quantities. Loop back.
61508 1040 DO 1050 J=1,4
61509 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
61510 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
61511 1050 CONTINUE
61512 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
61513 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
61514 &GOTO 200
61515 IF(P(I,4).LT.P(I,5)) GOTO 710
61516 KFL(JT)=-KFL(3)
61517 PMQ(JT)=PMQ(3)
61518 PX(JT)=-PX(3)
61519 PY(JT)=-PY(3)
61520 GAM(JT)=GAM(3)
61521 IF(IN(3).NE.IN(3*JT+3)) THEN
61522 DO 1060 J=1,4
61523 P(IN(3*JT+3),J)=P(IN(3),J)
61524 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
61525 1060 CONTINUE
61526 ENDIF
61527 DO 1070 JQ=1,2
61528 IN(3*JT+JQ)=IN(JQ)
61529 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
61530 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
61531 1070 CONTINUE
61532 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61533 &IBARRK(JT)=0
61534 GOTO 870
61535
61536C...Final hadron: side, flavour, hadron, mass.
61537 1080 I=I+1
61538 K(I,1)=1
61539 K(I,3)=IE(JR)
61540 K(I,4)=0
61541 K(I,5)=0
61542 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
61543 IF(K(I,2).EQ.0) GOTO 710
61544 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
61545 &IBARRK(JT)=0
61546 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61547 &K(I,3)=IJUORI(JT)
61548 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
61549 &K(I,3)=IJUORI(JR)
61550 P(I,5)=PYMASS(K(I,2))
61551 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
61552
61553C...Final two hadrons: find common setup of four-vectors.
61554 JQ=1
61555 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
61556 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
61557 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
61558 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
61559 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
61560 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
61561 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
61562 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
61563 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
61564 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
61565 ENDIF
61566
61567C...Solve kinematics for final two hadrons, if possible.
61568 WREM2=2D0*DHR1*DHR2*DHC12
61569 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
61570 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
61571 IF(FD.GE.1D0) GOTO 710
61572 FA=WREM2+PR(JT)-PR(JR)
61573 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
61574 PREVCF=PARJ(42)
61575 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61576 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
61577 FB=SIGN(FB,JS*(PYR(0)-PREV))
61578 KFL1A=IABS(KFL(1))
61579 KFL2A=IABS(KFL(2))
61580 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
61581 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
61582 &4D0*WREM2*PR(JT))),DBLE(JS))
61583 DO 1090 J=1,4
61584 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
61585 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
61586 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
61587 P(I,J)=P(N+NRS,J)-P(I-1,J)
61588 1090 CONTINUE
61589 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
61590 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
61591 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
61592 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
61593 NTRYFN=NTRYFN+1
61594 IF(NTRYFN.LT.100) GOTO 140
61595 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
61596 ENDIF
61597
61598C...Mark jets as fragmented and give daughter pointers.
61599 N=I-NRS+1
61600 DO 1100 I=NSAV+1,NSAV+NP
61601 IM=K(I,3)
61602 K(IM,1)=K(IM,1)+10
61603 IF(MSTU(16).NE.2) THEN
61604 K(IM,4)=NSAV+1
61605 K(IM,5)=NSAV+1
61606 ELSE
61607 K(IM,4)=NSAV+2
61608 K(IM,5)=N
61609 ENDIF
61610 1100 CONTINUE
61611
61612C...Document string system. Move up particles.
61613 NSAV=NSAV+1
61614 K(NSAV,1)=11
61615 K(NSAV,2)=92
61616 K(NSAV,3)=IP
61617 K(NSAV,4)=NSAV+1
61618 K(NSAV,5)=N
61619 DO 1110 J=1,4
61620 P(NSAV,J)=DPS(J)
61621 V(NSAV,J)=V(IP,J)
61622 1110 CONTINUE
61623 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
61624 V(NSAV,5)=0D0
61625 DO 1130 I=NSAV+1,N
61626 DO 1120 J=1,5
61627 K(I,J)=K(I+NRS-1,J)
61628 P(I,J)=P(I+NRS-1,J)
61629 V(I,J)=0D0
61630 1120 CONTINUE
61631 1130 CONTINUE
61632 MSTU91=MSTU(90)
61633 DO 1140 IZ=MSTU90+1,MSTU91
61634 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
61635 PARU9T(IZ)=PARU(90+IZ)
61636 1140 CONTINUE
61637 MSTU(90)=MSTU90
61638
61639C...Order particles in rank along the chain. Update mother pointer.
61640 DO 1160 I=NSAV+1,N
61641 DO 1150 J=1,5
61642 K(I-NSAV+N,J)=K(I,J)
61643 P(I-NSAV+N,J)=P(I,J)
61644 1150 CONTINUE
61645 1160 CONTINUE
61646 I1=NSAV
61647 DO 1190 I=N+1,2*N-NSAV
61648 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
61649 I1=I1+1
61650 DO 1170 J=1,5
61651 K(I1,J)=K(I,J)
61652 P(I1,J)=P(I,J)
61653 1170 CONTINUE
61654 IF(MSTU(16).NE.2) K(I1,3)=NSAV
61655 DO 1180 IZ=MSTU90+1,MSTU91
61656 IF(MSTU9T(IZ).EQ.I) THEN
61657 MSTU(90)=MSTU(90)+1
61658 MSTU(90+MSTU(90))=I1
61659 PARU(90+MSTU(90))=PARU9T(IZ)
61660 ENDIF
61661 1180 CONTINUE
61662 1190 CONTINUE
61663 DO 1220 I=2*N-NSAV,N+1,-1
61664 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
61665 I1=I1+1
61666 DO 1200 J=1,5
61667 K(I1,J)=K(I,J)
61668 P(I1,J)=P(I,J)
61669 1200 CONTINUE
61670 IF(MSTU(16).NE.2) K(I1,3)=NSAV
61671 DO 1210 IZ=MSTU90+1,MSTU91
61672 IF(MSTU9T(IZ).EQ.I) THEN
61673 MSTU(90)=MSTU(90)+1
61674 MSTU(90+MSTU(90))=I1
61675 PARU(90+MSTU(90))=PARU9T(IZ)
61676 ENDIF
61677 1210 CONTINUE
61678 1220 CONTINUE
61679
61680C...Boost back particle system. Set production vertices.
61681 IF(MBST.EQ.0) THEN
61682 MSTU(33)=1
61683 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
61684 & DPS(3)/DPS(4))
61685 ELSE
61686 DO 1230 I=NSAV+1,N
61687 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61688 IF(P(I,3).GT.0D0) THEN
61689 HHPEZ=(P(I,4)+P(I,3))*HHBZ
61690 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61691 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61692 ELSE
61693 HHPEZ=(P(I,4)-P(I,3))/HHBZ
61694 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61695 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61696 ENDIF
61697 1230 CONTINUE
61698 ENDIF
61699 DO 1250 I=NSAV+1,N
61700 DO 1240 J=1,4
61701 V(I,J)=V(IP,J)
61702 1240 CONTINUE
61703 1250 CONTINUE
61704
61705 RETURN
61706 END
61707
61708C*********************************************************************
61709
61710C...PYJURF
61711C...From three given input vectors in PJU the boost VJU from
61712C...the "lab frame" to the junction rest frame is constructed.
61713
61714 SUBROUTINE PYJURF(PJU,VJU)
61715
61716C...Double precision and integer declarations.
61717 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61718 IMPLICIT INTEGER(I-N)
61719
61720C...Input, output and local arrays.
61721 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
61722 DATA TWOPI/6.283186D0/
61723
61724C...Calculate masses and other invariants.
61725 DO 100 J=1,4
61726 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
61727 100 CONTINUE
61728 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
61729 PSUM(5)=SQRT(PSUM2)
61730 DO 120 I=1,3
61731 DO 110 J=1,3
61732 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
61733 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
61734 110 CONTINUE
61735 120 CONTINUE
61736
61737C...Pick I to be most massive parton and J to be the one closest to I.
61738 ITRY=0
61739 I=1
61740 IF(A(2,2).GT.A(1,1)) I=2
61741 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
61742 130 ITRY=ITRY+1
61743 J=1+MOD(I,3)
61744 K=1+MOD(J,3)
61745 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
61746 K=1+MOD(I,3)
61747 J=1+MOD(K,3)
61748 ENDIF
61749 PMI2=A(I,I)
61750 PMJ2=A(J,J)
61751 PMK2=A(K,K)
61752 AIJ=A(I,J)
61753 AIK=A(I,K)
61754 AJK=A(J,K)
61755
61756C...Trivial find new parton energies if all three partons are massless.
61757 IF(PMI2.LT.1D-4) THEN
61758 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
61759 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
61760 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
61761
61762C...Else find momentum range for parton I and values at extremes.
61763 ELSE
61764 PAIMIN=0D0
61765 PEIMIN=SQRT(PMI2)
61766 PEJMIN=AIJ/PEIMIN
61767 PEKMIN=AIK/PEIMIN
61768 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
61769 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
61770 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
61771 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
61772 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
61773 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
61774 HI=PEIMAX**2-0.25D0*PAIMAX**2
61775 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
61776 & 0.5D0*PAIMAX*AIJ)/HI
61777 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
61778 & 0.5D0*PAIMAX*AIK)/HI
61779 PEJMAX=SQRT(PAJMAX**2+PMJ2)
61780 PEKMAX=SQRT(PAKMAX**2+PMK2)
61781 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
61782
61783C...If unexpected values at upper endpoint then pick another parton.
61784 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
61785 I1=1+MOD(I,3)
61786 IF(A(I1,I1).GE.1D-4) THEN
61787 I=I1
61788 GOTO 130
61789 ENDIF
61790 ITRY=ITRY+1
61791 I1=1+MOD(I,3)
61792 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
61793 I=I1
61794 GOTO 130
61795 ENDIF
61796 ENDIF
61797
61798C..Start binary + linear search to find solution inside range.
61799 ITER=0
61800 ITMIN=0
61801 ITMAX=0
61802 PAI=0.5D0*(PAIMIN+PAIMAX)
61803 140 ITER=ITER+1
61804
61805C...Derive momentum of other two partons and distance to root.
61806 PEI=SQRT(PAI**2+PMI2)
61807 HI=PEI**2-0.25D0*PAI**2
61808 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
61809 PEJ=SQRT(PAJ**2+PMJ2)
61810 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
61811 PEK=SQRT(PAK**2+PMK2)
61812 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
61813
61814C...Pick next I momentum to explore, hopefully closer to root.
61815 IF(FNOW.GT.0D0) THEN
61816 PAIMIN=PAI
61817 FMIN=FNOW
61818 ITMIN=ITMIN+1
61819 ELSE
61820 PAIMAX=PAI
61821 FMAX=FNOW
61822 ITMAX=ITMAX+1
61823 ENDIF
61824 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
61825 & THEN
61826 PAI=0.5D0*(PAIMIN+PAIMAX)
61827 GOTO 140
61828 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
61829 & ABS(FNOW).GT.1D-12*PSUM2) THEN
61830 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
61831 GOTO 140
61832 ENDIF
61833 ENDIF
61834
61835C...Now know energies in junction rest frame.
61836 PENEW(I)=PEI
61837 PENEW(J)=PEJ
61838 PENEW(K)=PEK
61839
61840C...Boost (copy of) partons to their rest frame.
61841 VXCM=-PSUM(1)/PSUM(5)
61842 VYCM=-PSUM(2)/PSUM(5)
61843 VZCM=-PSUM(3)/PSUM(5)
61844 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
61845 DO 150 I=1,3
61846 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
61847 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
61848 PCM(I,1)=PJU(I,1)+FAC2*VXCM
61849 PCM(I,2)=PJU(I,2)+FAC2*VYCM
61850 PCM(I,3)=PJU(I,3)+FAC2*VZCM
61851 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
61852 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
61853 150 CONTINUE
61854
61855C...Construct difference vectors and boost to junction rest frame.
61856 DO 160 J=1,3
61857 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
61858 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
61859 160 CONTINUE
61860 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
61861 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
61862 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
61863 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
61864 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
61865 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
61866 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
61867 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
61868 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
61869 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
61870 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
61871
61872C...Add two boosts, giving final result.
61873 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
61874 VJU(1)=VXJU+FCM*VXCM
61875 VJU(2)=VYJU+FCM*VYCM
61876 VJU(3)=VZJU+FCM*VZCM
61877 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
61878 VJU(5)=1D0
61879
61880C...In case of error in reconstruction: revert to CM frame of system.
61881 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
61882 &(PCM(1,5)*PCM(2,5))
61883 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
61884 &(PCM(1,5)*PCM(3,5))
61885 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
61886 &(PCM(2,5)*PCM(3,5))
61887 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
61888 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
61889 DO 170 I=1,3
61890 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
61891 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
61892 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
61893 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
61894 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
61895 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
61896 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
61897 170 CONTINUE
61898 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
61899 &(PCM(1,5)*PCM(2,5))
61900 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
61901 &(PCM(1,5)*PCM(3,5))
61902 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
61903 &(PCM(2,5)*PCM(3,5))
61904 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
61905 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
61906 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
61907 VJU(1)=VXCM
61908 VJU(2)=VYCM
61909 VJU(3)=VZCM
61910 VJU(4)=GAMCM
61911 ENDIF
61912
61913 RETURN
61914 END
61915
61916C*********************************************************************
61917
61918C...PYINDF
61919C...Handles the fragmentation of a jet system (or a single
61920C...jet) according to independent fragmentation models.
61921
61922 SUBROUTINE PYINDF(IP)
61923
61924C...Double precision and integer declarations.
61925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61926 IMPLICIT INTEGER(I-N)
61927 INTEGER PYK,PYCHGE,PYCOMP
61928C...Commonblocks.
61929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61932 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61933C...Local arrays.
61934 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
61935 &KFLO(2),PXO(2),PYO(2),WO(2)
61936
61937C.. MOPS error message
61938 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
61939 &' are not treated as expected in independent fragmentation')
61940
61941C...Reset counters. Identify parton system and take copy. Check flavour.
61942 NSAV=N
61943 MSTU90=MSTU(90)
61944 NJET=0
61945 KQSUM=0
61946 DO 100 J=1,5
61947 DPS(J)=0D0
61948 100 CONTINUE
61949 I=IP-1
61950 110 I=I+1
61951 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61952 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
61953 IF(MSTU(21).GE.1) RETURN
61954 ENDIF
61955 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
61956 KC=PYCOMP(K(I,2))
61957 IF(KC.EQ.0) GOTO 110
61958 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61959 IF(KQ.EQ.0) GOTO 110
61960 NJET=NJET+1
61961 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61962 DO 120 J=1,5
61963 K(NSAV+NJET,J)=K(I,J)
61964 P(NSAV+NJET,J)=P(I,J)
61965 DPS(J)=DPS(J)+P(I,J)
61966 120 CONTINUE
61967 K(NSAV+NJET,3)=I
61968 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
61969 &K(I+1,1).EQ.2)) GOTO 110
61970 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
61971 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
61972 IF(MSTU(21).GE.1) RETURN
61973 ENDIF
61974
61975C...Boost copied system to CM frame. Find CM energy and sum flavours.
61976 IF(NJET.NE.1) THEN
61977 MSTU(33)=1
61978 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
61979 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
61980 ENDIF
61981 PECM=0D0
61982 DO 130 J=1,3
61983 NFI(J)=0
61984 130 CONTINUE
61985 DO 140 I=NSAV+1,NSAV+NJET
61986 PECM=PECM+P(I,4)
61987 KFA=IABS(K(I,2))
61988 IF(KFA.LE.3) THEN
61989 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
61990 ELSEIF(KFA.GT.1000) THEN
61991 KFLA=MOD(KFA/1000,10)
61992 KFLB=MOD(KFA/100,10)
61993 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
61994 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
61995 ENDIF
61996 140 CONTINUE
61997
61998C...Loop over attempts made. Reset counters.
61999 NTRY=0
62000 150 NTRY=NTRY+1
62001 IF(NTRY.GT.200) THEN
62002 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
62003 IF(MSTU(21).GE.1) RETURN
62004 ENDIF
62005 N=NSAV+NJET
62006 MSTU(90)=MSTU90
62007 DO 160 J=1,3
62008 NFL(J)=NFI(J)
62009 IFET(J)=0
62010 KFLF(J)=0
62011 160 CONTINUE
62012
62013C...Loop over jets to be fragmented.
62014 DO 230 IP1=NSAV+1,NSAV+NJET
62015 MSTJ(91)=0
62016 NSAV1=N
62017 MSTU91=MSTU(90)
62018
62019C...Initial flavour and momentum values. Jet along +z axis.
62020 KFLH=IABS(K(IP1,2))
62021 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
62022 KFLO(2)=0
62023 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
62024
62025C...Initial values for quark or diquark jet.
62026 170 IF(IABS(K(IP1,2)).NE.21) THEN
62027 NSTR=1
62028 KFLO(1)=K(IP1,2)
62029 CALL PYPTDI(0,PXO(1),PYO(1))
62030 WO(1)=WF
62031
62032C...Initial values for gluon treated like random quark jet.
62033 ELSEIF(MSTJ(2).LE.2) THEN
62034 NSTR=1
62035 IF(MSTJ(2).EQ.2) MSTJ(91)=1
62036 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62037 CALL PYPTDI(0,PXO(1),PYO(1))
62038 WO(1)=WF
62039
62040C...Initial values for gluon treated like quark-antiquark jet pair,
62041C...sharing energy according to Altarelli-Parisi splitting function.
62042 ELSE
62043 NSTR=2
62044 IF(MSTJ(2).EQ.4) MSTJ(91)=1
62045 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62046 KFLO(2)=-KFLO(1)
62047 CALL PYPTDI(0,PXO(1),PYO(1))
62048 PXO(2)=-PXO(1)
62049 PYO(2)=-PYO(1)
62050 WO(1)=WF*PYR(0)**(1D0/3D0)
62051 WO(2)=WF-WO(1)
62052 ENDIF
62053
62054C...Initial values for rank, flavour, pT and W+.
62055 DO 220 ISTR=1,NSTR
62056 180 I=N
62057 MSTU(90)=MSTU91
62058 IRANK=0
62059 KFL1=KFLO(ISTR)
62060 PX1=PXO(ISTR)
62061 PY1=PYO(ISTR)
62062 W=WO(ISTR)
62063
62064C...New hadron. Generate flavour and hadron species.
62065 190 I=I+1
62066 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
62067 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
62068 IF(MSTU(21).GE.1) RETURN
62069 ENDIF
62070 IRANK=IRANK+1
62071 K(I,1)=1
62072 K(I,3)=IP1
62073 K(I,4)=0
62074 K(I,5)=0
62075 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
62076 IF(K(I,2).EQ.0) GOTO 180
62077 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
62078 IF(PYR(0).GT.PARJ(19)) GOTO 200
62079 ENDIF
62080
62081C...Find hadron mass. Generate four-momentum.
62082 P(I,5)=PYMASS(K(I,2))
62083 CALL PYPTDI(KFL1,PX2,PY2)
62084 P(I,1)=PX1+PX2
62085 P(I,2)=PY1+PY2
62086 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
62087 CALL PYZDIS(KFL1,KFL2,PR,Z)
62088 MZSAV=0
62089 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
62090 MZSAV=1
62091 MSTU(90)=MSTU(90)+1
62092 MSTU(90+MSTU(90))=I
62093 PARU(90+MSTU(90))=Z
62094 ENDIF
62095 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
62096 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
62097 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
62098 & P(I,3).LE.0.001D0) THEN
62099 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
62100 P(I,3)=0.0001D0
62101 P(I,4)=SQRT(PR)
62102 Z=P(I,4)/W
62103 ENDIF
62104
62105C...Remaining flavour and momentum.
62106 KFL1=-KFL2
62107 PX1=-PX2
62108 PY1=-PY2
62109 W=(1D0-Z)*W
62110 DO 210 J=1,5
62111 V(I,J)=0D0
62112 210 CONTINUE
62113
62114C...Check if pL acceptable. Go back for new hadron if enough energy.
62115 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
62116 I=I-1
62117 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
62118 ENDIF
62119 IF(W.GT.PARJ(31)) GOTO 190
62120 N=I
62121 220 CONTINUE
62122 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
62123 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
62124
62125C...Rotate jet to new direction.
62126 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
62127 PHI=PYANGL(P(IP1,1),P(IP1,2))
62128 MSTU(33)=1
62129 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
62130 K(K(IP1,3),4)=NSAV1+1
62131 K(K(IP1,3),5)=N
62132
62133C...End of jet generation loop. Skip conservation in some cases.
62134 230 CONTINUE
62135 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
62136 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
62137
62138C...Subtract off produced hadron flavours, finished if zero.
62139 DO 240 I=NSAV+NJET+1,N
62140 KFA=IABS(K(I,2))
62141 KFLA=MOD(KFA/1000,10)
62142 KFLB=MOD(KFA/100,10)
62143 KFLC=MOD(KFA/10,10)
62144 IF(KFLA.EQ.0) THEN
62145 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
62146 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
62147 ELSE
62148 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
62149 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
62150 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
62151 ENDIF
62152 240 CONTINUE
62153 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
62154 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
62155 IF(NREQ.EQ.0) GOTO 320
62156
62157C...Take away flavour of low-momentum particles until enough freedom.
62158 NREM=0
62159 250 IREM=0
62160 P2MIN=PECM**2
62161 DO 260 I=NSAV+NJET+1,N
62162 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
62163 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
62164 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
62165 260 CONTINUE
62166 IF(IREM.EQ.0) GOTO 150
62167 K(IREM,1)=7
62168 KFA=IABS(K(IREM,2))
62169 KFLA=MOD(KFA/1000,10)
62170 KFLB=MOD(KFA/100,10)
62171 KFLC=MOD(KFA/10,10)
62172 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
62173 IF(K(IREM,1).EQ.8) GOTO 250
62174 IF(KFLA.EQ.0) THEN
62175 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
62176 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
62177 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
62178 ELSE
62179 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
62180 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
62181 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
62182 ENDIF
62183 NREM=NREM+1
62184 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
62185 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
62186 IF(NREQ.GT.NREM) GOTO 250
62187 DO 270 I=NSAV+NJET+1,N
62188 IF(K(I,1).EQ.8) K(I,1)=1
62189 270 CONTINUE
62190
62191C...Find combination of existing and new flavours for hadron.
62192 280 NFET=2
62193 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
62194 IF(NREQ.LT.NREM) NFET=1
62195 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
62196 DO 290 J=1,NFET
62197 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
62198 KFLF(J)=ISIGN(1,NFL(1))
62199 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
62200 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
62201 290 CONTINUE
62202 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
62203 &GOTO 280
62204 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
62205 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
62206 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
62207 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
62208 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
62209 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
62210 IF(NFET.LE.2) KFLF(3)=0
62211 IF(KFLF(3).NE.0) THEN
62212 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
62213 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
62214 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
62215 & KFLFC=KFLFC+ISIGN(2,KFLFC)
62216 ELSE
62217 KFLFC=KFLF(1)
62218 ENDIF
62219 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
62220 IF(KF.EQ.0) GOTO 280
62221 DO 300 J=1,MAX(2,NFET)
62222 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
62223 300 CONTINUE
62224
62225C...Store hadron at random among free positions.
62226 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
62227 DO 310 I=NSAV+NJET+1,N
62228 IF(K(I,1).EQ.7) NPOS=NPOS-1
62229 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
62230 K(I,1)=1
62231 K(I,2)=KF
62232 P(I,5)=PYMASS(K(I,2))
62233 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62234 310 CONTINUE
62235 NREM=NREM-1
62236 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
62237 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
62238 IF(NREM.GT.0) GOTO 280
62239
62240C...Compensate for missing momentum in global scheme (3 options).
62241 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
62242 DO 340 J=1,3
62243 PSI(J)=0D0
62244 DO 330 I=NSAV+NJET+1,N
62245 PSI(J)=PSI(J)+P(I,J)
62246 330 CONTINUE
62247 340 CONTINUE
62248 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
62249 PWS=0D0
62250 DO 350 I=NSAV+NJET+1,N
62251 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
62252 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
62253 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
62254 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
62255 350 CONTINUE
62256 DO 370 I=NSAV+NJET+1,N
62257 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
62258 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
62259 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
62260 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
62261 DO 360 J=1,3
62262 P(I,J)=P(I,J)-PSI(J)*PW/PWS
62263 360 CONTINUE
62264 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62265 370 CONTINUE
62266
62267C...Compensate for missing momentum withing each jet separately.
62268 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
62269 DO 390 I=N+1,N+NJET
62270 K(I,1)=0
62271 DO 380 J=1,5
62272 P(I,J)=0D0
62273 380 CONTINUE
62274 390 CONTINUE
62275 DO 410 I=NSAV+NJET+1,N
62276 IR1=K(I,3)
62277 IR2=N+IR1-NSAV
62278 K(IR2,1)=K(IR2,1)+1
62279 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
62280 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
62281 DO 400 J=1,3
62282 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
62283 400 CONTINUE
62284 P(IR2,4)=P(IR2,4)+P(I,4)
62285 P(IR2,5)=P(IR2,5)+PLS
62286 410 CONTINUE
62287 PSS=0D0
62288 DO 420 I=N+1,N+NJET
62289 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
62290 420 CONTINUE
62291 DO 440 I=NSAV+NJET+1,N
62292 IR1=K(I,3)
62293 IR2=N+IR1-NSAV
62294 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
62295 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
62296 DO 430 J=1,3
62297 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
62298 & PLS*P(IR1,J)
62299 430 CONTINUE
62300 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62301 440 CONTINUE
62302 ENDIF
62303
62304C...Scale momenta for energy conservation.
62305 IF(MOD(MSTJ(3),5).NE.0) THEN
62306 PMS=0D0
62307 PES=0D0
62308 PQS=0D0
62309 DO 450 I=NSAV+NJET+1,N
62310 PMS=PMS+P(I,5)
62311 PES=PES+P(I,4)
62312 PQS=PQS+P(I,5)**2/P(I,4)
62313 450 CONTINUE
62314 IF(PMS.GE.PECM) GOTO 150
62315 NECO=0
62316 460 NECO=NECO+1
62317 PFAC=(PECM-PQS)/(PES-PQS)
62318 PES=0D0
62319 PQS=0D0
62320 DO 480 I=NSAV+NJET+1,N
62321 DO 470 J=1,3
62322 P(I,J)=PFAC*P(I,J)
62323 470 CONTINUE
62324 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
62325 PES=PES+P(I,4)
62326 PQS=PQS+P(I,5)**2/P(I,4)
62327 480 CONTINUE
62328 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
62329 ENDIF
62330
62331C...Origin of produced particles and parton daughter pointers.
62332 490 DO 500 I=NSAV+NJET+1,N
62333 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
62334 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
62335 500 CONTINUE
62336 DO 510 I=NSAV+1,NSAV+NJET
62337 I1=K(I,3)
62338 K(I1,1)=K(I1,1)+10
62339 IF(MSTU(16).NE.2) THEN
62340 K(I1,4)=NSAV+1
62341 K(I1,5)=NSAV+1
62342 ELSE
62343 K(I1,4)=K(I1,4)-NJET+1
62344 K(I1,5)=K(I1,5)-NJET+1
62345 IF(K(I1,5).LT.K(I1,4)) THEN
62346 K(I1,4)=0
62347 K(I1,5)=0
62348 ENDIF
62349 ENDIF
62350 510 CONTINUE
62351
62352C...Document independent fragmentation system. Remove copy of jets.
62353 NSAV=NSAV+1
62354 K(NSAV,1)=11
62355 K(NSAV,2)=93
62356 K(NSAV,3)=IP
62357 K(NSAV,4)=NSAV+1
62358 K(NSAV,5)=N-NJET+1
62359 DO 520 J=1,4
62360 P(NSAV,J)=DPS(J)
62361 V(NSAV,J)=V(IP,J)
62362 520 CONTINUE
62363 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
62364 V(NSAV,5)=0D0
62365 DO 540 I=NSAV+NJET,N
62366 DO 530 J=1,5
62367 K(I-NJET+1,J)=K(I,J)
62368 P(I-NJET+1,J)=P(I,J)
62369 V(I-NJET+1,J)=V(I,J)
62370 530 CONTINUE
62371 540 CONTINUE
62372 N=N-NJET+1
62373 DO 550 IZ=MSTU90+1,MSTU(90)
62374 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
62375 550 CONTINUE
62376
62377C...Boost back particle system. Set production vertices.
62378 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
62379 &DPS(2)/DPS(4),DPS(3)/DPS(4))
62380 DO 570 I=NSAV+1,N
62381 DO 560 J=1,4
62382 V(I,J)=V(IP,J)
62383 560 CONTINUE
62384 570 CONTINUE
62385
62386 RETURN
62387 END
62388
62389C*********************************************************************
62390
62391C...PYDECY
62392C...Handles the decay of unstable particles.
62393
62394 SUBROUTINE PYDECY(IP)
62395
62396C...Double precision and integer declarations.
62397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62398 IMPLICIT INTEGER(I-N)
62399 INTEGER PYK,PYCHGE,PYCOMP
62400C...Commonblocks.
62401 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62404 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62405 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
62406C...Local arrays.
62407 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
62408 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
62409 CHARACTER CIDC*4
62410 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
62411
62412C...Functions: momentum in two-particle decays and four-product.
62413 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
62414 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)
62415
62416C...Initial values.
62417 NTRY=0
62418 NSAV=N
62419 KFA=IABS(K(IP,2))
62420 KFS=ISIGN(1,K(IP,2))
62421 KC=PYCOMP(KFA)
62422 MSTJ(92)=0
62423
62424C...Choose lifetime and determine decay vertex.
62425 IF(K(IP,1).EQ.5) THEN
62426 V(IP,5)=0D0
62427 ELSEIF(K(IP,1).NE.4) THEN
62428 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
62429 ENDIF
62430 DO 100 J=1,4
62431 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
62432 100 CONTINUE
62433
62434C...Determine whether decay allowed or not.
62435 MOUT=0
62436 IF(MSTJ(22).EQ.2) THEN
62437 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
62438 ELSEIF(MSTJ(22).EQ.3) THEN
62439 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
62440 ELSEIF(MSTJ(22).EQ.4) THEN
62441 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
62442 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
62443 ENDIF
62444 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
62445 K(IP,1)=4
62446 RETURN
62447 ENDIF
62448
62449C...Interface to external tau decay library (for tau polarization).
62450 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
62451
62452C...Starting values for pointers and momenta.
62453 ITAU=IP
62454 DO 110 J=1,4
62455 PTAU(J)=P(ITAU,J)
62456 PCMTAU(J)=P(ITAU,J)
62457 110 CONTINUE
62458
62459C...Iterate to find position and code of mother of tau.
62460 IMTAU=ITAU
62461 120 IMTAU=K(IMTAU,3)
62462
62463 IF(IMTAU.EQ.0) THEN
62464C...If no known origin then impossible to do anything further.
62465 KFORIG=0
62466 IORIG=0
62467
62468 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
62469C...If tau -> tau + gamma then add gamma energy and loop.
62470 IF(K(K(IMTAU,4),2).EQ.22) THEN
62471 DO 130 J=1,4
62472 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
62473 130 CONTINUE
62474 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
62475 DO 140 J=1,4
62476 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
62477 140 CONTINUE
62478 ENDIF
62479 GOTO 120
62480
62481 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
62482C...If coming from weak decay of hadron then W is not stored in record,
62483C...but can be reconstructed by adding neutrino momentum.
62484 KFORIG=-ISIGN(24,K(ITAU,2))
62485 IORIG=0
62486 DO 160 II=K(IMTAU,4),K(IMTAU,5)
62487 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
62488 DO 150 J=1,4
62489 PCMTAU(J)=PCMTAU(J)+P(II,J)
62490 150 CONTINUE
62491 ENDIF
62492 160 CONTINUE
62493
62494 ELSE
62495C...If coming from resonance decay then find latest copy of this
62496C...resonance (may not completely agree).
62497 KFORIG=K(IMTAU,2)
62498 IORIG=IMTAU
62499 DO 170 II=IMTAU+1,IP-1
62500 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
62501 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
62502 170 CONTINUE
62503 DO 180 J=1,4
62504 PCMTAU(J)=P(IORIG,J)
62505 180 CONTINUE
62506 ENDIF
62507
62508C...Boost tau to rest frame of production process (where known)
62509C...and rotate it to sit along +z axis.
62510 DO 190 J=1,3
62511 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
62512 190 CONTINUE
62513 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
62514 & -DBETAU(2),-DBETAU(3))
62515 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
62516 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
62517 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
62518 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
62519
62520C...Call tau decay routine (if meaningful) and fill extra info.
62521 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
62522 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
62523 DO 200 II=NSAV+1,NSAV+NDECAY
62524 K(II,1)=1
62525 K(II,3)=IP
62526 K(II,4)=0
62527 K(II,5)=0
62528 200 CONTINUE
62529 N=NSAV+NDECAY
62530 ENDIF
62531
62532C...Boost back decay tau and decay products.
62533 DO 210 J=1,4
62534 P(ITAU,J)=PTAU(J)
62535 210 CONTINUE
62536 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
62537 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
62538 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
62539 & DBETAU(2),DBETAU(3))
62540
62541C...Skip past ordinary tau decay treatment.
62542 MMAT=0
62543 MBST=0
62544 ND=0
62545 GOTO 630
62546 ENDIF
62547 ENDIF
62548
62549C...B-Bbar mixing: flip sign of meson appropriately.
62550 MMIX=0
62551 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
62552 XBBMIX=PARJ(76)
62553 IF(KFA.EQ.531) XBBMIX=PARJ(77)
62554 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
62555 IF(MMIX.EQ.1) KFS=-KFS
62556 ENDIF
62557
62558C...Check existence of decay channels. Particle/antiparticle rules.
62559 KCA=KC
62560 IF(MDCY(KC,2).GT.0) THEN
62561 MDMDCY=MDME(MDCY(KC,2),2)
62562 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
62563 ENDIF
62564 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
62565 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
62566 RETURN
62567 ENDIF
62568 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
62569 IF(KCHG(KC,3).EQ.0) THEN
62570 KFSP=1
62571 KFSN=0
62572 IF(PYR(0).GT.0.5D0) KFS=-KFS
62573 ELSEIF(KFS.GT.0) THEN
62574 KFSP=1
62575 KFSN=0
62576 ELSE
62577 KFSP=0
62578 KFSN=1
62579 ENDIF
62580
62581C...Sum branching ratios of allowed decay channels.
62582 220 NOPE=0
62583 BRSU=0D0
62584 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
62585 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
62586 & KFSN*MDME(IDL,1).NE.3) GOTO 230
62587 IF(MDME(IDL,2).GT.100) GOTO 230
62588 NOPE=NOPE+1
62589 BRSU=BRSU+BRAT(IDL)
62590 230 CONTINUE
62591 IF(NOPE.EQ.0) THEN
62592 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
62593 RETURN
62594 ENDIF
62595
62596C...Select decay channel among allowed ones.
62597 240 RBR=BRSU*PYR(0)
62598 IDL=MDCY(KCA,2)-1
62599 250 IDL=IDL+1
62600 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
62601 &KFSN*MDME(IDL,1).NE.3) THEN
62602 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
62603 ELSEIF(MDME(IDL,2).GT.100) THEN
62604 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
62605 ELSE
62606 IDC=IDL
62607 RBR=RBR-BRAT(IDL)
62608 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
62609 ENDIF
62610
62611C...Start readout of decay channel: matrix element, reset counters.
62612 MMAT=MDME(IDC,2)
62613 260 NTRY=NTRY+1
62614 IF(MOD(NTRY,200).EQ.0) THEN
62615 WRITE(CIDC,'(I4)') IDC
62616C...Do not print warning for some well-known special cases.
62617 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
62618 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
62619 & CIDC)
62620 GOTO 240
62621 ENDIF
62622 IF(NTRY.GT.1000) THEN
62623 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
62624 IF(MSTU(21).GE.1) RETURN
62625 ENDIF
62626 I=N
62627 NP=0
62628 NQ=0
62629 MBST=0
62630 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
62631 DO 270 J=1,4
62632 PV(1,J)=0D0
62633 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
62634 270 CONTINUE
62635 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
62636 PV(1,5)=P(IP,5)
62637 PS=0D0
62638 PSQ=0D0
62639 MREM=0
62640 MHADDY=0
62641 IF(KFA.GT.80) MHADDY=1
62642C.. Random flavour and popcorn system memory.
62643 IRNDMO=0
62644 JTMO=0
62645 MSTU(121)=0
62646 MSTU(125)=10
62647
62648C...Read out decay products. Convert to standard flavour code.
62649 JTMAX=5
62650 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
62651 DO 280 JT=1,JTMAX
62652 IF(JT.LE.5) KP=KFDP(IDC,JT)
62653 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
62654 IF(KP.EQ.0) GOTO 280
62655 KPA=IABS(KP)
62656 KCP=PYCOMP(KPA)
62657 IF(KPA.GT.80) MHADDY=1
62658 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
62659 KFP=KP
62660 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
62661 KFP=KFS*KP
62662 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
62663 KFP=-KFS*MOD(KFA/10,10)
62664 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
62665 KFP=KFS*(100*MOD(KFA/10,100)+3)
62666 ELSEIF(KPA.EQ.81) THEN
62667 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
62668 ELSEIF(KP.EQ.82) THEN
62669 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
62670 IF(KFP.EQ.0) GOTO 260
62671 KFP=-KFP
62672 IRNDMO=1
62673 MSTJ(93)=1
62674 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
62675 ELSEIF(KP.EQ.-82) THEN
62676 KFP=MSTU(124)
62677 ENDIF
62678 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
62679
62680C...Add decay product to event record or to quark flavour list.
62681 KFPA=IABS(KFP)
62682 KQP=KCHG(KCP,2)
62683 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
62684 NQ=NQ+1
62685 KFLO(NQ)=KFP
62686C...set rndmflav popcorn system pointer
62687 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
62688 MSTJ(93)=2
62689 PSQ=PSQ+PYMASS(KFLO(NQ))
62690 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
62691 & MOD(NQ,2).EQ.1) THEN
62692 NQ=NQ-1
62693 PS=PS-P(I,5)
62694 K(I,1)=1
62695 KFI=K(I,2)
62696 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
62697 IF(K(I,2).EQ.0) GOTO 260
62698 MSTJ(93)=1
62699 P(I,5)=PYMASS(K(I,2))
62700 PS=PS+P(I,5)
62701 ELSE
62702 I=I+1
62703 NP=NP+1
62704 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
62705 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
62706 K(I,1)=1+MOD(NQ,2)
62707 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
62708 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
62709 K(I,2)=KFP
62710 K(I,3)=IP
62711 K(I,4)=0
62712 K(I,5)=0
62713 P(I,5)=PYMASS(KFP)
62714 PS=PS+P(I,5)
62715 ENDIF
62716 280 CONTINUE
62717
62718C...Check masses for resonance decays.
62719 IF(MHADDY.EQ.0) THEN
62720 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
62721 ENDIF
62722
62723C...Choose decay multiplicity in phase space model.
62724 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
62725 PSP=PS
62726 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
62727 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
62728 300 NTRY=NTRY+1
62729C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
62730 IF(IRNDMO.EQ.0) THEN
62731 MSTU(121)=0
62732 JTMO=0
62733 ELSEIF(IRNDMO.EQ.1) THEN
62734 IRNDMO=2
62735 ELSE
62736 GOTO 260
62737 ENDIF
62738 IF(NTRY.GT.1000) THEN
62739 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
62740 IF(MSTU(21).GE.1) RETURN
62741 ENDIF
62742 IF(MMAT.LE.20) THEN
62743 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
62744 & SIN(PARU(2)*PYR(0))
62745 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
62746 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
62747 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
62748 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
62749 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
62750 ELSE
62751 ND=MMAT-20
62752 ENDIF
62753C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
62754 MSTU(125)=ND-NQ/2
62755 IF(MSTU(121).GT.MSTU(125)) GOTO 300
62756
62757C...Form hadrons from flavour content.
62758 DO 310 JT=1,NQ
62759 KFL1(JT)=KFLO(JT)
62760 310 CONTINUE
62761 IF(ND.EQ.NP+NQ/2) GOTO 330
62762 DO 320 I=N+NP+1,N+ND-NQ/2
62763C.. Stick to started popcorn system, else pick side at random
62764 JT=JTMO
62765 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
62766 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
62767 IF(K(I,2).EQ.0) GOTO 300
62768 MSTU(125)=MSTU(125)-1
62769 JTMO=0
62770 IF(MSTU(121).GT.0) JTMO=JT
62771 KFL1(JT)=-KFL2
62772 320 CONTINUE
62773 330 JT=2
62774 JT2=3
62775 JT3=4
62776 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
62777 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
62778 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
62779 IF(JT.EQ.3) JT2=2
62780 IF(JT.EQ.4) JT3=2
62781 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
62782 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
62783 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
62784 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
62785
62786C...Check that sum of decay product masses not too large.
62787 PS=PSP
62788 DO 340 I=N+NP+1,N+ND
62789 K(I,1)=1
62790 K(I,3)=IP
62791 K(I,4)=0
62792 K(I,5)=0
62793 P(I,5)=PYMASS(K(I,2))
62794 PS=PS+P(I,5)
62795 340 CONTINUE
62796 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
62797
62798C...Rescale energy to subtract off spectator quark mass.
62799 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
62800 & .AND.NP.GE.3) THEN
62801 PS=PS-P(N+NP,5)
62802 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
62803 DO 350 J=1,5
62804 P(N+NP,J)=PQT*PV(1,J)
62805 PV(1,J)=(1D0-PQT)*PV(1,J)
62806 350 CONTINUE
62807 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
62808 ND=NP-1
62809 MREM=1
62810
62811C...Fully specified final state: check mass broadening effects.
62812 ELSE
62813 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
62814 ND=NP
62815 ENDIF
62816
62817C...Determine position of grandmother, number of sisters.
62818 NM=0
62819 KFAS=0
62820 MSGN=0
62821 IF(MMAT.EQ.3) THEN
62822 IM=K(IP,3)
62823 IF(IM.LT.0.OR.IM.GE.IP) IM=0
62824 IF(IM.NE.0) KFAM=IABS(K(IM,2))
62825 IF(IM.NE.0) THEN
62826 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
62827 IF(K(IL,3).EQ.IM) NM=NM+1
62828 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
62829 360 CONTINUE
62830 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
62831 & MOD(KFAM/1000,10).NE.0) NM=0
62832 IF(NM.EQ.2) THEN
62833 KFAS=IABS(K(ISIS,2))
62834 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
62835 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
62836 ENDIF
62837 ENDIF
62838 ENDIF
62839
62840C...Kinematics of one-particle decays.
62841 IF(ND.EQ.1) THEN
62842 DO 370 J=1,4
62843 P(N+1,J)=P(IP,J)
62844 370 CONTINUE
62845 GOTO 630
62846 ENDIF
62847
62848C...Calculate maximum weight ND-particle decay.
62849 PV(ND,5)=P(N+ND,5)
62850 IF(ND.GE.3) THEN
62851 WTMAX=1D0/WTCOR(ND-2)
62852 PMAX=PV(1,5)-PS+P(N+ND,5)
62853 PMIN=0D0
62854 DO 380 IL=ND-1,1,-1
62855 PMAX=PMAX+P(N+IL,5)
62856 PMIN=PMIN+P(N+IL+1,5)
62857 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
62858 380 CONTINUE
62859 ENDIF
62860
62861C...Find virtual gamma mass in Dalitz decay.
62862 390 IF(ND.EQ.2) THEN
62863 ELSEIF(MMAT.EQ.2) THEN
62864 PMES=4D0*PMAS(11,1)**2
62865 PMRHO2=PMAS(131,1)**2
62866 PGRHO2=PMAS(131,2)**2
62867 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
62868 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
62869 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
62870 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
62871 IF(WT.LT.PYR(0)) GOTO 400
62872 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
62873
62874C...M-generator gives weight. If rejected, try again.
62875 ELSE
62876 410 RORD(1)=1D0
62877 DO 440 IL1=2,ND-1
62878 RSAV=PYR(0)
62879 DO 420 IL2=IL1-1,1,-1
62880 IF(RSAV.LE.RORD(IL2)) GOTO 430
62881 RORD(IL2+1)=RORD(IL2)
62882 420 CONTINUE
62883 430 RORD(IL2+1)=RSAV
62884 440 CONTINUE
62885 RORD(ND)=0D0
62886 WT=1D0
62887 DO 450 IL=ND-1,1,-1
62888 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
62889 & (PV(1,5)-PS)
62890 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
62891 450 CONTINUE
62892 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
62893 ENDIF
62894
62895C...Perform two-particle decays in respective CM frame.
62896 460 DO 480 IL=1,ND-1
62897 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
62898 UE(3)=2D0*PYR(0)-1D0
62899 PHI=PARU(2)*PYR(0)
62900 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
62901 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
62902 DO 470 J=1,3
62903 P(N+IL,J)=PA*UE(J)
62904 PV(IL+1,J)=-PA*UE(J)
62905 470 CONTINUE
62906 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
62907 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
62908 480 CONTINUE
62909
62910C...Lorentz transform decay products to lab frame.
62911 DO 490 J=1,4
62912 P(N+ND,J)=PV(ND,J)
62913 490 CONTINUE
62914 DO 530 IL=ND-1,1,-1
62915 DO 500 J=1,3
62916 BE(J)=PV(IL,J)/PV(IL,4)
62917 500 CONTINUE
62918 GA=PV(IL,4)/PV(IL,5)
62919 DO 520 I=N+IL,N+ND
62920 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
62921 DO 510 J=1,3
62922 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
62923 510 CONTINUE
62924 P(I,4)=GA*(P(I,4)+BEP)
62925 520 CONTINUE
62926 530 CONTINUE
62927
62928C...Check that no infinite loop in matrix element weight.
62929 NTRY=NTRY+1
62930 IF(NTRY.GT.800) GOTO 560
62931
62932C...Matrix elements for omega and phi decays.
62933 IF(MMAT.EQ.1) THEN
62934 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
62935 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
62936 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
62937 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
62938
62939C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
62940 ELSEIF(MMAT.EQ.2) THEN
62941 FOUR12=FOUR(N+1,N+2)
62942 FOUR13=FOUR(N+1,N+3)
62943 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
62944 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
62945 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
62946
62947C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
62948C...V vector), of form cos**2(theta02) in V1 rest frame, and for
62949C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
62950 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
62951 FOUR10=FOUR(IP,IM)
62952 FOUR12=FOUR(IP,N+1)
62953 FOUR02=FOUR(IM,N+1)
62954 PMS1=P(IP,5)**2
62955 PMS0=P(IM,5)**2
62956 PMS2=P(N+1,5)**2
62957 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
62958 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
62959 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
62960 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
62961 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
62962 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
62963
62964C...Matrix element for "onium" -> g + g + g or gamma + g + g.
62965 ELSEIF(MMAT.EQ.4) THEN
62966 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
62967 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
62968 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
62969 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
62970 & ((1D0-HX3)/(HX1*HX2))**2
62971 IF(WT.LT.2D0*PYR(0)) GOTO 390
62972 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
62973 & GOTO 390
62974
62975C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
62976 ELSEIF(MMAT.EQ.41) THEN
62977 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
62978 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
62979 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
62980 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
62981
62982C...Matrix elements for weak decays (only semileptonic for c and b)
62983 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
62984 & .AND.ND.EQ.3) THEN
62985 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
62986 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
62987 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
62988 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
62989 DO 550 J=1,4
62990 P(N+NP+1,J)=0D0
62991 DO 540 IS=N+3,N+NP
62992 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
62993 540 CONTINUE
62994 550 CONTINUE
62995 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
62996 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
62997 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
62998 ENDIF
62999
63000C...Scale back energy and reattach spectator.
63001 560 IF(MREM.EQ.1) THEN
63002 DO 570 J=1,5
63003 PV(1,J)=PV(1,J)/(1D0-PQT)
63004 570 CONTINUE
63005 ND=ND+1
63006 MREM=0
63007 ENDIF
63008
63009C...Low invariant mass for system with spectator quark gives particle,
63010C...not two jets. Readjust momenta accordingly.
63011 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
63012 MSTJ(93)=1
63013 PM2=PYMASS(K(N+2,2))
63014 MSTJ(93)=1
63015 PM3=PYMASS(K(N+3,2))
63016 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
63017 & (PARJ(32)+PM2+PM3)**2) GOTO 630
63018 K(N+2,1)=1
63019 KFTEMP=K(N+2,2)
63020 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
63021 IF(K(N+2,2).EQ.0) GOTO 260
63022 P(N+2,5)=PYMASS(K(N+2,2))
63023 PS=P(N+1,5)+P(N+2,5)
63024 PV(2,5)=P(N+2,5)
63025 MMAT=0
63026 ND=2
63027 GOTO 460
63028 ELSEIF(MMAT.EQ.44) THEN
63029 MSTJ(93)=1
63030 PM3=PYMASS(K(N+3,2))
63031 MSTJ(93)=1
63032 PM4=PYMASS(K(N+4,2))
63033 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
63034 & (PARJ(32)+PM3+PM4)**2) GOTO 600
63035 K(N+3,1)=1
63036 KFTEMP=K(N+3,2)
63037 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
63038 IF(K(N+3,2).EQ.0) GOTO 260
63039 P(N+3,5)=PYMASS(K(N+3,2))
63040 DO 580 J=1,3
63041 P(N+3,J)=P(N+3,J)+P(N+4,J)
63042 580 CONTINUE
63043 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)
63044 HA=P(N+1,4)**2-P(N+2,4)**2
63045 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
63046 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
63047 & (P(N+1,3)-P(N+2,3))**2
63048 HD=(PV(1,4)-P(N+3,4))**2
63049 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
63050 HF=HD*HC-HB**2
63051 HG=HD*HC-HA*HB
63052 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
63053 DO 590 J=1,3
63054 PCOR=HH*(P(N+1,J)-P(N+2,J))
63055 P(N+1,J)=P(N+1,J)+PCOR
63056 P(N+2,J)=P(N+2,J)-PCOR
63057 590 CONTINUE
63058 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)
63059 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)
63060 ND=ND-1
63061 ENDIF
63062
63063C...Check invariant mass of W jets. May give one particle or start over.
63064 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
63065 &.AND.IABS(K(N+1,2)).LT.10) THEN
63066 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
63067 MSTJ(93)=1
63068 PM1=PYMASS(K(N+1,2))
63069 MSTJ(93)=1
63070 PM2=PYMASS(K(N+2,2))
63071 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
63072 KFLDUM=INT(1.5D0+PYR(0))
63073 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
63074 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
63075 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
63076 PSM=PYMASS(KF1)+PYMASS(KF2)
63077 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
63078 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
63079 IF(MMAT.EQ.48) GOTO 390
63080 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
63081 K(N+1,1)=1
63082 KFTEMP=K(N+1,2)
63083 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
63084 IF(K(N+1,2).EQ.0) GOTO 260
63085 P(N+1,5)=PYMASS(K(N+1,2))
63086 K(N+2,2)=K(N+3,2)
63087 P(N+2,5)=P(N+3,5)
63088 PS=P(N+1,5)+P(N+2,5)
63089 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
63090 PV(2,5)=P(N+3,5)
63091 MMAT=0
63092 ND=2
63093 GOTO 460
63094 ENDIF
63095
63096C...Phase space decay of partons from W decay.
63097 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
63098 KFLO(1)=K(N+1,2)
63099 KFLO(2)=K(N+2,2)
63100 K(N+1,1)=K(N+3,1)
63101 K(N+1,2)=K(N+3,2)
63102 DO 620 J=1,5
63103 PV(1,J)=P(N+1,J)+P(N+2,J)
63104 P(N+1,J)=P(N+3,J)
63105 620 CONTINUE
63106 PV(1,5)=PMR
63107 N=N+1
63108 NP=0
63109 NQ=2
63110 PS=0D0
63111 MSTJ(93)=2
63112 PSQ=PYMASS(KFLO(1))
63113 MSTJ(93)=2
63114 PSQ=PSQ+PYMASS(KFLO(2))
63115 MMAT=11
63116 GOTO 290
63117 ENDIF
63118
63119C...Boost back for rapidly moving particle.
63120 630 N=N+ND
63121 IF(MBST.EQ.1) THEN
63122 DO 640 J=1,3
63123 BE(J)=P(IP,J)/P(IP,4)
63124 640 CONTINUE
63125 GA=P(IP,4)/P(IP,5)
63126 DO 660 I=NSAV+1,N
63127 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
63128 DO 650 J=1,3
63129 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
63130 650 CONTINUE
63131 P(I,4)=GA*(P(I,4)+BEP)
63132 660 CONTINUE
63133 ENDIF
63134
63135C...Fill in position of decay vertex.
63136 DO 680 I=NSAV+1,N
63137 DO 670 J=1,4
63138 V(I,J)=VDCY(J)
63139 670 CONTINUE
63140 V(I,5)=0D0
63141 680 CONTINUE
63142
63143C...Set up for parton shower evolution from jets.
63144 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
63145 K(NSAV+1,1)=3
63146 K(NSAV+2,1)=3
63147 K(NSAV+3,1)=3
63148 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
63149 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
63150 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
63151 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
63152 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
63153 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
63154 MSTJ(92)=-(NSAV+1)
63155 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
63156 K(NSAV+2,1)=3
63157 K(NSAV+3,1)=3
63158 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
63159 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
63160 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
63161 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
63162 MSTJ(92)=NSAV+2
63163 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
63164 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
63165 K(NSAV+1,1)=3
63166 K(NSAV+2,1)=3
63167 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
63168 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
63169 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
63170 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
63171 MSTJ(92)=NSAV+1
63172 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
63173 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
63174 MSTJ(92)=NSAV+1
63175 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
63176 & THEN
63177 K(NSAV+1,1)=3
63178 K(NSAV+2,1)=3
63179 K(NSAV+3,1)=3
63180 KCP=PYCOMP(K(NSAV+1,2))
63181 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
63182 JCON=4
63183 IF(KQP.LT.0) JCON=5
63184 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
63185 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
63186 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
63187 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
63188 MSTJ(92)=NSAV+1
63189 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
63190 K(NSAV+1,1)=3
63191 K(NSAV+3,1)=3
63192 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
63193 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
63194 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
63195 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
63196 MSTJ(92)=NSAV+1
63197 ENDIF
63198
63199C...Mark decayed particle; special option for B-Bbar mixing.
63200 IF(K(IP,1).EQ.5) K(IP,1)=15
63201 IF(K(IP,1).LE.10) K(IP,1)=11
63202 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
63203 K(IP,4)=NSAV+1
63204 K(IP,5)=N
63205
63206 RETURN
63207 END
63208
63209
63210C*********************************************************************
63211
63212C...PYDCYK
63213C...Handles flavour production in the decay of unstable particles
63214C...and small string clusters.
63215
63216 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
63217
63218C...Double precision and integer declarations.
63219 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63220 IMPLICIT INTEGER(I-N)
63221 INTEGER PYK,PYCHGE,PYCOMP
63222C...Commonblocks.
63223 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63224 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63225 SAVE /PYDAT1/,/PYDAT2/
63226
63227
63228C.. Call PYKFDI directly if no popcorn option is on
63229 IF(MSTJ(12).LT.2) THEN
63230 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
63231 MSTU(124)=KFL3
63232 RETURN
63233 ENDIF
63234
63235 KFL3=0
63236 KF=0
63237 IF(KFL1.EQ.0) RETURN
63238 KF1A=IABS(KFL1)
63239 KF2A=IABS(KFL2)
63240
63241 NSTO=130
63242 NMAX=MIN(MSTU(125),10)
63243
63244C.. Identify rank 0 cluster qq
63245 IRANK=1
63246 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
63247
63248 IF(KF2A.GT.0)THEN
63249C.. Join jets: Fails if store not empty
63250 IF(MSTU(121).GT.0) THEN
63251 MSTU(121)=0
63252 RETURN
63253 ENDIF
63254 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
63255 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
63256C.. Pick popcorn meson from store, return same qq, decrease store
63257 KF=MSTU(NSTO+MSTU(121))
63258 KFL3=-KFL1
63259 MSTU(121)=MSTU(121)-1
63260 ELSE
63261C.. Generate new flavour. Then done if no diquark is generated
63262 100 CALL PYKFDI(KFL1,0,KFL3,KF)
63263 IF(MSTU(121).EQ.-1) GOTO 100
63264 MSTU(124)=KFL3
63265 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
63266
63267C.. Simple case if no dynamical popcorn suppressions are considered
63268 IF(MSTJ(12).LT.4) THEN
63269 IF(MSTU(121).EQ.0) RETURN
63270 NMES=1
63271 KFPREV=-KFL3
63272 CALL PYKFDI(KFPREV,0,KFL3,KFM)
63273C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
63274 IF(IABS(KFL3).LE.10)THEN
63275 KFL3=-KFPREV
63276 RETURN
63277 ENDIF
63278 GOTO 120
63279 ENDIF
63280
63281C test output qq against fake Gamma, then return if no popcorn.
63282 GB=2D0
63283 IF(IRANK.NE.0)THEN
63284 CALL PYZDIS(1,2103,5D0,Z)
63285 GB=5D0*(1D0-Z)/Z
63286 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
63287 MSTU(121)=0
63288 GOTO 100
63289 ENDIF
63290 ENDIF
63291 IF(MSTU(121).EQ.0) RETURN
63292
63293C..Set store size memory. Pick fake dynamical variables of qq.
63294 NMES=MSTU(121)
63295 CALL PYPTDI(1,PX3,PY3)
63296 X=1D0
63297 POPM=0D0
63298 G=GB
63299 POPG=GB
63300
63301C.. Pick next popcorn meson, test with fake dynamical variables
63302 110 KFPREV=-KFL3
63303 PX1=-PX3
63304 PY1=-PY3
63305 CALL PYKFDI(KFPREV,0,KFL3,KFM)
63306 IF(MSTU(121).EQ.-1) GOTO 100
63307 CALL PYPTDI(KFL3,PX3,PY3)
63308 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
63309 CALL PYZDIS(KFPREV,KFL3,PM,Z)
63310 G=(1D0-Z)*(G+PM/Z)
63311 X=(1D0-Z)*X
63312
63313 PTST=1D0
63314 GTST=1D0
63315 RTST=PYR(0)
63316 IF(MSTJ(12).GT.4)THEN
63317 POPMN=SQRT((1D0-X)*(G/X-GB))
63318 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
63319 PTST=EXP((POPM-POPMN)*PARF(193))
63320 POPM=POPMN
63321 ENDIF
63322 IF(IRANK.NE.0)THEN
63323 POPGN=X*GB
63324 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
63325 POPG=POPGN
63326 ENDIF
63327 IF(RTST.GT.PTST*GTST)THEN
63328 MSTU(121)=0
63329 IF(RTST.GT.PTST) MSTU(121)=-1
63330 GOTO 100
63331 ENDIF
63332
63333C.. Store meson
63334 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
63335 IF(MSTU(121).GT.0) GOTO 110
63336
63337C.. Test accepted system size. If OK set global popcorn size variable.
63338 IF(NMES.GT.NMAX)THEN
63339 KF=0
63340 KFL3=0
63341 RETURN
63342 ENDIF
63343 MSTU(121)=NMES
63344 ENDIF
63345
63346 RETURN
63347 END
63348
63349C********************************************************************
63350
63351C...PYKFDI
63352C...Generates a new flavour pair and combines off a hadron
63353
63354 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
63355
63356C...Double precision and integer declarations.
63357 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63358 IMPLICIT INTEGER(I-N)
63359 INTEGER PYK,PYCHGE,PYCOMP
63360C...Commonblocks.
63361 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63362 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63363 SAVE /PYDAT1/,/PYDAT2/
63364C...Local arrays.
63365 DIMENSION PD(7)
63366
63367 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
63368
63369C...Default flavour values. Input consistency checks.
63370 KF1A=IABS(KFL1)
63371 KF2A=IABS(KFL2)
63372 KFL3=0
63373 KF=0
63374 IF(KF1A.EQ.0) RETURN
63375 IF(KF2A.NE.0)THEN
63376 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
63377 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
63378 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
63379 ENDIF
63380
63381C...Check if tabulated flavour probabilities are to be used.
63382 IF(MSTJ(15).EQ.1) THEN
63383 IF(MSTJ(12).GE.5) CALL PYERRM(29,
63384 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
63385 & ' together with MSTJ(12)>=5 modification')
63386 KTAB1=-1
63387 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
63388 KFL1A=MOD(KF1A/1000,10)
63389 KFL1B=MOD(KF1A/100,10)
63390 KFL1S=MOD(KF1A,10)
63391 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
63392 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
63393 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
63394 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
63395 KTAB2=0
63396 IF(KF2A.NE.0) THEN
63397 KTAB2=-1
63398 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
63399 KFL2A=MOD(KF2A/1000,10)
63400 KFL2B=MOD(KF2A/100,10)
63401 KFL2S=MOD(KF2A,10)
63402 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
63403 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
63404 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
63405 ENDIF
63406 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
63407 ENDIF
63408
63409C.. Recognize rank 0 diquark case
63410 100 IRANK=1
63411 KFDIQ=MAX(KF1A,KF2A)
63412 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
63413
63414C.. Join two flavours to meson or baryon. Test for popcorn.
63415 IF(KF2A.GT.0)THEN
63416 MBARY=0
63417 IF(KFDIQ.GT.10) THEN
63418 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
63419 & CALL PYNMES(KFDIQ)
63420 IF(MSTU(121).NE.0) THEN
63421 MSTU(121)=0
63422 RETURN
63423 ENDIF
63424 MBARY=2
63425 ENDIF
63426 KFQOLD=KF1A
63427 KFQVER=KF2A
63428 GOTO 130
63429 ENDIF
63430
63431C.. Separate incoming flavours, curtain flavour consistency check
63432 KFIN=KFL1
63433 KFQOLD=KF1A
63434 KFQPOP=KF1A/10000
63435 IF(KF1A.GT.10)THEN
63436 KFIN=-KFL1
63437 KFL1A=MOD(KF1A/1000,10)
63438 KFL1B=MOD(KF1A/100,10)
63439 IF(IRANK.EQ.0)THEN
63440 QAWT=1D0
63441 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
63442 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
63443 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
63444 ENDIF
63445 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
63446 MSTU(121)=0
63447 RETURN
63448 ENDIF
63449 KFQOLD=KFL1A+KFL1B-KFQPOP
63450 ENDIF
63451
63452C...Meson/baryon choice. Set number of mesons if starting a popcorn
63453C...system.
63454 110 MBARY=0
63455 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
63456 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
63457 MBARY=1
63458 CALL PYNMES(0)
63459 ENDIF
63460 ELSEIF(KF1A.GT.10)THEN
63461 MBARY=2
63462 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
63463 IF(MSTU(121).GT.0) MBARY=-1
63464 ENDIF
63465
63466C..x->H+q: Choose single vertex quark. Jump to form hadron.
63467 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
63468 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
63469 KFL3=ISIGN(KFQVER,-KFIN)
63470 GOTO 130
63471 ENDIF
63472
63473C..x->H+qq: (IDW=proper PARF position for diquark weights)
63474 IDW=160
63475 IF(MBARY.EQ.1)THEN
63476 IF(MSTU(121).EQ.0) IDW=150
63477 SQWT=PARF(IDW+1)
63478 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
63479 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
63480C.. Shift to s-curtain parameters if needed
63481 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
63482 PARF(194)=PARF(138)*PARF(139)
63483 PARF(193)=PARJ(8)+PARJ(9)
63484 ENDIF
63485 ENDIF
63486
63487C.. x->H+qq: Get vertex quark
63488 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
63489 IDW=MSTU(122)
63490 MSTU(121)=MSTU(121)-1
63491 IF(IDW.EQ.170) THEN
63492 IF(MSTU(121).EQ.0)THEN
63493 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
63494 ELSE
63495 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
63496 ENDIF
63497 ELSE
63498 IF(MSTU(121).EQ.0)THEN
63499 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
63500 ELSE
63501 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
63502 ENDIF
63503 ENDIF
63504 IPOS=200+30*IPOS+1
63505
63506 IMES=-1
63507 RMES=PYR(0)*PARF(194)
63508 120 IMES=IMES+1
63509 RMES=RMES-PARF(IPOS+IMES)
63510 IF(IMES.EQ.30) THEN
63511 MSTU(121)=-1
63512 KF=-111
63513 RETURN
63514 ENDIF
63515 IF(RMES.GT.0D0) GOTO 120
63516 KMUL=IMES/5
63517 KFJ=2*KMUL+1
63518 IF(KMUL.EQ.2) KFJ=10003
63519 IF(KMUL.EQ.3) KFJ=10001
63520 IF(KMUL.EQ.4) KFJ=20003
63521 IF(KMUL.EQ.5) KFJ=5
63522 IDIAG=0
63523 KFQVER=MOD(IMES,5)+1
63524 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
63525 IF(KFQVER.GT.3)THEN
63526 IDIAG=KFQVER-3
63527 KFQVER=KFQOLD
63528 ENDIF
63529 ELSE
63530 IF(MBARY.EQ.-1) IDW=170
63531 SQWT=PARF(IDW+2)
63532 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
63533 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
63534 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
63535 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
63536 KFQVER=KFQPOP
63537 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
63538 ENDIF
63539 ENDIF
63540
63541C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
63542 KFLDS=3
63543 IF(KFQPOP.NE.KFQVER)THEN
63544 SWT=PARF(IDW+7)
63545 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
63546 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
63547 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
63548 ENDIF
63549 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
63550 & +10000*KFQPOP
63551 KFL3=ISIGN(KFDIQ,KFIN)
63552
63553C..x->M+y: flavour for meson.
63554 130 IF(MBARY.LE.0)THEN
63555 KFLA=MAX(KFQOLD,KFQVER)
63556 KFLB=MIN(KFQOLD,KFQVER)
63557 KFS=ISIGN(1,KFL1)
63558 IF(KFLA.NE.KFQOLD) KFS=-KFS
63559C... Form meson, with spin and flavour mixing for diagonal states.
63560 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
63561 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
63562 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
63563 RETURN
63564 ENDIF
63565 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
63566 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
63567 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
63568 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
63569 IF(PYR(0).LT.PARJ(14)) KMUL=2
63570 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
63571 RMUL=PYR(0)
63572 IF(RMUL.LT.PARJ(15)) KMUL=3
63573 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
63574 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
63575 ENDIF
63576 KFLS=3
63577 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
63578 IF(KMUL.EQ.5) KFLS=5
63579 IF(KFLA.NE.KFLB)THEN
63580 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
63581 ELSE
63582 RMIX=PYR(0)
63583 IMIX=2*KFLA+10*KMUL
63584 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
63585 & INT(RMIX+PARF(IMIX)))+KFLS
63586 IF(KFLA.GE.4) KF=110*KFLA+KFLS
63587 ENDIF
63588 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
63589 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
63590
63591C..Optional extra suppression of eta and eta'.
63592C..Allow shift to qq->B+q in old version (set IRANK to 0)
63593 IF(KF.EQ.221.OR.KF.EQ.331)THEN
63594 IF(PYR(0).GT.PARJ(25+KF/300))THEN
63595 IF(KF2A.GT.0) GOTO 130
63596 IF(MSTJ(12).LT.4) IRANK=0
63597 GOTO 110
63598 ENDIF
63599 ENDIF
63600 MSTU(121)=0
63601
63602C.. x->B+y: Flavour for baryon
63603 ELSE
63604 KFLA=KFQVER
63605 IF(KF1A.LE.10) KFLA=KFQOLD
63606 KFLB=MOD(KFDIQ/1000,10)
63607 KFLC=MOD(KFDIQ/100,10)
63608 KFLDS=MOD(KFDIQ,10)
63609 KFLD=MAX(KFLA,KFLB,KFLC)
63610 KFLF=MIN(KFLA,KFLB,KFLC)
63611 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
63612
63613C... SU(6) factors for formation of baryon.
63614 KBARY=3
63615 KDMAX=5
63616 KFLG=KFLB
63617 IF(KFLB.NE.KFLC)THEN
63618 KBARY=2*KFLDS-1
63619 KDMAX=1+KFLDS/2
63620 IF(KFLB.GT.2) KDMAX=KDMAX+2
63621 ENDIF
63622 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
63623 KBARY=KBARY+1
63624 KFLG=KFLA
63625 ENDIF
63626
63627 SU6MAX=PARF(140+KDMAX)
63628 SU6DEC=PARJ(18)
63629 SU6S =PARF(146)
63630 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
63631 SU6MAX=1D0
63632 SU6DEC=1D0
63633 SU6S =1D0
63634 ENDIF
63635 SU6OCT=PARF(60+KBARY)
63636 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
63637 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
63638 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
63639 ELSE
63640 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
63641 ENDIF
63642 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
63643
63644C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
63645 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
63646 MSTU(121)=0
63647 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
63648 GOTO 110
63649 ENDIF
63650
63651C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
63652 KSIG=1
63653 KFLS=2
63654 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
63655 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
63656 KSIG=KFLDS/3
63657 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
63658 ENDIF
63659 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
63660 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
63661 ENDIF
63662 RETURN
63663
63664C...Use tabulated probabilities to select new flavour and hadron.
63665 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
63666 KT3L=1
63667 KT3U=6
63668 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
63669 KT3L=1
63670 KT3U=6
63671 ELSEIF(KTAB2.EQ.0) THEN
63672 KT3L=1
63673 KT3U=22
63674 ELSE
63675 KT3L=KTAB2
63676 KT3U=KTAB2
63677 ENDIF
63678 RFL=0D0
63679 DO 160 KTS=0,2
63680 DO 150 KT3=KT3L,KT3U
63681 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
63682 150 CONTINUE
63683 160 CONTINUE
63684 RFL=PYR(0)*RFL
63685 DO 180 KTS=0,2
63686 KTABS=KTS
63687 DO 170 KT3=KT3L,KT3U
63688 KTAB3=KT3
63689 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
63690 IF(RFL.LE.0D0) GOTO 190
63691 170 CONTINUE
63692 180 CONTINUE
63693 190 CONTINUE
63694
63695C...Reconstruct flavour of produced quark/diquark.
63696 IF(KTAB3.LE.6) THEN
63697 KFL3A=KTAB3
63698 KFL3B=0
63699 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
63700 ELSE
63701 KFL3A=1
63702 IF(KTAB3.GE.8) KFL3A=2
63703 IF(KTAB3.GE.11) KFL3A=3
63704 IF(KTAB3.GE.16) KFL3A=4
63705 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
63706 KFL3=1000*KFL3A+100*KFL3B+1
63707 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
63708 & KFL3+2
63709 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
63710 ENDIF
63711
63712C...Reconstruct meson code.
63713 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
63714 &KFL3B.NE.0)) THEN
63715 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
63716 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
63717 KF=110+2*KTABS+1
63718 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
63719 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
63720 & 25*KTABS)) KF=330+2*KTABS+1
63721 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
63722 KFLA=MAX(KTAB1,KTAB3)
63723 KFLB=MIN(KTAB1,KTAB3)
63724 KFS=ISIGN(1,KFL1)
63725 IF(KFLA.NE.KF1A) KFS=-KFS
63726 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
63727 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
63728 KFS=ISIGN(1,KFL1)
63729 IF(KFL1A.EQ.KFL3A) THEN
63730 KFLA=MAX(KFL1B,KFL3B)
63731 KFLB=MIN(KFL1B,KFL3B)
63732 IF(KFLA.NE.KFL1B) KFS=-KFS
63733 ELSEIF(KFL1A.EQ.KFL3B) THEN
63734 KFLA=KFL3A
63735 KFLB=KFL1B
63736 KFS=-KFS
63737 ELSEIF(KFL1B.EQ.KFL3A) THEN
63738 KFLA=KFL1A
63739 KFLB=KFL3B
63740 ELSEIF(KFL1B.EQ.KFL3B) THEN
63741 KFLA=MAX(KFL1A,KFL3A)
63742 KFLB=MIN(KFL1A,KFL3A)
63743 IF(KFLA.NE.KFL1A) KFS=-KFS
63744 ELSE
63745 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
63746 GOTO 100
63747 ENDIF
63748 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
63749
63750C...Reconstruct baryon code.
63751 ELSE
63752 IF(KTAB1.GE.7) THEN
63753 KFLA=KFL3A
63754 KFLB=KFL1A
63755 KFLC=KFL1B
63756 ELSE
63757 KFLA=KFL1A
63758 KFLB=KFL3A
63759 KFLC=KFL3B
63760 ENDIF
63761 KFLD=MAX(KFLA,KFLB,KFLC)
63762 KFLF=MIN(KFLA,KFLB,KFLC)
63763 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
63764 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
63765 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
63766 ENDIF
63767
63768C...Check that constructed flavour code is an allowed one.
63769 IF(KFL2.NE.0) KFL3=0
63770 KC=PYCOMP(KF)
63771 IF(KC.EQ.0) THEN
63772 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
63773 & 'failed')
63774 GOTO 100
63775 ENDIF
63776
63777 RETURN
63778 END
63779
63780C*********************************************************************
63781
63782C...PYNMES
63783C...Generates number of popcorn mesons and stores some relevant
63784C...parameters.
63785
63786 SUBROUTINE PYNMES(KFDIQ)
63787
63788C...Double precision and integer declarations.
63789 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63790 IMPLICIT INTEGER(I-N)
63791 INTEGER PYK,PYCHGE,PYCOMP
63792C...Commonblocks.
63793 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63794 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63795 SAVE /PYDAT1/,/PYDAT2/
63796
63797 MSTU(121)=0
63798 IF(MSTJ(12).LT.2) RETURN
63799
63800C..Old version: Get 1 or 0 popcorn mesons
63801 IF(MSTJ(12).LT.5)THEN
63802 POPWT=PARF(131)
63803 IF(KFDIQ.NE.0) THEN
63804 KFDIQA=IABS(KFDIQ)
63805 KFA=MOD(KFDIQA/1000,10)
63806 KFB=MOD(KFDIQA/100,10)
63807 KFS=MOD(KFDIQA,10)
63808 POPWT=PARF(132)
63809 IF(KFA.EQ.3) POPWT=PARF(133)
63810 IF(KFB.EQ.3) POPWT=PARF(134)
63811 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
63812 ENDIF
63813 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
63814 RETURN
63815 ENDIF
63816
63817C..New version: Store popcorn- or rank 0 diquark parameters
63818 MSTU(122)=170
63819 PARF(193)=PARJ(8)
63820 PARF(194)=PARF(139)
63821 IF(KFDIQ.NE.0) THEN
63822 MSTU(122)=180
63823 PARF(193)=PARJ(10)
63824 PARF(194)=PARF(140)
63825 ENDIF
63826 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
63827 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
63828 & '(PYNMES:) Neglecting too large popcorn possibility')
63829 RETURN
63830 ENDIF
63831
63832C..New version: Get number of popcorn mesons
63833 100 RTST=PYR(0)
63834 MSTU(121)=-1
63835 110 MSTU(121)=MSTU(121)+1
63836 RTST=RTST/PARF(194)
63837 IF(RTST.LT.1D0) GOTO 110
63838 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
63839 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
63840 RETURN
63841 END
63842
63843C***************************************************************
63844
63845C...PYKFIN
63846C...Precalculates a set of diquark and popcorn weights.
63847
63848 SUBROUTINE PYKFIN
63849
63850C...Double precision and integer declarations.
63851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63852 IMPLICIT INTEGER(I-N)
63853 INTEGER PYK,PYCHGE,PYCOMP
63854C...Commonblocks.
63855 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63856 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63857 SAVE /PYDAT1/,/PYDAT2/
63858
63859 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
63860
63861
63862 MSTU(123)=1
63863C..Diquark indices for dimensional variables
63864 IUD1=1
63865 IUU1=2
63866 IUS0=3
63867 ISU0=4
63868 IUS1=5
63869 ISU1=6
63870 ISS1=7
63871
63872C.. *** SU(6) factors **
63873C..Modify with decuplet- (and Sigma/Lambda-) suppression.
63874 PARF(146)=1D0
63875 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
63876 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
63877 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
63878 DO 100 I=1,6
63879 SU6(I)=PARF(60+I)
63880 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
63881 100 CONTINUE
63882 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
63883 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
63884 DO 110 I=1,6
63885 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
63886 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
63887 110 CONTINUE
63888
63889C..SU(6)max q q' s,c,b
63890 SU6MUD =MAX(SU6(1) , SU6(8) )
63891 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
63892 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
63893 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
63894 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
63895 SU6M(IUS0)=SU6M(ISU0)
63896 SU6M(ISS1)=SU6M(IUU1)
63897 SU6M(IUS1)=SU6M(ISU1)
63898
63899C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
63900 PARF(141)=SU6MUD
63901 PARF(142)=SU6M(IUD1)
63902 PARF(143)=SU6M(ISU0)
63903 PARF(144)=SU6M(ISU1)
63904 PARF(145)=SU6M(ISS1)
63905
63906C..diquark SU(6) survival =
63907C..sum over quark (quark tunnel weight)*(SU(6)).
63908 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
63909 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
63910 DMB(IUS0)=DMB(ISU0)
63911 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
63912 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
63913 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
63914 DMB(IUS1)=DMB(ISU1)
63915 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
63916
63917C.. *** Tunneling factors for Diquark production***
63918C.. T: half a curtain pair = sqrt(curtain pair factor)
63919 IF(MSTJ(12).GE.5) THEN
63920 PMUD0=PYMASS(2101)
63921 PMUD1=PYMASS(2103)-PMUD0
63922 PMUS0=PYMASS(3201)-PMUD0
63923 PMUS1=PYMASS(3203)-PMUS0-PMUD0
63924 PMSS1=PYMASS(3303)-PMUS0-PMUD0
63925 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
63926 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
63927 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
63928 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
63929 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
63930 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
63931 QBB(IUD1)=QBB(IUU1)
63932 ELSE
63933 PAR2M=SQRT(PARJ(2))
63934 PAR3M=SQRT(PARJ(3))
63935 PAR4M=SQRT(PARJ(4))
63936 QBB(ISU0)=PAR2M*PAR3M
63937 QBB(IUS0)=PAR3M
63938 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
63939 QBB(IUU1)=PAR4M
63940 QBB(ISU1)=PAR4M*QBB(ISU0)
63941 QBB(IUS1)=PAR4M*QBB(IUS0)
63942 QBB(IUD1)=PAR4M
63943 ENDIF
63944
63945C.. tau: spin*(vertex factor)*(T = half-curtain factor)
63946 QBM(ISU0)=QBB(ISU0)
63947 QBM(IUS0)=PARJ(2)*QBB(IUS0)
63948 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
63949 QBM(IUU1)=6D0*QBB(IUU1)
63950 QBM(ISU1)=3D0*QBB(ISU1)
63951 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
63952 QBM(IUD1)=3D0*QBB(IUD1)
63953
63954C.. Combine T and tau to diquark weight for q-> B+B+..
63955 DO 120 I=1,7
63956 QBB(I)=QBB(I)*QBM(I)
63957 120 CONTINUE
63958
63959 IF(MSTJ(12).GE.5)THEN
63960C..New version: tau for rank 0 diquark.
63961 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
63962 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
63963 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
63964 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
63965 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
63966 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
63967 DMB(7+IUD1)=DMB(7+IUU1)/2D0
63968
63969C..New version: curtain flavour ratios.
63970C.. s/u for q->B+M+...
63971C.. s/u for rank 0 diquark: su -> ...M+B+...
63972C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
63973 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
63974 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
63975 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
63976 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
63977 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
63978 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
63979 ELSE
63980C..Old version: reset unused rank 0 diquark weights and
63981C.. unused diquark SU(6) survival weights
63982 DO 130 I=1,7
63983 IF(MSTJ(12).LT.3) DMB(I)=1D0
63984 DMB(7+I)=1D0
63985 130 CONTINUE
63986
63987C..Old version: Shuffle PARJ(7) into tau
63988 QBM(IUS0)=QBM(IUS0)*PARJ(7)
63989 QBM(ISS1)=QBM(ISS1)*PARJ(7)
63990 QBM(IUS1)=QBM(IUS1)*PARJ(7)
63991
63992C..Old version: curtain flavour ratios.
63993C.. s/u for q->B+M+...
63994C.. s/u for rank 0 diquark: su -> ...M+B+...
63995C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
63996 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
63997 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
63998 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
63999 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
64000 ENDIF
64001
64002C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
64003C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
64004 DO 140 I=1,7
64005 DMB(7+I)=DMB(7+I)*DMB(I)
64006 DMB(I)=DMB(I)*QBM(I)
64007 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
64008 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
64009 140 CONTINUE
64010
64011C.. *** Popcorn factors ***
64012
64013 IF(MSTJ(12).LT.5)THEN
64014C.. Old version: Resulting popcorn weights.
64015 PARF(138)=PARJ(6)
64016 WS=PARF(135)*PARF(138)
64017 WQ=WU*PARJ(5)/3D0
64018 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
64019 PARF(133)=WQ*
64020 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
64021 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
64022 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
64023 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
64024 & (1D0+QBB(IUD1)+QBB(IUU1)+
64025 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
64026 ELSE
64027C..New version: Store weights for popcorn mesons,
64028C..get prel. popcorn weights.
64029 DO 150 IPOS=201,1400
64030 PARF(IPOS)=0D0
64031 150 CONTINUE
64032 DO 160 I=138,140
64033 PARF(I)=0D0
64034 160 CONTINUE
64035 IPOS=200
64036 PARF(193)=PARJ(8)
64037 DO 240 MR=0,7,7
64038 IF(MR.EQ.7) PARF(193)=PARJ(10)
64039 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
64040 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
64041 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
64042 DO 230 NMES=0,1
64043 IF(NMES.EQ.1) SQWT=PARJ(2)
64044 DO 220 KFQPOP=1,4
64045 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
64046 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
64047 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
64048 QQWT=0.5D0
64049 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
64050 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
64051 ENDIF
64052 DO 210 KFQOLD =1,5
64053 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
64054 IF(NMES.EQ.1) THEN
64055 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
64056 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
64057 ENDIF
64058 WTTOT=0D0
64059 WTFAIL=0D0
64060 DO 190 KMUL=0,5
64061 PJWT=PARJ(12+KMUL)
64062 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
64063 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
64064 IF(PJWT.LE.0D0) GOTO 190
64065 IF(PJWT.GT.1D0) PJWT=1D0
64066 IMES=5*KMUL
64067 IMIX=2*KFQOLD+10*KMUL
64068 KFJ=2*KMUL+1
64069 IF(KMUL.EQ.2) KFJ=10003
64070 IF(KMUL.EQ.3) KFJ=10001
64071 IF(KMUL.EQ.4) KFJ=20003
64072 IF(KMUL.EQ.5) KFJ=5
64073 DO 180 KFQVER =1,3
64074 KFLA=MAX(KFQOLD,KFQVER)
64075 KFLB=MIN(KFQOLD,KFQVER)
64076 SWT=PARJ(11+KFLA/3+KFLA/4)
64077 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
64078 SWT=SWT*PJWT
64079 QWT=SQWT/(2D0+SQWT)
64080 IF(KFQVER.LT.3)THEN
64081 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
64082 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
64083 ENDIF
64084 IF(KFQVER.NE.KFQOLD)THEN
64085 IMES=IMES+1
64086 KFM=100*KFLA+10*KFLB+KFJ
64087 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64088 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
64089 WTTOT=WTTOT+PARF(IPOS+IMES)
64090 ELSE
64091 DO 170 ID=3,5
64092 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
64093 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
64094 IF(ID.EQ.5) DWT=PARF(IMIX)
64095 KFM=110*(ID-2)+KFJ
64096 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64097 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
64098 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
64099 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
64100 PARF(IPOS+5*KMUL+ID)=
64101 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
64102 ENDIF
64103 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
64104 170 CONTINUE
64105 ENDIF
64106 180 CONTINUE
64107 190 CONTINUE
64108 DO 200 IMES=1,30
64109 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
64110 200 CONTINUE
64111 IF(MR.EQ.7) PARF(140)=
64112 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
64113 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
64114 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
64115 IPOS=IPOS+30
64116 210 CONTINUE
64117 220 CONTINUE
64118 230 CONTINUE
64119 240 CONTINUE
64120 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
64121 MSTU(121)=0
64122
64123 ENDIF
64124
64125C..Recombine diquark weights to flavour and spin ratios
64126 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
64127 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
64128 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
64129 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
64130 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
64131 PARF(155)=QBB(ISU1)/QBB(ISU0)
64132 PARF(156)=QBB(IUS1)/QBB(IUS0)
64133 PARF(157)=QBB(IUD1)
64134
64135 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
64136 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
64137 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
64138 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
64139 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
64140 PARF(165)=QBM(ISU1)/QBM(ISU0)
64141 PARF(166)=QBM(IUS1)/QBM(IUS0)
64142 PARF(167)=QBM(IUD1)
64143
64144 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
64145 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
64146 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
64147 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
64148 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
64149 PARF(175)=DMB(ISU1)/DMB(ISU0)
64150 PARF(176)=DMB(IUS1)/DMB(IUS0)
64151 PARF(177)=DMB(IUD1)
64152
64153 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
64154 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
64155 PARF(187)=DMB(7+IUD1)
64156
64157 RETURN
64158 END
64159
64160
64161C*********************************************************************
64162
64163C...PYPTDI
64164C...Generates transverse momentum according to a Gaussian.
64165
64166 SUBROUTINE PYPTDI(KFL,PX,PY)
64167
64168C...Double precision and integer declarations.
64169 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64170 IMPLICIT INTEGER(I-N)
64171 INTEGER PYK,PYCHGE,PYCOMP
64172C...Commonblocks.
64173 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64174 SAVE /PYDAT1/
64175
64176C...Generate p_T and azimuthal angle, gives p_x and p_y.
64177 KFLA=IABS(KFL)
64178 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
64179 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
64180 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
64181 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
64182 PHI=PARU(2)*PYR(0)
64183 PX=PT*COS(PHI)
64184 PY=PT*SIN(PHI)
64185
64186 RETURN
64187 END
64188
64189C*********************************************************************
64190
64191C...PYZDIS
64192C...Generates the longitudinal splitting variable z.
64193
64194 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
64195
64196C...Double precision and integer declarations.
64197 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64198 IMPLICIT INTEGER(I-N)
64199 INTEGER PYK,PYCHGE,PYCOMP
64200C...Commonblocks.
64201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64203 SAVE /PYDAT1/,/PYDAT2/
64204
64205C...Check if heavy flavour fragmentation.
64206 KFLA=IABS(KFL1)
64207 KFLB=IABS(KFL2)
64208 KFLH=KFLA
64209 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
64210
64211C...Lund symmetric scaling function: determine parameters of shape.
64212 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
64213 &MSTJ(11).GE.4) THEN
64214 FA=PARJ(41)
64215 IF(MSTJ(91).EQ.1) FA=PARJ(43)
64216 IF(KFLB.GE.10) FA=FA+PARJ(45)
64217 FBB=PARJ(42)
64218 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
64219 FB=FBB*PR
64220 FC=1D0
64221 IF(KFLA.GE.10) FC=FC-PARJ(45)
64222 IF(KFLB.GE.10) FC=FC+PARJ(45)
64223 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
64224 FRED=PARJ(46)
64225 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
64226 FC=FC+FRED*FBB*PARF(100+KFLH)**2
64227 ENDIF
64228 MC=1
64229 IF(ABS(FC-1D0).GT.0.01D0) MC=2
64230
64231C...Determine position of maximum. Special cases for a = 0 or a = c.
64232 IF(FA.LT.0.02D0) THEN
64233 MA=1
64234 ZMAX=1D0
64235 IF(FC.GT.FB) ZMAX=FB/FC
64236 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
64237 MA=2
64238 ZMAX=FB/(FB+FC)
64239 ELSE
64240 MA=3
64241 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
64242 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
64243 ENDIF
64244
64245C...Subdivide z range if distribution very peaked near endpoint.
64246 MMAX=2
64247 IF(ZMAX.LT.0.1D0) THEN
64248 MMAX=1
64249 ZDIV=2.75D0*ZMAX
64250 IF(MC.EQ.1) THEN
64251 FINT=1D0-LOG(ZDIV)
64252 ELSE
64253 ZDIVC=ZDIV**(1D0-FC)
64254 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
64255 ENDIF
64256 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
64257 MMAX=3
64258 FSCB=SQRT(4D0+(FC/FB)**2)
64259 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
64260 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
64261 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
64262 FINT=1D0+FB*(1D0-ZDIV)
64263 ENDIF
64264
64265C...Choice of z, preweighted for peaks at low or high z.
64266 100 Z=PYR(0)
64267 FPRE=1D0
64268 IF(MMAX.EQ.1) THEN
64269 IF(FINT*PYR(0).LE.1D0) THEN
64270 Z=ZDIV*Z
64271 ELSEIF(MC.EQ.1) THEN
64272 Z=ZDIV**Z
64273 FPRE=ZDIV/Z
64274 ELSE
64275 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
64276 FPRE=(ZDIV/Z)**FC
64277 ENDIF
64278 ELSEIF(MMAX.EQ.3) THEN
64279 IF(FINT*PYR(0).LE.1D0) THEN
64280 Z=ZDIV+LOG(Z)/FB
64281 FPRE=EXP(FB*(Z-ZDIV))
64282 ELSE
64283 Z=ZDIV+Z*(1D0-ZDIV)
64284 ENDIF
64285 ENDIF
64286
64287C...Weighting according to correct formula.
64288 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
64289 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
64290 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
64291 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
64292 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
64293
64294C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
64295 ELSE
64296 FC=PARJ(50+MAX(1,KFLH))
64297 IF(MSTJ(91).EQ.1) FC=PARJ(59)
64298 110 Z=PYR(0)
64299 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
64300 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
64301 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
64302 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
64303 & GOTO 110
64304 ELSE
64305 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
64306 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
64307 ENDIF
64308 ENDIF
64309
64310 RETURN
64311 END
64312
64313C*********************************************************************
64314
64315C...PYSHOW
64316C...Generates timelike parton showers from given partons.
64317
64318 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
64319
64320C...Double precision and integer declarations.
64321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64322 IMPLICIT INTEGER(I-N)
64323 INTEGER PYK,PYCHGE,PYCOMP
64324C...Parameter statement to help give large particle numbers.
64325 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
64326 &KEXCIT=4000000,KDIMEN=5000000)
64327 PARAMETER (MAXNUR=1000)
64328C...Commonblocks.
64329 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
64330 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64333 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
64334 COMMON/PYINT1/MINT(400),VINT(400)
64335 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
64336C...Local arrays.
64337 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
64338 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
64339 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
64340 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
64341 &IREF(1000)
64342
64343C...Check that QMAX not too low.
64344 IF(MSTJ(41).LE.0) THEN
64345 RETURN
64346 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
64347 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
64348 ELSE
64349 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
64350 & RETURN
64351 ENDIF
64352
64353C...Store positions of shower initiating partons.
64354 MPSPD=0
64355 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
64356 NPA=1
64357 IPA(1)=IP1
64358 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
64359 & MSTU(32))) THEN
64360 NPA=2
64361 IPA(1)=IP1
64362 IPA(2)=IP2
64363 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
64364 & .AND.IP2.GE.-80) THEN
64365 NPA=IABS(IP2)
64366 DO 100 I=1,NPA
64367 IPA(I)=IP1+I-1
64368 100 CONTINUE
64369 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
64370 &IP2.EQ.-100) THEN
64371 MPSPD=1
64372 NPA=2
64373 IPA(1)=IP1+6
64374 IPA(2)=IP1+7
64375 ELSE
64376 CALL PYERRM(12,
64377 & '(PYSHOW:) failed to reconstruct showering system')
64378 IF(MSTU(21).GE.1) RETURN
64379 ENDIF
64380
64381C...Send off to PYPTFS for pT-ordered evolution if requested,
64382C...if at least 2 partons, and without predefined shower branchings.
64383 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
64384 &MPSPD.EQ.0) THEN
64385 NPART=NPA
64386 DO 110 II=1,NPART
64387 IPART(II)=IPA(II)
64388 PTPART(II)=0.5D0*QMAX
64389 110 CONTINUE
64390 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
64391 RETURN
64392 ENDIF
64393
64394C...Initialization of cutoff masses etc.
64395 DO 120 IFL=0,40
64396 ISCOL(IFL)=0
64397 ISCHG(IFL)=0
64398 KSH(IFL)=0
64399 120 CONTINUE
64400 ISCOL(21)=1
64401 KSH(21)=1
64402 PMTH(1,21)=PYMASS(21)
64403 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
64404 PMTH(3,21)=2D0*PMTH(2,21)
64405 PMTH(4,21)=PMTH(3,21)
64406 PMTH(5,21)=PMTH(3,21)
64407 PMTH(1,22)=PYMASS(22)
64408 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
64409 PMTH(3,22)=2D0*PMTH(2,22)
64410 PMTH(4,22)=PMTH(3,22)
64411 PMTH(5,22)=PMTH(3,22)
64412 PMQTH1=PARJ(82)
64413 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
64414 PMQT1E=MIN(PMQTH1,PARJ(90))
64415 PMQTH2=PMTH(2,21)
64416 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
64417 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
64418 DO 130 IFL=1,5
64419 ISCOL(IFL)=1
64420 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
64421 KSH(IFL)=1
64422 PMTH(1,IFL)=PYMASS(IFL)
64423 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
64424 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
64425 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
64426 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
64427 130 CONTINUE
64428 DO 140 IFL=11,15,2
64429 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
64430 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
64431 PMTH(1,IFL)=PYMASS(IFL)
64432 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
64433 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
64434 PMTH(4,IFL)=PMTH(3,IFL)
64435 PMTH(5,IFL)=PMTH(3,IFL)
64436 140 CONTINUE
64437 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
64438 ALAMS=PARJ(81)**2
64439 ALFM=LOG(PT2MIN/ALAMS)
64440
64441C...Check on phase space available for emission.
64442 IREJ=0
64443 DO 150 J=1,5
64444 PS(J)=0D0
64445 150 CONTINUE
64446 PM=0D0
64447 KFLA(2)=0
64448 DO 170 I=1,NPA
64449 KFLA(I)=IABS(K(IPA(I),2))
64450 PMA(I)=P(IPA(I),5)
64451C...Special cutoff masses for initial partons (may be a heavy quark,
64452C...squark, ..., and need not be on the mass shell).
64453 IR=30+I
64454 IF(NPA.LE.1) IREF(I)=IR
64455 IF(NPA.GE.2) IREF(I+1)=IR
64456 ISCOL(IR)=0
64457 ISCHG(IR)=0
64458 KSH(IR)=0
64459 IF(KFLA(I).LE.8) THEN
64460 ISCOL(IR)=1
64461 IF(MSTJ(41).GE.2) ISCHG(IR)=1
64462 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
64463 & KFLA(I).EQ.17) THEN
64464 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
64465 ELSEIF(KFLA(I).EQ.21) THEN
64466 ISCOL(IR)=1
64467 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
64468 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
64469 ISCOL(IR)=1
64470 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
64471 ISCOL(IR)=1
64472C...QUARKONIA+++
64473C...same for QQ~[3S18]
64474 ELSEIF(KFLA(I).EQ.9900443.OR.KFLA(I).EQ.9900553) THEN
64475 ISCOL(IR)=1
64476C...QUARKONIA---
64477 ENDIF
64478 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
64479 PMTH(1,IR)=PMA(I)
64480 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
64481 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
64482 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
64483 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
64484 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
64485 ELSEIF(ISCOL(IR).EQ.1) THEN
64486 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
64487 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
64488 PMTH(4,IR)=PMTH(3,IR)
64489 PMTH(5,IR)=PMTH(3,IR)
64490 ELSEIF(ISCHG(IR).EQ.1) THEN
64491 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
64492 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
64493 PMTH(4,IR)=PMTH(3,IR)
64494 PMTH(5,IR)=PMTH(3,IR)
64495 ENDIF
64496 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
64497 PM=PM+PMA(I)
64498 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
64499 DO 160 J=1,4
64500 PS(J)=PS(J)+P(IPA(I),J)
64501 160 CONTINUE
64502 170 CONTINUE
64503 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
64504 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
64505 IF(NPA.EQ.1) PS(5)=PS(4)
64506 IF(PS(5).LE.PM+PMQT1E) RETURN
64507
64508C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
64509 KFSRCE=0
64510 IF(IP2.LE.0) THEN
64511 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
64512 KFSRCE=IABS(K(K(IP1,3),2))
64513 ELSE
64514 IPAR1=MAX(1,K(IP1,3))
64515 IPAR2=MAX(1,K(IP2,3))
64516 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
64517 & KFSRCE=IABS(K(K(IPAR1,3),2))
64518 ENDIF
64519 ITYPES=0
64520 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
64521 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
64522 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
64523 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
64524 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
64525 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
64526 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
64527 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
64528
64529C...Identify two primary showerers.
64530 ITYPE1=0
64531 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
64532 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
64533 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
64534 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
64535 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
64536 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
64537 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
64538 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
64539 ITYPE2=0
64540 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
64541 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
64542 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
64543 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
64544 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
64545 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
64546 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
64547 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
64548
64549C...Order of showerers. Presence of gluino.
64550 ITYPMN=MIN(ITYPE1,ITYPE2)
64551 ITYPMX=MAX(ITYPE1,ITYPE2)
64552 IORD=1
64553 IF(ITYPE1.GT.ITYPE2) IORD=2
64554 IGLUI=0
64555 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
64556
64557C...Check if 3-jet matrix elements to be used.
64558 M3JC=0
64559 ALPHA=0.5D0
64560 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
64561 IF(MSTJ(38).NE.0) THEN
64562 M3JC=MSTJ(38)
64563 ALPHA=PARJ(80)
64564 MSTJ(38)=0
64565 ELSEIF(MSTJ(47).GE.6) THEN
64566 M3JC=MSTJ(47)
64567 ELSE
64568 ICLASS=1
64569 ICOMBI=4
64570
64571C...Vector/axial vector -> q + qbar; q -> q + V.
64572 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
64573 & ITYPES.EQ.3)) THEN
64574 ICLASS=2
64575 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
64576 ICOMBI=1
64577 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
64578 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
64579C...gamma*/Z0: assume e+e- initial state if unknown.
64580 EI=-1D0
64581 IF(KFSRCE.EQ.23) THEN
64582 IANNFL=K(K(IP1,3),3)
64583 IF(IANNFL.NE.0) THEN
64584 KANNFL=IABS(K(IANNFL,2))
64585 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
64586 ENDIF
64587 ENDIF
64588 AI=SIGN(1D0,EI+0.1D0)
64589 VI=AI-4D0*EI*PARU(102)
64590 EF=KCHG(KFLA(1),1)/3D0
64591 AF=SIGN(1D0,EF+0.1D0)
64592 VF=AF-4D0*EF*PARU(102)
64593 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
64594 SH=PS(5)**2
64595 SQMZ=PMAS(23,1)**2
64596 SQWZ=PS(5)*PMAS(23,2)
64597 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
64598 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
64599 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
64600 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
64601 ICOMBI=3
64602 ALPHA=VECT/(VECT+AXIV)
64603 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
64604 ICOMBI=4
64605 ENDIF
64606C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
64607 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
64608 ICLASS=2
64609 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
64610 & ITYPES.EQ.1)) THEN
64611 ICLASS=3
64612
64613C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
64614 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
64615 ICLASS=4
64616 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
64617 ICOMBI=1
64618 ELSEIF(KFSRCE.EQ.36) THEN
64619 ICOMBI=2
64620 ENDIF
64621 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
64622 & ITYPES.EQ.1)) THEN
64623 ICLASS=5
64624
64625C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
64626 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
64627 & ITYPES.EQ.3)) THEN
64628 ICLASS=6
64629 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
64630 & ITYPES.EQ.2)) THEN
64631 ICLASS=7
64632 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
64633 ICLASS=8
64634 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
64635 & ITYPES.EQ.2)) THEN
64636 ICLASS=9
64637
64638C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
64639 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
64640 & ITYPES.EQ.5)) THEN
64641 ICLASS=10
64642 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
64643 & ITYPES.EQ.2)) THEN
64644 ICLASS=11
64645 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
64646 & ITYPES.EQ.1)) THEN
64647 ICLASS=12
64648
64649C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
64650 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
64651 ICLASS=13
64652 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
64653 & ITYPES.EQ.2)) THEN
64654 ICLASS=14
64655 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
64656 & ITYPES.EQ.1)) THEN
64657 ICLASS=15
64658
64659C...g -> ~g + ~g (eikonal approximation).
64660 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
64661 ICLASS=16
64662 ENDIF
64663 M3JC=5*ICLASS+ICOMBI
64664 ENDIF
64665 ENDIF
64666
64667C...Find if interference with initial state partons.
64668 MIIS=0
64669 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
64670 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
64671 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
64672 &MIIS=MSTJ(50)-3
64673 IF(MIIS.NE.0) THEN
64674 DO 190 I=1,2
64675 KCII(I)=0
64676 KCA=PYCOMP(KFLA(I))
64677 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
64678 NIIS(I)=0
64679 IF(KCII(I).NE.0) THEN
64680 DO 180 J=1,2
64681 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
64682 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
64683 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
64684 NIIS(I)=NIIS(I)+1
64685 IIIS(I,NIIS(I))=ICSI
64686 ENDIF
64687 180 CONTINUE
64688 ENDIF
64689 190 CONTINUE
64690 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
64691 ENDIF
64692
64693C...Boost interfering initial partons to rest frame
64694C...and reconstruct their polar and azimuthal angles.
64695 IF(MIIS.NE.0) THEN
64696 DO 210 I=1,2
64697 DO 200 J=1,5
64698 K(N+I,J)=K(IPA(I),J)
64699 P(N+I,J)=P(IPA(I),J)
64700 V(N+I,J)=0D0
64701 200 CONTINUE
64702 210 CONTINUE
64703 DO 230 I=3,2+NIIS(1)
64704 DO 220 J=1,5
64705 K(N+I,J)=K(IIIS(1,I-2),J)
64706 P(N+I,J)=P(IIIS(1,I-2),J)
64707 V(N+I,J)=0D0
64708 220 CONTINUE
64709 230 CONTINUE
64710 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
64711 DO 240 J=1,5
64712 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
64713 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
64714 V(N+I,J)=0D0
64715 240 CONTINUE
64716 250 CONTINUE
64717 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
64718 & -PS(2)/PS(4),-PS(3)/PS(4))
64719 PHI=PYANGL(P(N+1,1),P(N+1,2))
64720 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
64721 THE=PYANGL(P(N+1,3),P(N+1,1))
64722 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
64723 DO 260 I=3,2+NIIS(1)
64724 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
64725 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
64726 260 CONTINUE
64727 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
64728 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
64729 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
64730 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
64731 270 CONTINUE
64732 ENDIF
64733
64734C...Boost 3 or more partons to their rest frame.
64735 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
64736 &-PS(2)/PS(4),-PS(3)/PS(4))
64737
64738C...Define imagined single initiator of shower for parton system.
64739 NS=N
64740 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
64741 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
64742 IF(MSTU(21).GE.1) RETURN
64743 ENDIF
64744 280 N=NS
64745 IF(NPA.GE.2) THEN
64746 K(N+1,1)=11
64747 K(N+1,2)=21
64748 K(N+1,3)=0
64749 K(N+1,4)=0
64750 K(N+1,5)=0
64751 P(N+1,1)=0D0
64752 P(N+1,2)=0D0
64753 P(N+1,3)=0D0
64754 P(N+1,4)=PS(5)
64755 P(N+1,5)=PS(5)
64756 V(N+1,5)=PS(5)**2
64757 N=N+1
64758 IREF(1)=21
64759 ENDIF
64760
64761C...Loop over partons that may branch.
64762 NEP=NPA
64763 IM=NS
64764 IF(NPA.EQ.1) IM=NS-1
64765 290 IM=IM+1
64766 IF(N.GT.NS) THEN
64767 IF(IM.GT.N) GOTO 600
64768 KFLM=IABS(K(IM,2))
64769 IR=IREF(IM-NS)
64770 IF(KSH(IR).EQ.0) GOTO 290
64771 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
64772 IGM=K(IM,3)
64773 ELSE
64774 IGM=-1
64775 ENDIF
64776 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
64777 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
64778 IF(MSTU(21).GE.1) RETURN
64779 ENDIF
64780
64781C...Position of aunt (sister to branching parton).
64782C...Origin and flavour of daughters.
64783 IAU=0
64784 IF(IGM.GT.0) THEN
64785 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
64786 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
64787 ENDIF
64788 IF(IGM.GE.0) THEN
64789 K(IM,4)=N+1
64790 DO 300 I=1,NEP
64791 K(N+I,3)=IM
64792 300 CONTINUE
64793 ELSE
64794 K(N+1,3)=IPA(1)
64795 ENDIF
64796 IF(IGM.LE.0) THEN
64797 DO 310 I=1,NEP
64798 K(N+I,2)=K(IPA(I),2)
64799 310 CONTINUE
64800 ELSEIF(KFLM.NE.21) THEN
64801 K(N+1,2)=K(IM,2)
64802 K(N+2,2)=K(IM,5)
64803 IREF(N+1-NS)=IREF(IM-NS)
64804 IREF(N+2-NS)=IABS(K(N+2,2))
64805 ELSEIF(K(IM,5).EQ.21) THEN
64806 K(N+1,2)=21
64807 K(N+2,2)=21
64808 IREF(N+1-NS)=21
64809 IREF(N+2-NS)=21
64810 ELSE
64811 K(N+1,2)=K(IM,5)
64812 K(N+2,2)=-K(IM,5)
64813 IREF(N+1-NS)=IABS(K(N+1,2))
64814 IREF(N+2-NS)=IABS(K(N+2,2))
64815 ENDIF
64816
64817C...Reset flags on daughters and tries made.
64818 DO 320 IP=1,NEP
64819 K(N+IP,1)=3
64820 K(N+IP,4)=0
64821 K(N+IP,5)=0
64822 KFLD(IP)=IABS(K(N+IP,2))
64823 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
64824 ITRY(IP)=0
64825 ISL(IP)=0
64826 ISI(IP)=0
64827 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
64828 320 CONTINUE
64829 ISLM=0
64830
64831C...Maximum virtuality of daughters.
64832 IF(IGM.LE.0) THEN
64833 DO 330 I=1,NPA
64834 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
64835 P(N+I,5)=MIN(QMAX,PS(5))
64836 IR=IREF(N+I-NS)
64837 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
64838 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
64839 330 CONTINUE
64840 ELSE
64841 IF(MSTJ(43).LE.2) PEM=V(IM,2)
64842 IF(MSTJ(43).GE.3) PEM=P(IM,4)
64843 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
64844 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
64845 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
64846 ENDIF
64847 DO 340 I=1,NEP
64848 PMSD(I)=P(N+I,5)
64849 IF(ISI(I).EQ.1) THEN
64850 IR=IREF(N+I-NS)
64851 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
64852 ENDIF
64853 V(N+I,5)=P(N+I,5)**2
64854 340 CONTINUE
64855
64856C...Choose one of the daughters for evolution.
64857 350 INUM=0
64858 IF(NEP.EQ.1) INUM=1
64859 DO 360 I=1,NEP
64860 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
64861 360 CONTINUE
64862 DO 370 I=1,NEP
64863 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
64864 IR=IREF(N+I-NS)
64865 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
64866 ENDIF
64867 370 CONTINUE
64868 IF(INUM.EQ.0) THEN
64869 RMAX=0D0
64870 DO 380 I=1,NEP
64871 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
64872 RPM=P(N+I,5)/PMSD(I)
64873 IR=IREF(N+I-NS)
64874 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
64875 RMAX=RPM
64876 INUM=I
64877 ENDIF
64878 ENDIF
64879 380 CONTINUE
64880 ENDIF
64881
64882C...Cancel choice of predetermined daughter already treated.
64883 INUM=MAX(1,INUM)
64884 INUMT=INUM
64885 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
64886 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
64887 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
64888 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
64889 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
64890 ENDIF
64891
64892C...Store information on choice of evolving daughter.
64893 IEP(1)=N+INUM
64894 DO 390 I=2,NEP
64895 IEP(I)=IEP(I-1)+1
64896 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
64897 390 CONTINUE
64898 DO 400 I=1,NEP
64899 KFL(I)=IABS(K(IEP(I),2))
64900 400 CONTINUE
64901 ITRY(INUM)=ITRY(INUM)+1
64902 IF(ITRY(INUM).GT.200) THEN
64903 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
64904 IF(MSTU(21).GE.1) RETURN
64905 ENDIF
64906 Z=0.5D0
64907 IR=IREF(IEP(1)-NS)
64908 IF(KSH(IR).EQ.0) GOTO 450
64909 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
64910
64911C...Check if evolution already predetermined for daughter.
64912 IPSPD=0
64913 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
64914 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
64915 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
64916 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
64917 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
64918 ENDIF
64919 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
64920 ISSET(INUM)=0
64921 IF(IPSPD.NE.0) ISSET(INUM)=1
64922 ENDIF
64923
64924C...Select side for interference with initial state partons.
64925 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
64926 III=IEP(1)-NS-1
64927 ISII(III)=0
64928 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
64929 ISII(III)=1
64930 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
64931 IF(PYR(0).GT.0.5D0) ISII(III)=1
64932 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
64933 ISII(III)=1
64934 IF(PYR(0).GT.0.5D0) ISII(III)=2
64935 ENDIF
64936 ENDIF
64937
64938C...Calculate allowed z range.
64939 IF(NEP.EQ.1) THEN
64940 PMED=PS(4)
64941 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
64942 PMED=P(IM,5)
64943 ELSE
64944 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
64945 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
64946 ENDIF
64947 IF(MOD(MSTJ(43),2).EQ.1) THEN
64948 ZC=PMTH(2,21)/PMED
64949 ZCE=PMTH(2,22)/PMED
64950 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
64951 ELSE
64952 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
64953 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
64954 PMTMPE=PMTH(2,22)
64955 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
64956 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
64957 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
64958 ENDIF
64959 ZC=MIN(ZC,0.491D0)
64960 ZCE=MIN(ZCE,0.49991D0)
64961 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
64962 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
64963 P(IEP(1),5)=PMTH(1,IR)
64964 V(IEP(1),5)=P(IEP(1),5)**2
64965 GOTO 450
64966 ENDIF
64967
64968C...Integral of Altarelli-Parisi z kernel for QCD.
64969C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
64970 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
64971 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
64972C...QUARKONIA+++
64973C...Evolution of QQ~[3S18] state if MSTJ(191)=1.
64974 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(148).EQ.1.AND.
64975 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
64976 FBR=6D0*LOG((1D0-ZC)/ZC)
64977C...QUARKONIA---
64978 ELSEIF(MSTJ(49).EQ.0) THEN
64979 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
64980 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
64981
64982C...Integral of Altarelli-Parisi z kernel for scalar gluon.
64983 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
64984 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
64985 ELSEIF(MSTJ(49).EQ.1) THEN
64986 FBR=(1D0-2D0*ZC)/3D0
64987 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
64988
64989C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
64990 ELSEIF(KFL(1).EQ.21) THEN
64991 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
64992 ELSE
64993 FBR=2D0*LOG((1D0-ZC)/ZC)
64994 ENDIF
64995
64996C...Reset QCD probability for colourless.
64997 IF(ISCOL(IR).EQ.0) FBR=0D0
64998
64999C...Integral of Altarelli-Parisi kernel for photon emission.
65000 FBRE=0D0
65001 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
65002 IF(KFL(1).LE.18) THEN
65003 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
65004 ENDIF
65005 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
65006 ENDIF
65007
65008C...Inner veto algorithm starts. Find maximum mass for evolution.
65009 410 PMS=V(IEP(1),5)
65010 IF(IGM.GE.0) THEN
65011 PM2=0D0
65012 DO 420 I=2,NEP
65013 PM=P(IEP(I),5)
65014 IRI=IREF(IEP(I)-NS)
65015 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
65016 PM2=PM2+PM
65017 420 CONTINUE
65018 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
65019 ENDIF
65020
65021C...Select mass for daughter in QCD evolution.
65022 B0=27D0/6D0
65023 DO 430 IFF=4,MSTJ(45)
65024 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
65025 430 CONTINUE
65026C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
65027 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
65028C...Already predetermined choice.
65029 IF(IPSPD.NE.0) THEN
65030 PMSQCD=P(IPSPD,5)**2
65031 ELSEIF(FBR.LT.1D-3) THEN
65032 PMSQCD=0D0
65033 ELSEIF(MSTJ(44).LE.0) THEN
65034 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
65035 ELSEIF(MSTJ(44).EQ.1) THEN
65036 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
65037 ELSE
65038 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
65039 ENDIF
65040C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
65041 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
65042 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
65043 V(IEP(1),5)=PMSQCD
65044 MCE=1
65045
65046C...Select mass for daughter in QED evolution.
65047 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
65048C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
65049 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
65050 IF(FBRE.LT.1D-3) THEN
65051 PMSQED=0D0
65052 ELSE
65053 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
65054 & (PARU(101)*FBRE)))
65055 ENDIF
65056C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
65057 PMSQED=PMSQED+PMTH(1,IR)**2
65058 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
65059 & PMTH(2,IR)**2
65060 IF(PMSQED.GT.PMSQCD) THEN
65061 V(IEP(1),5)=PMSQED
65062 MCE=2
65063 ENDIF
65064 ENDIF
65065
65066C...Check whether daughter mass below cutoff.
65067 P(IEP(1),5)=SQRT(V(IEP(1),5))
65068 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
65069 P(IEP(1),5)=PMTH(1,IR)
65070 V(IEP(1),5)=P(IEP(1),5)**2
65071 GOTO 450
65072 ENDIF
65073
65074C...Already predetermined choice of z, and flavour in g -> qqbar.
65075 IF(IPSPD.NE.0) THEN
65076 IPSGD1=K(IPSPD,4)
65077 IPSGD2=K(IPSPD,5)
65078 PMSGD1=P(IPSGD1,5)**2
65079 PMSGD2=P(IPSGD2,5)**2
65080 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
65081 & 4D0*PMSGD1*PMSGD2))
65082 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
65083 & PMSGD1+PMSGD2)/ALAMPS
65084 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
65085 IF(KFL(1).NE.21) THEN
65086 K(IEP(1),5)=21
65087 ELSE
65088 K(IEP(1),5)=IABS(K(IPSGD1,2))
65089 ENDIF
65090
65091C...Select z value of branching: q -> qgamma.
65092 ELSEIF(MCE.EQ.2) THEN
65093 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
65094 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
65095 K(IEP(1),5)=22
65096
65097C...QUARKONIA+++
65098C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
65099 ELSEIF(MSTJ(49).EQ.0.AND.
65100 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
65101 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
65102C...Select always the harder 'gluon' if the switch MSTP(149)=0.
65103 IF(MSTP(149).EQ.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
65104 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
65105 K(IEP(1),5)=21
65106C...QUARKONIA---
65107
65108C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
65109 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
65110 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
65111C...Only do z weighting when no ME correction afterwards.
65112 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
65113 K(IEP(1),5)=21
65114 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
65115 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
65116 IF(PYR(0).GT.0.5D0) Z=1D0-Z
65117 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
65118 K(IEP(1),5)=21
65119 ELSEIF(MSTJ(49).NE.1) THEN
65120 Z=PYR(0)
65121 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
65122 KFLB=1+INT(MSTJ(45)*PYR(0))
65123 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
65124 IF(PMQ.GE.1D0) GOTO 410
65125 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
65126 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
65127 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
65128 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
65129 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
65130 ELSE
65131 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
65132 ENDIF
65133 K(IEP(1),5)=KFLB
65134
65135C...Ditto for scalar gluon model.
65136 ELSEIF(KFL(1).NE.21) THEN
65137 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
65138 K(IEP(1),5)=21
65139 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
65140 Z=ZC+(1D0-2D0*ZC)*PYR(0)
65141 K(IEP(1),5)=21
65142 ELSE
65143 Z=ZC+(1D0-2D0*ZC)*PYR(0)
65144 KFLB=1+INT(MSTJ(45)*PYR(0))
65145 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
65146 IF(PMQ.GE.1D0) GOTO 410
65147 K(IEP(1),5)=KFLB
65148 ENDIF
65149
65150C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
65151 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
65152 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
65153 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65154 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
65155 ELSE
65156 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
65157 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
65158 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
65159 IF(PT2APP.LT.PT2MIN) GOTO 410
65160 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
65161 ENDIF
65162 ENDIF
65163
65164C...Check if z consistent with chosen m.
65165 IF(KFL(1).EQ.21) THEN
65166 IRGD1=IABS(K(IEP(1),5))
65167 IRGD2=IRGD1
65168 ELSE
65169 IRGD1=IR
65170 IRGD2=IABS(K(IEP(1),5))
65171 ENDIF
65172 IF(NEP.EQ.1) THEN
65173 PED=PS(4)
65174 ELSEIF(NEP.GE.3) THEN
65175 PED=P(IEP(1),4)
65176 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
65177 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
65178 ELSE
65179 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
65180 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
65181 ENDIF
65182 IF(MOD(MSTJ(43),2).EQ.1) THEN
65183 PMQTH3=0.5D0*PARJ(82)
65184 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
65185 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
65186 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
65187 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
65188 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
65189 & 4D0*PMQ1*PMQ2)))
65190 ZH=1D0+PMQ1-PMQ2
65191 ELSE
65192 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
65193 ZH=1D0
65194 ENDIF
65195 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
65196 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65197 ELSEIF(IPSPD.NE.0) THEN
65198 ELSE
65199 ZL=0.5D0*(ZH-ZD)
65200 ZU=0.5D0*(ZH+ZD)
65201 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
65202 ENDIF
65203 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
65204 &(1D0-ZU)))
65205 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
65206
65207C...Width suppression for q -> q + g.
65208 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
65209 IF(IGM.EQ.0) THEN
65210 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
65211 ELSE
65212 EGLU=PMED*(1D0-Z)
65213 ENDIF
65214 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
65215 IF(MSTJ(40).EQ.1) THEN
65216 IF(CHI.LT.PYR(0)) GOTO 410
65217 ELSEIF(MSTJ(40).EQ.2) THEN
65218 IF(1D0-CHI.LT.PYR(0)) GOTO 410
65219 ENDIF
65220 ENDIF
65221
65222C...Three-jet matrix element correction.
65223 IF(M3JC.GE.1) THEN
65224 WME=1D0
65225 WSHOW=1D0
65226
65227C...QED matrix elements: only for massless case so far.
65228 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
65229 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
65230 X2=1D0-V(IEP(1),5)/V(NS+1,5)
65231 X3=(1D0-X1)+(1D0-X2)
65232 KI1=K(IPA(INUM),2)
65233 KI2=K(IPA(3-INUM),2)
65234 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
65235 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
65236 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
65237 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
65238 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
65239 ELSEIF(MCE.EQ.2) THEN
65240
65241C...QCD matrix elements, including mass effects.
65242 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
65243 PS1ME=V(IEP(1),5)
65244 PM1ME=PMTH(1,IR)
65245 M3JCC=M3JC
65246 IF(IR.GE.31.AND.IGM.EQ.0) THEN
65247C...QCD ME: original parton, first branching.
65248 PM2ME=PMTH(1,63-IR)
65249 ECMME=PS(5)
65250 ELSEIF(IR.GE.31) THEN
65251C...QCD ME: original parton, subsequent branchings.
65252 PM2ME=PMTH(1,63-IR)
65253 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
65254 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
65255 ELSEIF(K(IM,2).EQ.21) THEN
65256C...QCD ME: secondary partons, first branching.
65257 PM2ME=PM1ME
65258 ZMME=V(IM,1)
65259 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
65260 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
65261 & 4D0*PS1ME*PM2ME**2))
65262 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
65263 & V(IM,5)
65264 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
65265 M3JCC=66
65266 ELSE
65267C...QCD ME: secondary partons, subsequent branchings.
65268 PM2ME=PM1ME
65269 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
65270 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
65271 M3JCC=66
65272 ENDIF
65273C...Construct ME variables.
65274 R1ME=PM1ME/ECMME
65275 R2ME=PM2ME/ECMME
65276 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
65277 X2=1D0+R2ME**2-PS1ME/ECMME**2
65278C...Call ME, with right order important for two inequivalent showerers.
65279 IF(IR.EQ.IORD+30) THEN
65280 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
65281 ELSE
65282 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
65283 ENDIF
65284C...Split up total ME when two radiating partons.
65285 ISPRAD=1
65286 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
65287 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
65288 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
65289 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
65290 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
65291 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
65292 & MAX(1D-10,2D0-X1-X2)
65293C...Evaluate shower rate to be compared with.
65294 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
65295 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
65296 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
65297 ELSEIF(MSTJ(49).NE.1) THEN
65298
65299C...Toy model scalar theory matrix elements; no mass effects.
65300 ELSE
65301 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
65302 X2=1D0-V(IEP(1),5)/V(NS+1,5)
65303 X3=(1D0-X1)+(1D0-X2)
65304 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
65305 WME=X3**2
65306 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
65307 & PARJ(171)
65308 ENDIF
65309
65310 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
65311 ENDIF
65312
65313C...Impose angular ordering by rejection of nonordered emission.
65314 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
65315 PEMAO=V(IM,1)*P(IM,4)
65316 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
65317 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
65318 MAOD=0
65319 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
65320 & .OR.MSTJ(42).EQ.7)) THEN
65321 MAOD=0
65322 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
65323 & .OR.MSTJ(42).EQ.6)) THEN
65324 MAOD=1
65325 PMDAO=PMTH(2,K(IEP(1),5))
65326 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
65327 ELSE
65328 MAOD=1
65329 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
65330 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
65331 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
65332 ENDIF
65333 MAOM=1
65334 IAOM=IM
65335 440 IF(K(IAOM,5).EQ.22) THEN
65336 IAOM=K(IAOM,3)
65337 IF(K(IAOM,3).LE.NS) MAOM=0
65338 IF(MAOM.EQ.1) GOTO 440
65339 ENDIF
65340 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
65341 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
65342 IF(THE2ID.LT.THE2IM) GOTO 410
65343 ENDIF
65344 ENDIF
65345
65346C...Impose user-defined maximum angle at first branching.
65347 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
65348 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
65349 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
65350 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
65351 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
65352 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
65353 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
65354 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
65355 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
65356 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
65357 ENDIF
65358 ENDIF
65359
65360C...Impose angular constraint in first branching from interference
65361C...with initial state partons.
65362 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
65363 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
65364 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
65365 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
65366 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
65367 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
65368 ENDIF
65369 ENDIF
65370
65371C...End of inner veto algorithm. Check if only one leg evolved so far.
65372 450 V(IEP(1),1)=Z
65373 ISL(1)=0
65374 ISL(2)=0
65375 IF(NEP.EQ.1) GOTO 490
65376 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
65377 DO 460 I=1,NEP
65378 IR=IREF(N+I-NS)
65379 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
65380 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
65381 ENDIF
65382 460 CONTINUE
65383
65384C...Check if chosen multiplet m1,m2,z1,z2 is physical.
65385 IF(NEP.GE.3) THEN
65386 PMSUM=0D0
65387 DO 470 I=1,NEP
65388 PMSUM=PMSUM+P(N+I,5)
65389 470 CONTINUE
65390 IF(PMSUM.GE.PS(5)) GOTO 350
65391 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
65392 DO 480 I1=N+1,N+2
65393 IRDA=IREF(I1-NS)
65394 IF(KSH(IRDA).EQ.0) GOTO 480
65395 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
65396 IF(IRDA.EQ.21) THEN
65397 IRGD1=IABS(K(I1,5))
65398 IRGD2=IRGD1
65399 ELSE
65400 IRGD1=IRDA
65401 IRGD2=IABS(K(I1,5))
65402 ENDIF
65403 I2=2*N+3-I1
65404 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
65405 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
65406 ELSE
65407 IF(I1.EQ.N+1) ZM=V(IM,1)
65408 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
65409 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
65410 & 4D0*V(N+1,5)*V(N+2,5))
65411 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
65412 & V(IM,5)
65413 ENDIF
65414 IF(MOD(MSTJ(43),2).EQ.1) THEN
65415 PMQTH3=0.5D0*PARJ(82)
65416 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
65417 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
65418 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
65419 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
65420 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
65421 & 4D0*PMQ1*PMQ2)))
65422 ZH=1D0+PMQ1-PMQ2
65423 ELSE
65424 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
65425 ZH=1D0
65426 ENDIF
65427 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
65428 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65429 ELSE
65430 ZL=0.5D0*(ZH-ZD)
65431 ZU=0.5D0*(ZH+ZD)
65432 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
65433 & ISSET(1).EQ.0) THEN
65434 ISL(1)=1
65435 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
65436 & ISSET(2).EQ.0) THEN
65437 ISL(2)=1
65438 ENDIF
65439 ENDIF
65440 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
65441 & ZL*(1D0-ZU)))
65442 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
65443 480 CONTINUE
65444 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
65445 ISL(3-ISLM)=0
65446 ISLM=3-ISLM
65447 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
65448 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
65449 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
65450 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
65451 IF(ISL(1).EQ.1) ISL(2)=0
65452 IF(ISL(1).EQ.0) ISLM=1
65453 IF(ISL(2).EQ.0) ISLM=2
65454 ENDIF
65455 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
65456 ENDIF
65457 IRD1=IREF(N+1-NS)
65458 IRD2=IREF(N+2-NS)
65459 IF(IGM.GT.0) THEN
65460 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
65461 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
65462 PMQ1=V(N+1,5)/V(IM,5)
65463 PMQ2=V(N+2,5)/V(IM,5)
65464 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
65465 & 4D0*PMQ1*PMQ2)))
65466 ZH=1D0+PMQ1-PMQ2
65467 ZL=0.5D0*(ZH-ZD)
65468 ZU=0.5D0*(ZH+ZD)
65469 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
65470 ENDIF
65471 ENDIF
65472
65473C...Accepted branch. Construct four-momentum for initial partons.
65474 490 MAZIP=0
65475 MAZIC=0
65476 IF(NEP.EQ.1) THEN
65477 P(N+1,1)=0D0
65478 P(N+1,2)=0D0
65479 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
65480 & P(N+1,5))))
65481 P(N+1,4)=P(IPA(1),4)
65482 V(N+1,2)=P(N+1,4)
65483 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
65484 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
65485 P(N+1,1)=0D0
65486 P(N+1,2)=0D0
65487 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
65488 P(N+1,4)=PED1
65489 P(N+2,1)=0D0
65490 P(N+2,2)=0D0
65491 P(N+2,3)=-P(N+1,3)
65492 P(N+2,4)=P(IM,5)-PED1
65493 V(N+1,2)=P(N+1,4)
65494 V(N+2,2)=P(N+2,4)
65495 ELSEIF(NEP.GE.3) THEN
65496C...Rescale all momenta for energy conservation.
65497 LOOP=0
65498 PES=0D0
65499 PQS=0D0
65500 DO 510 I=1,NEP
65501 DO 500 J=1,4
65502 P(N+I,J)=P(IPA(I),J)
65503 500 CONTINUE
65504 PES=PES+P(N+I,4)
65505 PQS=PQS+P(N+I,5)**2/P(N+I,4)
65506 510 CONTINUE
65507 520 LOOP=LOOP+1
65508 FAC=(PS(5)-PQS)/(PES-PQS)
65509 PES=0D0
65510 PQS=0D0
65511 DO 540 I=1,NEP
65512 DO 530 J=1,3
65513 P(N+I,J)=FAC*P(N+I,J)
65514 530 CONTINUE
65515 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)
65516 V(N+I,2)=P(N+I,4)
65517 PES=PES+P(N+I,4)
65518 PQS=PQS+P(N+I,5)**2/P(N+I,4)
65519 540 CONTINUE
65520 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
65521
65522C...Construct transverse momentum for ordinary branching in shower.
65523 ELSE
65524 ZM=V(IM,1)
65525 LOOPPT=0
65526 550 LOOPPT=LOOPPT+1
65527 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
65528 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
65529 IF(PZM.LE.0D0) THEN
65530 PTS=0D0
65531 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
65532 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65533 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
65534 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
65535 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
65536 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
65537 ELSE
65538 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
65539 ENDIF
65540 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
65541 ZM=0.05D0+0.9D0*ZM
65542 GOTO 550
65543 ELSEIF(PTS.LT.0D0) THEN
65544 GOTO 280
65545 ENDIF
65546 PT=SQRT(MAX(0D0,PTS))
65547
65548C...Global statistics.
65549 MINT(353)=MINT(353)+1
65550 VINT(353)=VINT(353)+PT
65551 IF (MINT(353).EQ.1) VINT(358)=PT
65552
65553C...Find coefficient of azimuthal asymmetry due to gluon polarization.
65554 HAZIP=0D0
65555 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
65556 & .AND.IAU.NE.0) THEN
65557 IF(K(IGM,3).NE.0) MAZIP=1
65558 ZAU=V(IGM,1)
65559 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
65560 IF(MAZIP.EQ.0) ZAU=0D0
65561 IF(K(IGM,2).NE.21) THEN
65562 HAZIP=2D0*ZAU/(1D0+ZAU**2)
65563 ELSE
65564 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
65565 ENDIF
65566 IF(K(N+1,2).NE.21) THEN
65567 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
65568 ELSE
65569 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
65570 ENDIF
65571 ENDIF
65572
65573C...Find coefficient of azimuthal asymmetry due to soft gluon
65574C...interference.
65575 HAZIC=0D0
65576 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
65577 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
65578 IF(K(IGM,3).NE.0) MAZIC=N+1
65579 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
65580 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
65581 & ZM.GT.0.5D0) MAZIC=N+2
65582 IF(K(IAU,2).EQ.22) MAZIC=0
65583 ZS=ZM
65584 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
65585 ZGM=V(IGM,1)
65586 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
65587 IF(MAZIC.EQ.0) ZGM=1D0
65588 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
65589 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
65590 HAZIC=MIN(0.95D0,HAZIC)
65591 ENDIF
65592 ENDIF
65593
65594C...Construct energies for ordinary branching in shower.
65595 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
65596 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
65597 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65598 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
65599 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
65600 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
65601 P(N+1,4)=PEM*V(IM,1)
65602 ELSE
65603 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
65604 & SQRT(PMLS)*ZM)/V(IM,5)
65605 ENDIF
65606
65607C...Already predetermined choice of phi angle or not
65608 PHI=PARU(2)*PYR(0)
65609 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
65610 IPSPD=IP1+IM-NS-2
65611 IF(K(IPSPD,4).GT.0) THEN
65612 IPSGD1=K(IPSPD,4)
65613 IF(IM.EQ.NS+2) THEN
65614 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
65615 ELSE
65616 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
65617 ENDIF
65618 ENDIF
65619 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
65620 IPSPD=IP1+IM-NS-2
65621 IF(K(IPSPD,4).GT.0) THEN
65622 IPSGD1=K(IPSPD,4)
65623 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
65624 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
65625 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
65626 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
65627 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
65628 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
65629 ENDIF
65630 ENDIF
65631
65632C...Construct momenta for ordinary branching in shower.
65633 P(N+1,1)=PT*COS(PHI)
65634 P(N+1,2)=PT*SIN(PHI)
65635 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
65636 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
65637 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
65638 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
65639 ELSEIF(PZM.GT.0D0) THEN
65640 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
65641 & 2D0*PEM*P(N+1,4))/PZM
65642 ELSE
65643 P(N+1,3)=0D0
65644 ENDIF
65645 P(N+2,1)=-P(N+1,1)
65646 P(N+2,2)=-P(N+1,2)
65647 P(N+2,3)=PZM-P(N+1,3)
65648 P(N+2,4)=PEM-P(N+1,4)
65649 IF(MSTJ(43).LE.2) THEN
65650 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
65651 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
65652 ENDIF
65653 ENDIF
65654
65655C...Rotate and boost daughters.
65656 IF(IGM.GT.0) THEN
65657 IF(MSTJ(43).LE.2) THEN
65658 BEX=P(IGM,1)/P(IGM,4)
65659 BEY=P(IGM,2)/P(IGM,4)
65660 BEZ=P(IGM,3)/P(IGM,4)
65661 GA=P(IGM,4)/P(IGM,5)
65662 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
65663 & P(IM,4))
65664 ELSE
65665 BEX=0D0
65666 BEY=0D0
65667 BEZ=0D0
65668 GA=1D0
65669 GABEP=0D0
65670 ENDIF
65671 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
65672 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
65673 IF(PTIMB.GT.1D-4) THEN
65674 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
65675 ELSE
65676 PHI=0D0
65677 ENDIF
65678 DO 570 I=N+1,N+2
65679 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
65680 & SIN(THE)*COS(PHI)*P(I,3)
65681 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
65682 & SIN(THE)*SIN(PHI)*P(I,3)
65683 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
65684 DP(4)=P(I,4)
65685 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
65686 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
65687 P(I,1)=DP(1)+DGABP*BEX
65688 P(I,2)=DP(2)+DGABP*BEY
65689 P(I,3)=DP(3)+DGABP*BEZ
65690 P(I,4)=GA*(DP(4)+DBP)
65691 570 CONTINUE
65692 ENDIF
65693
65694C...Weight with azimuthal distribution, if required.
65695 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
65696 DO 580 J=1,3
65697 DPT(1,J)=P(IM,J)
65698 DPT(2,J)=P(IAU,J)
65699 DPT(3,J)=P(N+1,J)
65700 580 CONTINUE
65701 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
65702 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
65703 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
65704 DO 590 J=1,3
65705 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
65706 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
65707 590 CONTINUE
65708 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
65709 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
65710 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
65711 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
65712 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
65713 IF(MAZIP.NE.0) THEN
65714 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
65715 & GOTO 560
65716 ENDIF
65717 IF(MAZIC.NE.0) THEN
65718 IF(MAZIC.EQ.N+2) CAD=-CAD
65719 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
65720 & .LT.PYR(0)) GOTO 560
65721 ENDIF
65722 ENDIF
65723 ENDIF
65724
65725C...Azimuthal anisotropy due to interference with initial state partons.
65726 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
65727 &K(N+2,2).EQ.21)) THEN
65728 III=IM-NS-1
65729 IF(ISII(III).GE.1) THEN
65730 IAZIID=N+1
65731 IF(K(N+1,2).NE.21) IAZIID=N+2
65732 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
65733 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
65734 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
65735 IF(III.EQ.2) THEIID=PARU(1)-THEIID
65736 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
65737 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
65738 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
65739 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
65740 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
65741 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
65742 & .LT.PYR(0)) GOTO 560
65743 ENDIF
65744 ENDIF
65745
65746C...Continue loop over partons that may branch, until none left.
65747 IF(IGM.GE.0) K(IM,1)=14
65748 N=N+NEP
65749 NEP=2
65750 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
65751 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
65752 IF(MSTU(21).GE.1) N=NS
65753 IF(MSTU(21).GE.1) RETURN
65754 ENDIF
65755 GOTO 290
65756
65757C...Set information on imagined shower initiator.
65758 600 IF(NPA.GE.2) THEN
65759 K(NS+1,1)=11
65760 K(NS+1,2)=94
65761 K(NS+1,3)=IP1
65762 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
65763 K(NS+1,4)=NS+2
65764 K(NS+1,5)=NS+1+NPA
65765 IIM=1
65766 ELSE
65767 IIM=0
65768 ENDIF
65769
65770C...Reconstruct string drawing information.
65771 DO 610 I=NS+1+IIM,N
65772 KQ=KCHG(PYCOMP(K(I,2)),2)
65773 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
65774 K(I,1)=1
65775 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
65776 & IABS(K(I,2)).LE.18) THEN
65777 K(I,1)=1
65778 ELSEIF(K(I,1).LE.10) THEN
65779 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
65780 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
65781 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
65782 ID1=MOD(K(I,4),MSTU(5))
65783 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
65784 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
65785 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
65786 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
65787 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
65788 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
65789 K(ID1,4)=K(ID1,4)+MSTU(5)*I
65790 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
65791 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
65792 K(ID2,5)=K(ID2,5)+MSTU(5)*I
65793 ELSE
65794 ID1=MOD(K(I,4),MSTU(5))
65795 ID2=ID1+1
65796 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
65797 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
65798 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
65799 K(ID1,4)=K(ID1,4)+MSTU(5)*I
65800 K(ID1,5)=K(ID1,5)+MSTU(5)*I
65801 ELSE
65802 K(ID1,4)=0
65803 K(ID1,5)=0
65804 ENDIF
65805 K(ID2,4)=0
65806 K(ID2,5)=0
65807 ENDIF
65808 610 CONTINUE
65809
65810C...Transformation from CM frame.
65811 IF(NPA.EQ.1) THEN
65812 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
65813 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
65814 MSTU(33)=1
65815 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
65816 ELSEIF(NPA.EQ.2) THEN
65817 BEX=PS(1)/PS(4)
65818 BEY=PS(2)/PS(4)
65819 BEZ=PS(3)/PS(4)
65820 GA=PS(4)/PS(5)
65821 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
65822 & /(1D0+GA)-P(IPA(1),4))
65823 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
65824 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
65825 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
65826 MSTU(33)=1
65827 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
65828 ELSE
65829 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
65830 & PS(3)/PS(4))
65831 MSTU(33)=1
65832 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
65833 ENDIF
65834
65835C...Decay vertex of shower.
65836 DO 630 I=NS+1,N
65837 DO 620 J=1,5
65838 V(I,J)=V(IP1,J)
65839 620 CONTINUE
65840 630 CONTINUE
65841
65842C...Delete trivial shower, else connect initiators.
65843 IF(N.LE.NS+NPA+IIM) THEN
65844 N=NS
65845 ELSE
65846 DO 640 IP=1,NPA
65847 K(IPA(IP),1)=14
65848 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
65849 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
65850 K(NS+IIM+IP,3)=IPA(IP)
65851 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
65852 IF(K(NS+IIM+IP,1).NE.1) THEN
65853 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
65854 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
65855 ENDIF
65856 640 CONTINUE
65857 ENDIF
65858
65859 RETURN
65860 END
65861
65862C*********************************************************************
65863
65864C...PYPTFS
65865C...Generates pT-ordered timelike final-state parton showers.
65866
65867C...MODE defines how to find radiators and recoilers.
65868C... = 0 : based on colour flow between undecayed partons.
65869C... = 1 : for IPART <= NPARTD only consider primary partons,
65870C... whether decayed or not; else as above.
65871C... = 2 : based on common history, whether decayed or not.
65872
65873 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
65874
65875C...Double precision and integer declarations.
65876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65877 IMPLICIT INTEGER(I-N)
65878 INTEGER PYK,PYCHGE,PYCOMP
65879C...Parameter statement to help give large particle numbers.
65880 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65881 &KEXCIT=4000000,KDIMEN=5000000)
65882C...Parameter statement for maximum size of showers.
65883 PARAMETER (MAXNUR=1000)
65884C...Commonblocks.
65885 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65886 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65887 COMMON/PYCTAG/NCT,MCT(4000,2)
65888 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65889 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65890 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65891 COMMON/PYINT1/MINT(400),VINT(400)
65892 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
65893 &/PYINT1/
65894C...Local arrays.
65895 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
65896 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
65897 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
65898 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
65899C...Statement functions.
65900 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
65901 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
65902
65903C...Initial values. Check that valid system.
65904 PTGEN=0D0
65905 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
65906 &MSTJ(41).NE.12) RETURN
65907 IF(NPART.LE.0) THEN
65908 CALL PYERRM(2,'(PYPTFS:) showering system too small')
65909 RETURN
65910 ENDIF
65911 PT2CMX=PTMAX**2
65912
65913C...Mass thresholds and Lambda for QCD evolution.
65914 PMB=PMAS(5,1)
65915 PMC=PMAS(4,1)
65916 ALAM5=PARJ(81)
65917 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
65918 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
65919 PMBS=PMB**2
65920 PMCS=PMC**2
65921 ALAM5S=ALAM5**2
65922 ALAM4S=ALAM4**2
65923 ALAM3S=ALAM3**2
65924
65925C...Cutoff scale for QCD evolution. Starting pT2.
65926 NFLAV=MAX(0,MIN(5,MSTJ(45)))
65927 PT0C=0.5D0*PARJ(82)
65928 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
65929
65930C...Parameters for QED evolution.
65931 AEM2PI=PARU(101)/PARU(2)
65932 PT0EQ=0.5D0*PARJ(83)
65933 PT0EL=0.5D0*PARJ(90)
65934
65935C...Reset. Remove irrelevent colour tags.
65936 NEVOL=0
65937 DO 100 J=1,4
65938 PSUM(J)=0D0
65939 100 CONTINUE
65940 DO 110 I=MINT(84)+1,N
65941 IF(K(I,2).GT.0.AND.K(I,2).LT.6) K(I,5)=0
65942 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) K(I,4)=0
65943 110 CONTINUE
65944 NPARTS=NPART
65945
65946C...Begin loop to set up showering partons. Sum four-momenta.
65947 DO 210 IP=1,NPART
65948 I=IPART(IP)
65949 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
65950 IF(K(I,1).GT.10) GOTO 210
65951 ELSEIF(K(I,3).GT.MINT(84)) THEN
65952 IF(K(I,3).GT.MINT(84)+2) GOTO 210
65953 ELSE
65954 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
65955 ENDIF
65956 DO 120 J=1,4
65957 PSUM(J)=PSUM(J)+P(I,J)
65958 120 CONTINUE
65959
65960C...Find colour and charge, but skip diquarks.
65961 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
65962 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
65963 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
65964
65965C...Either colour or anticolour charge radiates; for gluon both.
65966 DO 160 JSGCOL=1,-1,-2
65967 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
65968 JCOL=4+(1-JSGCOL)/2
65969 JCOLR=9-JCOL
65970
65971C...Basic info about radiating parton.
65972 NEVOL=NEVOL+1
65973 IPOS(NEVOL)=I
65974 IFLG(NEVOL)=0
65975 ISCOL(NEVOL)=JSGCOL
65976 ISCHG(NEVOL)=0
65977 PTSCA(NEVOL)=PTPART(IP)
65978
65979C...Begin search for colour recoiler when MODE = 0 or 1.
65980 IF(MODE.LE.1) THEN
65981C...Find sister with matching anticolour to the radiating parton.
65982 IROLD=I
65983 IRNEW=K(IROLD,JCOL)/MSTU(5)
65984 MOVE=1
65985
65986C...Skip radiation off loose colour ends.
65987 130 IF(IRNEW.EQ.0) THEN
65988 NEVOL=NEVOL-1
65989 GOTO 160
65990
65991C...Optionally skip radiation on dipole to beam remnant.
65992 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
65993 NEVOL=NEVOL-1
65994 GOTO 160
65995
65996C...For now always skip radiation on dipole to junction.
65997 ELSEIF(K(IRNEW,2).EQ.88) THEN
65998 NEVOL=NEVOL-1
65999 GOTO 160
66000
66001C...For MODE=1: if reached primary then done.
66002 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
66003 & IRNEW.LE.NPARTD) THEN
66004
66005C...If sister stable and points back then done.
66006 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
66007 & THEN
66008 IF(K(IRNEW,1).LT.10) THEN
66009
66010C...If sister unstable then go to her daughter.
66011 ELSE
66012 IROLD=IRNEW
66013 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
66014 MOVE=2
66015 GOTO 130
66016 ENDIF
66017
66018C...If found mother then look for aunt.
66019 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
66020 & IROLD) THEN
66021 IROLD=IRNEW
66022 IRNEW=K(IROLD,JCOL)/MSTU(5)
66023 GOTO 130
66024
66025C...If daughter stable then done.
66026 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
66027 & THEN
66028 IF(K(IRNEW,1).LT.10) THEN
66029
66030C...If daughter unstable then go to granddaughter.
66031 ELSE
66032 IROLD=IRNEW
66033 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
66034 MOVE=2
66035 GOTO 130
66036 ENDIF
66037
66038C...If daughter points to another daughter then done or move up.
66039 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
66040 & IROLD) THEN
66041 IF(K(IRNEW,1).LT.10) THEN
66042 ELSE
66043 IROLD=IRNEW
66044 IRNEW=K(IRNEW,JCOL)/MSTU(5)
66045 MOVE=1
66046 GOTO 130
66047 ENDIF
66048 ENDIF
66049
66050C...Begin search for colour recoiler when MODE = 2.
66051 ELSE
66052 IROLD=I
66053 IRNEW=K(IROLD,JCOL)/MSTU(5)
66054 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
66055C...Step up to mother if radiating parton already branched.
66056 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
66057 IROLD=IRNEW
66058 IRNEW=K(IROLD,JCOL)/MSTU(5)
66059 GOTO 140
66060C...Pick sister by history if no anticolour available.
66061 ELSE
66062 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
66063 IRNEW=IROLD-1
66064 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
66065 & THEN
66066 IRNEW=IROLD+1
66067C...Last resort: pick at random among other primaries.
66068 ELSE
66069 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
66070 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
66071 ENDIF
66072 ENDIF
66073 ENDIF
66074C...Trace down if sister branched.
66075 150 IF(K(IRNEW,1).GT.10) THEN
66076 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
66077 GOTO 150
66078 ENDIF
66079 ENDIF
66080
66081C...Now found other end of colour dipole.
66082 IREC(NEVOL)=IRNEW
66083 ENDIF
66084 160 CONTINUE
66085
66086C...Also electrical charge may radiate; so far only quarks and leptons.
66087 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
66088 & IABS(K(I,2)).LE.18) THEN
66089
66090C...Basic info about radiating parton.
66091 NEVOL=NEVOL+1
66092 IPOS(NEVOL)=I
66093 IFLG(NEVOL)=0
66094 ISCOL(NEVOL)=0
66095 ISCHG(NEVOL)=KCHA
66096 PTSCA(NEVOL)=PTPART(IP)
66097
66098C...Pick nearest (= smallest invariant mass) charged particle
66099C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
66100 IF(MODE.LE.1) THEN
66101 IRNEW=0
66102 PM2MIN=VINT(2)
66103 DO 170 IP2=1,NPART+N-MINT(53)
66104 IF(IP2.EQ.IP) GOTO 170
66105 IF(IP2.LE.NPART) THEN
66106 I2=IPART(IP2)
66107 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
66108 IF(K(I2,1).GT.10) GOTO 170
66109 ELSEIF(K(I2,3).GT.MINT(84)) THEN
66110 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
66111 ELSE
66112 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
66113 ENDIF
66114 ELSE
66115 I2=MINT(53)+IP2-NPART
66116 ENDIF
66117 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
66118 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
66119 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
66120 IF(PM2INV.LT.PM2MIN) THEN
66121 IRNEW=I2
66122 PM2MIN=PM2INV
66123 ENDIF
66124 170 CONTINUE
66125 IF(IRNEW.EQ.0) THEN
66126 NEVOL=NEVOL-1
66127 GOTO 210
66128 ENDIF
66129
66130C...Begin search for charge recoiler when MODE = 2.
66131 ELSE
66132 IROLD=I
66133C...Pick sister by history; step up if parton already branched.
66134 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
66135 IROLD=K(IROLD,3)
66136 GOTO 180
66137 ENDIF
66138 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
66139 IRNEW=IROLD-1
66140 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
66141 IRNEW=IROLD+1
66142C...Last resort: pick at random among other primaries.
66143 ELSE
66144 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
66145 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
66146 ENDIF
66147C...Trace down if sister branched.
66148 190 IF(K(IRNEW,1).GT.10) THEN
66149 DO 200 IR=IRNEW+1,N
66150 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
66151 IRNEW=IR
66152 GOTO 190
66153 ENDIF
66154 200 CONTINUE
66155 ENDIF
66156 ENDIF
66157 IREC(NEVOL)=IRNEW
66158 ENDIF
66159
66160C...End loop to set up showering partons. System invariant mass.
66161 210 CONTINUE
66162 IF(NEVOL.LE.0) RETURN
66163 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
66164
66165C...Check if 3-jet matrix elements to be used.
66166 M3JC=0
66167 ALPHA=0.5D0
66168 NMESYS=0
66169 IF(MSTJ(47).GE.1) THEN
66170
66171C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
66172 KFSRCE=0
66173 IPART1=K(IPART(1),3)
66174 IPART2=K(IPART(2),3)
66175 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
66176 KFSRCE=IABS(K(IPART1,2))
66177 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
66178 IPART1=K(IPART1,3)
66179 GOTO 220
66180 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
66181 IPART2=K(IPART2,3)
66182 GOTO 220
66183 ENDIF
66184 ITYPES=0
66185 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
66186 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
66187 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
66188 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
66189 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
66190 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
66191 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
66192 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
66193
66194C...Identify two primary showerers.
66195 KFLA1=IABS(K(IPART(1),2))
66196 ITYPE1=0
66197 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
66198 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
66199 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
66200 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
66201 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
66202 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
66203 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
66204 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
66205 KFLA2=IABS(K(IPART(2),2))
66206 ITYPE2=0
66207 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
66208 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
66209 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
66210 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
66211 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
66212 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
66213 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
66214 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
66215
66216C...Order of showerers. Presence of gluino.
66217 ITYPMN=MIN(ITYPE1,ITYPE2)
66218 ITYPMX=MAX(ITYPE1,ITYPE2)
66219 IORD=1
66220 IF(ITYPE1.GT.ITYPE2) IORD=2
66221 IGLUI=0
66222 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
66223
66224C...Require exactly two primary showerers for ME corrections.
66225 NPRIM=0
66226 DO 230 I=1,N
66227 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
66228 230 CONTINUE
66229 IF(NPRIM.NE.2) THEN
66230
66231C...Predetermined and default matrix element kinds.
66232 ELSEIF(MSTJ(38).NE.0) THEN
66233 M3JC=MSTJ(38)
66234 ALPHA=PARJ(80)
66235 MSTJ(38)=0
66236 ELSEIF(MSTJ(47).GE.6) THEN
66237 M3JC=MSTJ(47)
66238 ELSE
66239 ICLASS=1
66240 ICOMBI=4
66241
66242C...Vector/axial vector -> q + qbar; q -> q + V.
66243 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
66244 & ITYPES.EQ.3)) THEN
66245 ICLASS=2
66246 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
66247 ICOMBI=1
66248 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
66249 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
66250C...gamma*/Z0: assume e+e- initial state if unknown.
66251 EI=-1D0
66252 IF(KFSRCE.EQ.23) THEN
66253 IANNFL=K(IPART1,3)
66254 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
66255 IF(IANNFL.NE.0) THEN
66256 KANNFL=IABS(K(IANNFL,2))
66257 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
66258 ENDIF
66259 ENDIF
66260 AI=SIGN(1D0,EI+0.1D0)
66261 VI=AI-4D0*EI*PARU(102)
66262 EF=KCHG(KFLA1,1)/3D0
66263 AF=SIGN(1D0,EF+0.1D0)
66264 VF=AF-4D0*EF*PARU(102)
66265 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66266 SH=PSUM(5)**2
66267 SQMZ=PMAS(23,1)**2
66268 SQWZ=PSUM(5)*PMAS(23,2)
66269 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66270 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66271 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66272 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66273 ICOMBI=3
66274 ALPHA=VECT/(VECT+AXIV)
66275 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66276 ICOMBI=4
66277 ENDIF
66278C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66279 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66280 ICLASS=2
66281 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66282 & ITYPES.EQ.1)) THEN
66283 ICLASS=3
66284
66285C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66286 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66287 ICLASS=4
66288 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66289 ICOMBI=1
66290 ELSEIF(KFSRCE.EQ.36) THEN
66291 ICOMBI=2
66292 ENDIF
66293 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66294 & ITYPES.EQ.1)) THEN
66295 ICLASS=5
66296
66297C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66298 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66299 & ITYPES.EQ.3)) THEN
66300 ICLASS=6
66301 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66302 & ITYPES.EQ.2)) THEN
66303 ICLASS=7
66304 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66305 ICLASS=8
66306 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66307 & ITYPES.EQ.2)) THEN
66308 ICLASS=9
66309
66310C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66311 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66312 & ITYPES.EQ.5)) THEN
66313 ICLASS=10
66314 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66315 & ITYPES.EQ.2)) THEN
66316 ICLASS=11
66317 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66318 & ITYPES.EQ.1)) THEN
66319 ICLASS=12
66320
66321C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66322 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66323 ICLASS=13
66324 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66325 & ITYPES.EQ.2)) THEN
66326 ICLASS=14
66327 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66328 & ITYPES.EQ.1)) THEN
66329 ICLASS=15
66330
66331C...g -> ~g + ~g (eikonal approximation).
66332 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66333 ICLASS=16
66334 ENDIF
66335 M3JC=5*ICLASS+ICOMBI
66336 ENDIF
66337
66338C...Store pair that together define matrix element treatment.
66339 IF(M3JC.NE.0) THEN
66340 NMESYS=1
66341 MESYS(NMESYS,0)=M3JC
66342 MESYS(NMESYS,1)=IPART(1)
66343 MESYS(NMESYS,2)=IPART(2)
66344 ENDIF
66345
66346C...Store qqbar or l+l- pairs for QED radiation.
66347 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
66348 NMESYS=NMESYS+1
66349 MESYS(NMESYS,0)=101
66350 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
66351 MESYS(NMESYS,1)=IPART(1)
66352 MESYS(NMESYS,2)=IPART(2)
66353 ENDIF
66354
66355C...Store other qqbar/l+l- pairs from g/gamma branchings.
66356 DO 270 I1=1,N
66357 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
66358 I1M=K(I1,3)
66359 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
66360 I1M=K(I1M,3)
66361 GOTO 240
66362 ENDIF
66363C...Move up this check to avoid out-of-bounds.
66364 IF(I1M.EQ.0) GOTO 270
66365 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
66366 DO 260 I2=I1+1,N
66367 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
66368 I2M=K(I2,3)
66369 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
66370 I2M=K(I2M,3)
66371 GOTO 250
66372 ENDIF
66373 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
66374 NMESYS=NMESYS+1
66375 MESYS(NMESYS,0)=66
66376 MESYS(NMESYS,1)=I1
66377 MESYS(NMESYS,2)=I2
66378 NMESYS=NMESYS+1
66379 MESYS(NMESYS,0)=102
66380 MESYS(NMESYS,1)=I1
66381 MESYS(NMESYS,2)=I2
66382 ENDIF
66383 260 CONTINUE
66384 270 CONTINUE
66385 ENDIF
66386
66387C..Loopback point for counting number of emissions.
66388 NGEN=0
66389 280 NGEN=NGEN+1
66390
66391C...Begin loop to evolve all existing partons, if required.
66392 290 IMX=0
66393 PT2MX=0D0
66394 DO 360 IEVOL=1,NEVOL
66395 IF(IFLG(IEVOL).EQ.0) THEN
66396
66397C...Basic info on radiator and recoil.
66398 I=IPOS(IEVOL)
66399 IR=IREC(IEVOL)
66400 SHT=SHAT(I,IR)
66401 PM2I=P(I,5)**2
66402 PM2R=P(IR,5)**2
66403
66404C...Invariant mass of "dipole".Starting value for pT evolution.
66405 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
66406 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
66407
66408C...Case of evolution by QCD branching.
66409 IF(ISCOL(IEVOL).NE.0) THEN
66410
66411C...Parton-by-parton maximum scale from initial conditions.
66412 IF(MSTP(72).EQ.0) THEN
66413 DO 300 IPRT=1,NPARTS
66414 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
66415 300 CONTINUE
66416 ENDIF
66417
66418C...If kinematically impossible then do not evolve.
66419 IF(PT2.LT.PT2CMN) THEN
66420 IFLG(IEVOL)=-1
66421 GOTO 360
66422 ENDIF
66423
66424C...Check if part of system for which ME corrections should be applied.
66425 IMESYS=0
66426 DO 310 IME=1,NMESYS
66427 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
66428 & MESYS(IME,0).LT.100) IMESYS=IME
66429 310 CONTINUE
66430
66431C...Special flag for colour octet states.
66432 MOCT=0
66433 IF(K(I,2).EQ.21) MOCT=1
66434 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
66435
66436C...Upper estimate for matrix element weighting and colour factor.
66437C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
66438 WTPSGL=2D0
66439 COLFAC=4D0/3D0
66440 IF(MOCT.GE.1) COLFAC=3D0/2D0
66441 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
66442 WTPSQQ=0.5D0*0.5D0*NFLAV
66443
66444C...Determine overestimated z range: switch at c and b masses.
66445 320 IZRG=1
66446 PT2MNE=PT2CMN
66447 B0=27D0/6D0
66448 ALAMS=ALAM3S
66449 IF(PT2.GT.1.01D0*PMCS) THEN
66450 IZRG=2
66451 PT2MNE=PMCS
66452 B0=25D0/6D0
66453 ALAMS=ALAM4S
66454 ENDIF
66455 IF(PT2.GT.1.01D0*PMBS) THEN
66456 IZRG=3
66457 PT2MNE=PMBS
66458 B0=23D0/6D0
66459 ALAMS=ALAM5S
66460 ENDIF
66461 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
66462 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
66463
66464C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
66465 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
66466 EVCOEF=EVEMGL
66467 IF(MOCT.EQ.1) THEN
66468 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
66469 EVCOEF=EVCOEF+EVEMQQ
66470 ENDIF
66471
66472C...Pick pT2 (in overestimated z range).
66473 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
66474
66475C...Loopback if crossed c/b mass thresholds.
66476 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
66477 PT2=PMBS
66478 GOTO 320
66479 ENDIF
66480 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
66481 PT2=PMCS
66482 GOTO 320
66483 ENDIF
66484
66485C...Finish if below lower cutoff.
66486 IF(PT2.LT.PT2CMN) THEN
66487 IFLG(IEVOL)=-1
66488 GOTO 360
66489 ENDIF
66490
66491C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
66492 IFLAG=1
66493 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
66494
66495C...Pick z: dz/(1-z) or dz.
66496 IF(IFLAG.EQ.1) THEN
66497 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
66498 ELSE
66499 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
66500 ENDIF
66501
66502C...Loopback if outside allowed range for given pT2.
66503 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
66504 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
66505 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
66506 PM2=PM2I+PT2/(Z*(1D0-Z))
66507 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
66508
66509C...No weighting for primary partons; to be done later on.
66510 IF(IMESYS.GT.0) THEN
66511
66512C...Weighting of q->qg/X->Xg branching.
66513 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
66514 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
66515
66516C...Weighting of g->gg branching.
66517 ELSEIF(IFLAG.EQ.1) THEN
66518 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
66519
66520C...Flavour choice and weighting of g->qqbar branching.
66521 ELSE
66522 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
66523 PMQ=PMAS(KFQ,1)
66524 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
66525 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
66526 IF(WTME.LT.PYR(0)) GOTO 330
66527 IFLAG=10+KFQ
66528 ENDIF
66529
66530C...Case of evolution by QED branching.
66531 ELSEIF(ISCHG(IEVOL).NE.0) THEN
66532
66533C...If kinematically impossible then do not evolve.
66534 PT2EMN=PT0EQ**2
66535 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
66536 IF(PT2.LT.PT2EMN) THEN
66537 IFLG(IEVOL)=-1
66538 GOTO 360
66539 ENDIF
66540
66541C...Check if part of system for which ME corrections should be applied.
66542 IMESYS=0
66543 DO 340 IME=1,NMESYS
66544 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
66545 & MESYS(IME,0).GT.100) IMESYS=IME
66546 340 CONTINUE
66547
66548C...Charge. Matrix element weighting factor.
66549 CHG=ISCHG(IEVOL)/3D0
66550 WTPSGA=2D0
66551
66552C...Determine overestimated z range. Find evolution coefficient.
66553 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
66554 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
66555 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
66556
66557C...Pick pT2 (in overestimated z range).
66558 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
66559
66560C...Finish if below lower cutoff.
66561 IF(PT2.LT.PT2EMN) THEN
66562 IFLG(IEVOL)=-1
66563 GOTO 360
66564 ENDIF
66565
66566C...Pick z: dz/(1-z).
66567 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
66568
66569C...Loopback if outside allowed range for given pT2.
66570 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
66571 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
66572 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
66573 PM2=PM2I+PT2/(Z*(1D0-Z))
66574 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
66575
66576C...Weighting by branching kernel, except if ME weighting later.
66577 IF(IMESYS.EQ.0) THEN
66578 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
66579 ENDIF
66580 IFLAG=3
66581 ENDIF
66582
66583C...Save acceptable branching.
66584 IFLG(IEVOL)=IFLAG
66585 IMESAV(IEVOL)=IMESYS
66586 PT2SAV(IEVOL)=PT2
66587 ZSAV(IEVOL)=Z
66588 SHTSAV(IEVOL)=SHT
66589 ENDIF
66590
66591C...Check if branching has highest pT.
66592 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
66593 IMX=IEVOL
66594 PT2MX=PT2SAV(IEVOL)
66595 ENDIF
66596 360 CONTINUE
66597
66598C...Finished if no more branchings to be done.
66599 IF(IMX.EQ.0) GOTO 480
66600
66601C...Restore info on hardest branching to be processed.
66602 I=IPOS(IMX)
66603 IR=IREC(IMX)
66604 KCOL=ISCOL(IMX)
66605 KCHA=ISCHG(IMX)
66606 IMESYS=IMESAV(IMX)
66607 PT2=PT2SAV(IMX)
66608 Z=ZSAV(IMX)
66609 SHT=SHTSAV(IMX)
66610 PM2I=P(I,5)**2
66611 PM2R=P(IR,5)**2
66612 PM2=PM2I+PT2/(Z*(1D0-Z))
66613
66614C...Special flag for colour octet states.
66615 MOCT=0
66616 IF(K(I,2).EQ.21) MOCT=1
66617 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
66618
66619C...Restore further info for g->qqbar branching.
66620 KFQ=0
66621 IF(IFLG(IMX).GT.10) THEN
66622 KFQ=IFLG(IMX)-10
66623 PMQ=PMAS(KFQ,1)
66624 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
66625 ENDIF
66626
66627C...For branching g include azimuthal asymmetries from polarization.
66628 ASYPOL=0D0
66629 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
66630C...Trace grandmother via intermediate recoil copies.
66631 KFGM=0
66632 IM=I
66633 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
66634 & K(IM,3).GT.0) THEN
66635 IM=K(IM,3)
66636 IF(IM.GT.MINT(84)) GOTO 370
66637 ENDIF
66638 IGM=K(IM,3)
66639 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
66640 & KFGM=IABS(K(IGM,2))
66641C...Define approximate energy sharing by identifying aunt.
66642 IAU=IM+1
66643 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
66644 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
66645 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
66646C...Coefficient from gluon production.
66647 IF(KFGM.LE.6) THEN
66648 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
66649 ELSE
66650 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
66651 ENDIF
66652C...Coefficient from gluon decay.
66653 IF(KFQ.EQ.0) THEN
66654 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
66655 ELSE
66656 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
66657 ENDIF
66658 ENDIF
66659 ENDIF
66660
66661C...Create new slots for branching products and recoil.
66662 INEW=N+1
66663 IGNEW=N+2
66664 IRNEW=N+3
66665 N=N+3
66666
66667C...Set status, flavour and mother of new ones.
66668 K(INEW,1)=K(I,1)
66669 K(IGNEW,1)=3
66670 IF(KCHA.NE.0) K(IGNEW,1)=1
66671 K(IRNEW,1)=K(IR,1)
66672 IF(KFQ.EQ.0) THEN
66673 K(INEW,2)=K(I,2)
66674 K(IGNEW,2)=21
66675 IF(KCHA.NE.0) K(IGNEW,2)=22
66676 ELSE
66677 K(INEW,2)=-ISIGN(KFQ,KCOL)
66678 K(IGNEW,2)=-K(INEW,2)
66679 ENDIF
66680 K(IRNEW,2)=K(IR,2)
66681 K(INEW,3)=I
66682 K(IGNEW,3)=I
66683 K(IRNEW,3)=IR
66684
66685C...Find rest frame and angles of branching+recoil.
66686 DO 380 J=1,5
66687 P(INEW,J)=P(I,J)
66688 P(IGNEW,J)=0D0
66689 P(IRNEW,J)=P(IR,J)
66690 380 CONTINUE
66691 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
66692 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
66693 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
66694 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
66695 PHI=PYANGL(P(INEW,1),P(INEW,2))
66696 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
66697
66698C...Derive kinematics of branching: generics (like g->gg).
66699 DO 390 J=1,4
66700 P(INEW,J)=0D0
66701 P(IRNEW,J)=0D0
66702 390 CONTINUE
66703 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
66704 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
66705 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
66706 PTCOR=SQRT(MAX(0D0,PT2COR))
66707 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
66708 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
66709C...Specific kinematics reduction for q->qg with m_q > 0.
66710 IF(MOCT.NE.1) THEN
66711 PTCOR=(1D0-PM2I/PM2)*PTCOR
66712 PZN=PZN+PM2I*PZG/PM2
66713 PZG=(1D0-PM2I/PM2)*PZG
66714C...Specific kinematics reduction for g->qqbar with m_q > 0.
66715 ELSEIF(KFQ.NE.0) THEN
66716 P(INEW,5)=PMQ
66717 P(IGNEW,5)=PMQ
66718 PTCOR=ROOTQQ*PTCOR
66719 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
66720 PZG=PZM-PZN
66721 ENDIF
66722
66723C...Pick phi and construct kinematics of branching.
66724 400 PHIROT=PARU(2)*PYR(0)
66725 P(INEW,1)=PTCOR*COS(PHIROT)
66726 P(INEW,2)=PTCOR*SIN(PHIROT)
66727 P(INEW,3)=PZN
66728 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
66729 P(IGNEW,1)=-P(INEW,1)
66730 P(IGNEW,2)=-P(INEW,2)
66731 P(IGNEW,3)=PZG
66732 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
66733 P(IRNEW,1)=0D0
66734 P(IRNEW,2)=0D0
66735 P(IRNEW,3)=-PZM
66736 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
66737
66738C...Boost branching system to lab frame.
66739 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
66740
66741C...Renew choice of phi angle according to polarization asymmetry.
66742 IF(ABS(ASYPOL).GT.1D-3) THEN
66743 DO 410 J=1,3
66744 DPT(1,J)=P(I,J)
66745 DPT(2,J)=P(IAU,J)
66746 DPT(3,J)=P(INEW,J)
66747 410 CONTINUE
66748 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
66749 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
66750 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
66751 DO 420 J=1,3
66752 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
66753 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
66754 420 CONTINUE
66755 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
66756 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
66757 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
66758 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
66759 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
66760 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
66761 & GOTO 400
66762 ENDIF
66763 ENDIF
66764
66765C...Matrix element corrections for primary partons when requested.
66766 IF(IMESYS.GT.0) THEN
66767 M3JC=MESYS(IMESYS,0)
66768
66769C...Identify recoiling partner and set up three-body kinematics.
66770 IRP=MESYS(IMESYS,1)
66771 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
66772 IF(IRP.EQ.IR) IRP=IRNEW
66773 DO 430 J=1,4
66774 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
66775 430 CONTINUE
66776 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
66777 & PSUM(3)**2))
66778 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
66779 & PSUM(3)*P(INEW,3))/PSUM(5)**2
66780 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
66781 & PSUM(3)*P(IRP,3))/PSUM(5)**2
66782 X3=2D0-X1-X2
66783 R1ME=P(INEW,5)/PSUM(5)
66784 R2ME=P(IRP,5)/PSUM(5)
66785
66786C...Matrix elements for gluon emission.
66787 IF(M3JC.LT.100) THEN
66788
66789C...Call ME, with right order important for two inequivalent showerers.
66790 IF(MESYS(IMESYS,IORD).EQ.I) THEN
66791 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
66792 ELSE
66793 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
66794 ENDIF
66795
66796C...Split up total ME when two radiating partons.
66797 ISPRAD=1
66798 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
66799 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
66800 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
66801 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66802 & MAX(1D-10,2D0-X1-X2)
66803
66804C...Evaluate shower rate.
66805 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
66806 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66807 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
66808
66809C...Matrix elements for photon emission: still rather primitive.
66810 ELSE
66811
66812C...For generic charge combination currently only massless expression.
66813 IF(M3JC.EQ.101) THEN
66814 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
66815 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
66816 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66817 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
66818
66819C...For flavour neutral system assume vector source and include masses.
66820 ELSE
66821 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
66822 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
66823 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
66824 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66825 ENDIF
66826 ENDIF
66827
66828C...Perform weighting with W_ME/W_PS.
66829 IF(WME.LT.PYR(0)*WPS) THEN
66830 N=N-3
66831 IFLG(IMX)=0
66832 GOTO 290
66833 ENDIF
66834 ENDIF
66835
66836C...Now for sure accepted branching. Save highest pT.
66837 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
66838
66839C...Update status for obsolete ones. Bookkkep the moved original parton
66840C...and new daughter (arbitrary choice for g->gg or g->qqbar).
66841C...Do not bookkeep radiated photon, since it cannot radiate further.
66842 K(I,1)=K(I,1)+10
66843 K(IR,1)=K(IR,1)+10
66844 DO 440 IP=1,NPART
66845 IF(IPART(IP).EQ.I) IPART(IP)=INEW
66846 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
66847 440 CONTINUE
66848 IF(KCHA.EQ.0) THEN
66849 NPART=NPART+1
66850 IPART(NPART)=IGNEW
66851 ENDIF
66852
66853C...Initialize colour flow of branching.
66854C...Use both old and new style colour tags for flexibility.
66855 K(INEW,4)=0
66856 K(IGNEW,4)=0
66857 K(INEW,5)=0
66858 K(IGNEW,5)=0
66859 JCOLP=4+(1-KCOL)/2
66860 JCOLN=9-JCOLP
66861 MCT(INEW,1)=0
66862 MCT(INEW,2)=0
66863 MCT(IGNEW,1)=0
66864 MCT(IGNEW,2)=0
66865 MCT(IRNEW,1)=0
66866 MCT(IRNEW,2)=0
66867
66868C...Trivial colour flow for l->lgamma and q->qgamma.
66869 IF(IABS(KCHA).EQ.3) THEN
66870 K(I,4)=INEW
66871 K(I,5)=IGNEW
66872 ELSEIF(KCHA.NE.0) THEN
66873 IF(K(I,4).NE.0) THEN
66874 K(I,4)=K(I,4)+INEW
66875 K(INEW,4)=MSTU(5)*I
66876 MCT(INEW,1)=MCT(I,1)
66877 ENDIF
66878 IF(K(I,5).NE.0) THEN
66879 K(I,5)=K(I,5)+INEW
66880 K(INEW,5)=MSTU(5)*I
66881 MCT(INEW,2)=MCT(I,2)
66882 ENDIF
66883
66884C...Set colour flow for q->qg and g->gg.
66885 ELSEIF(KFQ.EQ.0) THEN
66886 K(I,JCOLP)=K(I,JCOLP)+IGNEW
66887 K(IGNEW,JCOLP)=MSTU(5)*I
66888 K(INEW,JCOLP)=MSTU(5)*IGNEW
66889 K(IGNEW,JCOLN)=MSTU(5)*INEW
66890 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
66891 NCT=NCT+1
66892 MCT(INEW,JCOLP-3)=NCT
66893 MCT(IGNEW,JCOLN-3)=NCT
66894 IF(MOCT.GE.1) THEN
66895 K(I,JCOLN)=K(I,JCOLN)+INEW
66896 K(INEW,JCOLN)=MSTU(5)*I
66897 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
66898 ENDIF
66899
66900C...Set colour flow for g->qqbar.
66901 ELSE
66902 K(I,JCOLN)=K(I,JCOLN)+INEW
66903 K(INEW,JCOLN)=MSTU(5)*I
66904 K(I,JCOLP)=K(I,JCOLP)+IGNEW
66905 K(IGNEW,JCOLP)=MSTU(5)*I
66906 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
66907 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
66908 ENDIF
66909
66910C...Daughter info for colourless recoiling parton.
66911 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
66912 K(IR,4)=IRNEW
66913 K(IR,5)=IRNEW
66914 K(IRNEW,4)=0
66915 K(IRNEW,5)=0
66916
66917C...Colour of recoiling parton sails through unchanged.
66918 ELSE
66919 IF(K(IR,4).NE.0) THEN
66920 K(IR,4)=K(IR,4)+IRNEW
66921 K(IRNEW,4)=MSTU(5)*IR
66922 MCT(IRNEW,1)=MCT(IR,1)
66923 ENDIF
66924 IF(K(IR,5).NE.0) THEN
66925 K(IR,5)=K(IR,5)+IRNEW
66926 K(IRNEW,5)=MSTU(5)*IR
66927 MCT(IRNEW,2)=MCT(IR,2)
66928 ENDIF
66929 ENDIF
66930
66931C...Vertex information trivial.
66932 DO 450 J=1,5
66933 V(INEW,J)=V(I,J)
66934 V(IGNEW,J)=V(I,J)
66935 V(IRNEW,J)=V(IR,J)
66936 450 CONTINUE
66937
66938C...Update list of old radiators.
66939 DO 460 IEVOL=1,NEVOL
66940 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
66941 IPOS(IEVOL)=INEW
66942 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
66943 IREC(IEVOL)=IRNEW
66944 IFLG(IEVOL)=0
66945 ELSEIF(IPOS(IEVOL).EQ.I) THEN
66946 IPOS(IEVOL)=INEW
66947 IFLG(IEVOL)=0
66948 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
66949 IPOS(IEVOL)=IRNEW
66950 IREC(IEVOL)=INEW
66951 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
66952 IFLG(IEVOL)=0
66953 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
66954 IPOS(IEVOL)=IRNEW
66955 IFLG(IEVOL)=0
66956 ENDIF
66957C...Update links of old connected partons.
66958 IF(IREC(IEVOL).EQ.I) THEN
66959 IREC(IEVOL)=INEW
66960 IFLG(IEVOL)=0
66961 ELSEIF(IREC(IEVOL).EQ.IR) THEN
66962 IREC(IEVOL)=IRNEW
66963 IFLG(IEVOL)=0
66964 ENDIF
66965 460 CONTINUE
66966
66967C...q->qg or g->gg: create new gluon radiators.
66968 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
66969 NEVOL=NEVOL+1
66970 IPOS(NEVOL)=INEW
66971 IREC(NEVOL)=IGNEW
66972 IFLG(NEVOL)=0
66973 ISCOL(NEVOL)=KCOL
66974 ISCHG(NEVOL)=0
66975 PTSCA(NEVOL)=SQRT(PT2)
66976 NEVOL=NEVOL+1
66977 IPOS(NEVOL)=IGNEW
66978 IREC(NEVOL)=INEW
66979 IFLG(NEVOL)=0
66980 ISCOL(NEVOL)=-KCOL
66981 ISCHG(NEVOL)=0
66982 PTSCA(NEVOL)=PTSCA(NEVOL-1)
66983 ENDIF
66984
66985C...Update matrix elements parton list and add new for g/gamma->qqbar.
66986 DO 470 IME=1,NMESYS
66987 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
66988 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
66989 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
66990 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
66991 470 CONTINUE
66992 IF(KFQ.NE.0) THEN
66993 NMESYS=NMESYS+1
66994 MESYS(NMESYS,0)=66
66995 MESYS(NMESYS,1)=INEW
66996 MESYS(NMESYS,2)=IGNEW
66997 NMESYS=NMESYS+1
66998 MESYS(NMESYS,0)=102
66999 MESYS(NMESYS,1)=INEW
67000 MESYS(NMESYS,2)=IGNEW
67001 ENDIF
67002
67003C...Global statistics.
67004 MINT(353)=MINT(353)+1
67005 VINT(353)=VINT(353)+PTCOR
67006 IF (MINT(353).EQ.1) VINT(358)=PTCOR
67007
67008C...Loopback for more emissions if enough space.
67009 PT2CMX=PT2
67010 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
67011 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
67012 GOTO 280
67013 ELSE
67014 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
67015 ENDIF
67016
67017C...Done.
67018 480 CONTINUE
67019
67020 RETURN
67021 END
67022
67023C*********************************************************************
67024
67025C...PYMAEL
67026C...Auxiliary to PYSHOW and PYPTFS.
67027C...Matrix elements for gluon (or photon) emission from
67028C...a two-body state; to be used by the parton shower routine.
67029C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
67030C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
67031C... = (alpha-strong/2 pi) * CF * PYMAEL,
67032C...i.e. normalization is such that one recovers the familiar
67033C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
67034C...Coupling structure:
67035C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
67036C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
67037C... = 16-19 : q -> q V
67038C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
67039C... = 26-29 : q -> q S
67040C... = 31-34 : V -> ~q ~qbar (~q = squark)
67041C... = 36-39 : ~q -> ~q V
67042C... = 41-44 : S -> ~q ~qbar
67043C... = 46-49 : ~q -> ~q S
67044C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
67045C... = 56-59 : ~q -> q chi
67046C... = 61-64 : q -> ~q chi
67047C... = 66-69 : ~g -> q ~qbar
67048C... = 71-74 : ~q -> q ~g
67049C... = 76-79 : q -> ~q ~g
67050C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
67051C...Note that the order of the decay products is important.
67052C...In each set of four, the variants are ordered as:
67053C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
67054C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
67055C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
67056C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
67057
67058 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
67059
67060C...Double precision and integer declarations.
67061 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67062 IMPLICIT INTEGER(I-N)
67063
67064C...Check input values. Return zero outside allowed phase space.
67065 PYMAEL=0D0
67066 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
67067 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
67068 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
67069 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
67070 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
67071 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
67072
67073C...Initial values and flags.
67074 ICLASS=NI/5
67075 ICOMBI=NI-5*ICLASS
67076 ISSET1=0
67077 ISSET2=0
67078 ISSET4=0
67079
67080C... Phase space.
67081 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
67082
67083C...Eikonal expression; also acts as default.
67084 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
67085 RLO=PS
67086 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
67087 ANUM=0D0
67088 ELSEIF(ICOMBI.EQ.2) THEN
67089 ANUM=(2D0-X1-X2)**2
67090 ELSEIF(ICOMBI.EQ.3) THEN
67091 ANUM=ALPCOR*(2D0-X1-X2)**2
67092 ELSE
67093 ANUM=0.5D0*(2D0-X1-X2)**2
67094 ENDIF
67095 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
67096 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
67097 & R1**2/(1D0+R2**2-R1**2-X2)**2-
67098 & R2**2/(1D0+R1**2-R2**2-X1)**2)
67099 ICOMBI=0
67100
67101C...V -> q qbar (V = gamma*/Z0/W+-/...).
67102 ELSEIF(ICLASS.EQ.2) THEN
67103 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67104 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
67105 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
67106 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
67107 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
67108 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
67109 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
67110 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
67111 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
67112 & (-1+R1**2-R2**2+X2)**2
67113 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
67114 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
67115 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
67116 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
67117 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
67118 & -X1-X2)**2+X1*(2-X1-X2)**2)/
67119 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67120 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
67121 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
67122 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
67123 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
67124 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
67125 RFO1=RFO1/2.D0
67126 ISSET1=1
67127 ENDIF
67128 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67129 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
67130 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
67131 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
67132 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
67133 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
67134 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
67135 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
67136 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
67137 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
67138 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
67139 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
67140 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
67141 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
67142 & -X1-X2)**2+X1*(2-X1-X2)**2)/
67143 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67144 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
67145 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
67146 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
67147 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
67148 & +X2)/(-1-R1**2+R2**2+X1)**2
67149 RFO2=RFO2/2.D0
67150 ISSET2=1
67151 ENDIF
67152 IF(ICOMBI.EQ.4) THEN
67153 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
67154 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
67155 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
67156 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
67157 & (-1-R1**2+R2**2+X1)**2
67158 RFO4=RFO4
67159 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
67160 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
67161 & -R1**2*X2**2+X1*X2**2)/
67162 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67163 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
67164 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
67165 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
67166 & (-1+R1**2-R2**2+X2)**2
67167 RFO4=RFO4/2.D0
67168 ISSET4=1
67169 ENDIF
67170
67171C...q -> q V.
67172 ELSEIF(ICLASS.EQ.3) THEN
67173 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67174 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
67175 & +R1**2*R2**2-2D0*R2**4)
67176 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
67177 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
67178 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
67179 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
67180 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
67181 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
67182 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
67183 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
67184 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
67185 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
67186 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
67187 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
67188 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
67189 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
67190 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
67191 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
67192 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
67193 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
67194 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
67195 ISSET1=1
67196 ENDIF
67197 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67198 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
67199 & +R1**2*R2**2-2D0*R2**4)
67200 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
67201 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
67202 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
67203 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
67204 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
67205 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
67206 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67207 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
67208 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
67209 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
67210 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
67211 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
67212 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
67213 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
67214 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
67215 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
67216 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
67217 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
67218 & +X1*X2**2)/(-2+X1+X2)**2
67219 ISSET2=1
67220 ENDIF
67221 IF(ICOMBI.EQ.4) THEN
67222 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
67223 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
67224 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
67225 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
67226 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
67227 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67228 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
67229 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
67230 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
67231 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
67232 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
67233 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
67234 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
67235 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
67236 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
67237 & +X1*X2**2)/(2-X1-X2)**2
67238 ISSET4=1
67239 ENDIF
67240
67241C...S -> q qbar (S = h0/H0/A0/H+-/...).
67242 ELSEIF(ICLASS.EQ.4) THEN
67243 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67244 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
67245 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67246 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67247 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67248 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
67249 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
67250 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67251 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67252 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
67253 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67254 ISSET1=1
67255 ENDIF
67256 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67257 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
67258 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67259 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67260 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67261 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67262 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
67263 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67264 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
67265 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
67266 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
67267 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67268 ISSET2=1
67269 ENDIF
67270 IF(ICOMBI.EQ.4) THEN
67271 RLO4=PS*(1D0-R1**2-R2**2)
67272 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
67273 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67274 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
67275 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
67276 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67277 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
67278 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67279 ISSET4=1
67280 ENDIF
67281
67282C...q -> q S.
67283 ELSEIF(ICLASS.EQ.5) THEN
67284 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67285 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
67286 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
67287 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
67288 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
67289 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67290 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
67291 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
67292 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67293 & (-1+R1**2-R2**2+X2)**2
67294 ISSET1=1
67295 ENDIF
67296 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67297 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
67298 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
67299 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
67300 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
67301 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67302 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
67303 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
67304 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67305 & (-1+R1**2-R2**2+X2)**2
67306 ISSET2=1
67307 ENDIF
67308 IF(ICOMBI.EQ.4) THEN
67309 RLO4=PS*(1D0+R1**2-R2**2)
67310 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
67311 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
67312 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
67313 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
67314 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
67315 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
67316 ISSET4=1
67317 ENDIF
67318
67319C...V -> ~q ~qbar (~q = squark).
67320 ELSEIF(ICLASS.EQ.6) THEN
67321 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
67322 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
67323 & (-1-R1**2+R2**2+X1)**2
67324 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
67325 & (-1-R1**2+R2**2+X1)
67326 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
67327 & /(-1+R1**2-R2**2+X2)**2
67328 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
67329 & (-1+R1**2-R2**2+X2)
67330 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
67331 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
67332 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
67333 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67334 ISSET1=1
67335
67336C...~q -> ~q V.
67337 ELSEIF(ICLASS.EQ.7) THEN
67338 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
67339 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
67340 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
67341 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
67342 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
67343 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
67344 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
67345 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
67346 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
67347 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
67348 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
67349 & (3*(-2+X1+X2))
67350 RFO1=3D0*RFO1/8D0
67351 ISSET1=1
67352
67353C...S -> ~q ~qbar.
67354 ELSEIF(ICLASS.EQ.8) THEN
67355 RLO1=PS
67356 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
67357 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
67358 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
67359 & -R1**2*X2**2+X1*X2**2)/
67360 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
67361 RFO1=2D0*RFO1
67362 ISSET1=1
67363
67364C...~q -> ~q S.
67365 ELSEIF(ICLASS.EQ.9) THEN
67366 RLO1=PS
67367 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
67368 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67369 & -(X1+X2)/(-2+X1+X2)**2
67370 ISSET1=1
67371
67372C...chi -> q ~qbar (chi = neutralino/chargino).
67373 ELSEIF(ICLASS.EQ.10) THEN
67374 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67375 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
67376 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
67377 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
67378 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
67379 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67380 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
67381 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67382 & (-1+R1**2-R2**2+X2)**2
67383 ISSET1=1
67384 ENDIF
67385 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67386 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
67387 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
67388 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
67389 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
67390 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67391 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
67392 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67393 & (-1+R1**2-R2**2+X2)**2
67394 ISSET2=1
67395 ENDIF
67396 IF(ICOMBI.EQ.4) THEN
67397 RLO4=PS*(1+R1**2-R2**2)
67398 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
67399 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
67400 & +X2+R1**2*X2-X1*X2/2)/
67401 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
67402 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
67403 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
67404 ISSET4=1
67405 ENDIF
67406
67407C...~q -> q chi.
67408 ELSEIF(ICLASS.EQ.11) THEN
67409 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67410 RLO1=PS*(1D0-(R1+R2)**2)
67411 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
67412 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67413 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
67414 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67415 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
67416 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
67417 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67418 ISSET1=1
67419 ENDIF
67420 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67421 RLO2=PS*(1D0-(R1-R2)**2)
67422 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
67423 & (-2+X1+X2)**2
67424 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67425 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
67426 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
67427 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
67428 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
67429 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
67430 ISSET2=1
67431 ENDIF
67432 IF(ICOMBI.EQ.4) THEN
67433 RLO4=PS*(1D0-R1**2-R2**2)
67434 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
67435 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
67436 & +3*R1**2*X2-R2**2*X2-X1*X2)/
67437 & (-1+R1**2-R2**2+X2)**2
67438 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
67439 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
67440 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67441 ISSET4=1
67442 ENDIF
67443
67444C...q -> ~q chi.
67445 ELSEIF(ICLASS.EQ.12) THEN
67446 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67447 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
67448 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
67449 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
67450 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
67451 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
67452 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
67453 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67454 ISSET1=1
67455 END IF
67456 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67457 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
67458 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
67459 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
67460 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
67461 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
67462 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
67463 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67464 ISSET2=1
67465 END IF
67466 IF(ICOMBI.EQ.4) THEN
67467 RLO4=PS*(1D0-R1**2+R2**2)
67468 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
67469 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
67470 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
67471 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
67472 & +R1**2*X2-X1*X2/2-X2**2/2)/
67473 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
67474 ISSET4=1
67475 END IF
67476
67477C...~g -> q ~qbar.
67478 ELSEIF(ICLASS.EQ.13) THEN
67479 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67480 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
67481 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
67482 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
67483 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
67484 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
67485 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
67486 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
67487 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
67488 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
67489 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
67490 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
67491 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
67492 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67493 & (3*(-1+R1**2-R2**2+X2)**2)
67494 RFO1=3D0*RFO1/4D0
67495 ISSET1=1
67496 ENDIF
67497 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67498 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
67499 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
67500 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
67501 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
67502 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
67503 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
67504 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
67505 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
67506 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
67507 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
67508 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67509 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
67510 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
67511 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67512 & (3*(-1+R1**2-R2**2+X2)**2)
67513 RFO2=3D0*RFO2/4D0
67514 ISSET2=1
67515 ENDIF
67516 IF(ICOMBI.EQ.4) THEN
67517 RLO4=PS*(1D0+R1**2-R2**2)
67518 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
67519 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
67520 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
67521 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
67522 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
67523 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67524 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
67525 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67526 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
67527 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
67528 & (3*(-1+R1**2-R2**2+X2)**2)
67529 RFO4=3D0*RFO4/8D0
67530 ISSET4=1
67531 ENDIF
67532
67533C...~q -> q ~g.
67534 ELSEIF(ICLASS.EQ.14) THEN
67535 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67536 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
67537 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
67538 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67539 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67540 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
67541 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
67542 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
67543 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
67544 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
67545 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
67546 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
67547 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
67548 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
67549 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
67550 RFO1=RFO1
67551 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
67552 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
67553 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67554 RFO1=9D0*RFO1/64D0
67555 ISSET1=1
67556 ENDIF
67557 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67558 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
67559 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
67560 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
67561 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
67562 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
67563 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
67564 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
67565 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
67566 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
67567 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
67568 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
67569 RFO2=RFO2
67570 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
67571 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
67572 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
67573 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
67574 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
67575 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67576 RFO2=9D0*RFO2/64D0
67577 ISSET2=1
67578 ENDIF
67579 IF(ICOMBI.EQ.4) THEN
67580 RLO4=PS*(1-R1**2-R2**2)
67581 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
67582 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
67583 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
67584 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
67585 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
67586 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
67587 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
67588 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
67589 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
67590 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
67591 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
67592 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
67593 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
67594 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
67595 RFO4=9D0*RFO4/128D0
67596 ISSET4=1
67597 ENDIF
67598
67599C...q -> ~q ~g.
67600 ELSEIF(ICLASS.EQ.15) THEN
67601 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
67602 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
67603 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
67604 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
67605 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
67606 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
67607 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
67608 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
67609 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
67610 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
67611 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
67612 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
67613 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
67614 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
67615 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
67616 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67617 RFO1=9D0*RFO1/32D0
67618 ISSET1=1
67619 END IF
67620 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
67621 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
67622 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
67623 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
67624 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
67625 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
67626 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
67627 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
67628 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
67629 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
67630 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
67631 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
67632 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
67633 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
67634 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
67635 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67636 RFO2=9D0*RFO2/32D0
67637 ISSET2=1
67638 END IF
67639 IF(ICOMBI.EQ.4) THEN
67640 RLO4=PS*(1D0-R1**2+R2**2)
67641 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
67642 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
67643 & -R2**2*X2/2-X1*X2/2)/
67644 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
67645 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
67646 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
67647 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
67648 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
67649 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
67650 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
67651 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
67652 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
67653 RFO4=9D0*RFO4/64D0
67654 ISSET4=1
67655 END IF
67656
67657C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
67658 ELSEIF(ICLASS.EQ.16) THEN
67659 RLO=PS
67660 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
67661 ANUM=0D0
67662 ELSEIF(ICOMBI.EQ.2) THEN
67663 ANUM=(2D0-X1-X2)**2
67664 ELSEIF(ICOMBI.EQ.3) THEN
67665 ANUM=ALPCOR*(2D0-X1-X2)**2
67666 ELSE
67667 ANUM=0.5D0*(2D0-X1-X2)**2
67668 ENDIF
67669 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
67670 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
67671 & R1**2/(1D0+R2**2-R1**2-X2)**2-
67672 & R2**2/(1D0+R1**2-R2**2-X1)**2)
67673 RFO=9D0*RFO/4D0
67674 ICOMBI=0
67675 ENDIF
67676
67677C...Find relevant LO and FO expression.
67678 IF(ICOMBI.EQ.0) THEN
67679 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
67680 RLO=RLO1
67681 RFO=RFO1
67682 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
67683 RLO=RLO2
67684 RFO=RFO2
67685 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
67686 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
67687 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
67688 ELSEIF(ISSET4.EQ.1) THEN
67689 RLO=RLO4
67690 RFO=RFO4
67691 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
67692 RLO=0.5D0*(RLO1+RLO2)
67693 RFO=0.5D0*(RFO1+RFO2)
67694 ELSEIF(ISSET1.EQ.1) THEN
67695 RLO=RLO1
67696 RFO=RFO1
67697 ELSE
67698 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
67699 RLO=1D0
67700 RFO=0D0
67701 ENDIF
67702
67703C...Output.
67704 PYMAEL=RFO/RLO
67705
67706 RETURN
67707 END
67708
67709C*********************************************************************
67710
67711C...PYBOEI
67712C...Modifies an event so as to approximately take into account
67713C...Bose-Einstein effects according to a simple phenomenological
67714C...parametrization.
67715
67716 SUBROUTINE PYBOEI(NSAV)
67717
67718C...Double precision and integer declarations.
67719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67720 IMPLICIT INTEGER(I-N)
67721 INTEGER PYK,PYCHGE,PYCOMP
67722C...Parameter statement to help give large particle numbers.
67723 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67724 &KEXCIT=4000000,KDIMEN=5000000)
67725C...Commonblocks.
67726 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67727 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67728 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67729 COMMON/PYINT1/MINT(400),VINT(400)
67730 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
67731C...Local arrays and data.
67732 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
67733 &BEIW(100),BEI3W(100)
67734 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
67735C...Statement function: squared invariant mass.
67736 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
67737 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
67738
67739C...Boost event to overall CM frame. Calculate CM energy.
67740 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
67741 DO 100 J=1,4
67742 DPS(J)=0D0
67743 100 CONTINUE
67744 DO 120 I=1,N
67745 KFA=IABS(K(I,2))
67746 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
67747 & .AND.K(I,3).GT.0) THEN
67748 KFMA=IABS(K(K(I,3),2))
67749 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
67750 ENDIF
67751 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
67752 DO 110 J=1,4
67753 DPS(J)=DPS(J)+P(I,J)
67754 110 CONTINUE
67755 120 CONTINUE
67756 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
67757 &-DPS(3)/DPS(4))
67758 PECM=0D0
67759 DO 130 I=1,N
67760 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
67761 130 CONTINUE
67762
67763C...Check if we have separated strings
67764
67765C...Reserve copy of particles by species at end of record.
67766 IWP=0
67767 IWN=0
67768 NBE(0)=N+MSTU(3)
67769 NMAX=NBE(0)
67770 SMMIN=PECM
67771 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
67772 NBE(IBE)=NBE(IBE-1)
67773 DO 180 I=NSAV+1,N
67774 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
67775 DO 140 IIBE=1,IBE-1
67776 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
67777 140 CONTINUE
67778 ELSE
67779 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
67780 ENDIF
67781 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
67782 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
67783 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
67784 RETURN
67785 ENDIF
67786 NBE(IBE)=NBE(IBE)+1
67787 NMAX=NBE(IBE)
67788 K(NBE(IBE),1)=I
67789 K(NBE(IBE),2)=0
67790 K(NBE(IBE),3)=0
67791 K(NBE(IBE),4)=0
67792 K(NBE(IBE),5)=0
67793 P(NBE(IBE),1)=0.0D0
67794 P(NBE(IBE),2)=0.0D0
67795 P(NBE(IBE),3)=0.0D0
67796 P(NBE(IBE),4)=0.0D0
67797 P(NBE(IBE),5)=0.0D0
67798 SMMIN=MIN(SMMIN,P(I,5))
67799C...Check if particles comes from different W's or Z's
67800 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
67801 IM=I
67802 150 IF(K(IM,3).GT.0) THEN
67803 IM=K(IM,3)
67804 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
67805 K(NBE(IBE),5)=IM
67806 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
67807 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
67808 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
67809 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
67810 ENDIF
67811 ENDIF
67812C...Check if particles comes from different strings.
67813 IF(PARJ(94).GT.0.0D0) THEN
67814 IM=I
67815 160 IF(K(IM,3).GT.0) THEN
67816 IM=K(IM,3)
67817 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
67818 K(NBE(IBE),5)=IM
67819 ENDIF
67820 ENDIF
67821 DO 170 J=1,3
67822 P(NBE(IBE),J)=0D0
67823 V(NBE(IBE),J)=0D0
67824 170 CONTINUE
67825 P(NBE(IBE),5)=-1.0D0
67826 180 CONTINUE
67827 190 CONTINUE
67828 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
67829
67830C...Calculate separation between W+ and W- or between two Z0's.
67831C...No separation if there has been re-connections.
67832 SIGW=PARJ(93)
67833 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
67834 IF(K(IWP,2).EQ.23) THEN
67835 DMW=PMAS(23,1)
67836 DGW=PMAS(23,2)
67837 ELSE
67838 DMW=PMAS(24,1)
67839 DGW=PMAS(24,2)
67840 ENDIF
67841 DMP=P(IWP,5)
67842 DMN=P(IWN,5)
67843 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
67844 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
67845 TAUP=-TAUPD*LOG(PYR(IDUM))
67846 TAUN=-TAUND*LOG(PYR(IDUM))
67847 DXP=TAUP*PYP(IWP,8)/DMP
67848 DXN=TAUN*PYP(IWN,8)/DMN
67849 DX=DXP+DXN
67850 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
67851 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
67852 ENDIF
67853
67854C...Add separation between strings.
67855 IF(PARJ(94).GT.0.0D0) THEN
67856 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
67857 IWP=-1
67858 IWN=-1
67859 ENDIF
67860
67861 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
67862 DO 220 IBE=1,MIN(9,MSTJ(52))
67863 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
67864 Q2MIN=PECM**2
67865 I1=K(I1M,1)
67866 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
67867 IF(I2M.EQ.I1M) GOTO 200
67868 I2=K(I2M,1)
67869 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
67870 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
67871 & (P(I1,5)+P(I2,5))**2
67872 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
67873 Q2MIN=Q2
67874 ENDIF
67875 200 CONTINUE
67876 P(I1M,5)=Q2MIN
67877 210 CONTINUE
67878 220 CONTINUE
67879 ENDIF
67880
67881C...Tabulate integral for subsequent momentum shift.
67882 DO 400 IBE=1,MIN(9,MSTJ(52))
67883 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
67884 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
67885 & .LE.1) GOTO 270
67886 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
67887 & NBE(7)-NBE(6)).LE.1) GOTO 270
67888 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
67889 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
67890 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
67891 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
67892 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
67893 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
67894 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
67895 QDELW=0.1D0*MIN(PMHQ,SIGW)
67896 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
67897 IF(MSTJ(51).EQ.1) THEN
67898 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
67899 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
67900 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
67901 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
67902 BEEX=EXP(0.5D0*QDEL/PARJ(93))
67903 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
67904 BEEXW=EXP(0.5D0*QDELW/SIGW)
67905 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
67906 BERT=EXP(-QDEL/PARJ(93))
67907 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
67908 BERTW=EXP(-QDELW/SIGW)
67909 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
67910 ELSE
67911 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
67912 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
67913 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
67914 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
67915 ENDIF
67916 DO 230 IBIN=1,NBIN
67917 QBIN=QDEL*(IBIN-0.5D0)
67918 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
67919 IF(MSTJ(51).EQ.1) THEN
67920 BEEX=BEEX*BERT
67921 BEI(IBIN)=BEI(IBIN)*BEEX
67922 ELSE
67923 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
67924 ENDIF
67925 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
67926 230 CONTINUE
67927 DO 240 IBIN=1,NBIN3
67928 QBIN=QDEL3*(IBIN-0.5D0)
67929 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
67930 IF(MSTJ(51).EQ.1) THEN
67931 BEEX3=BEEX3*BERT3
67932 BEI3(IBIN)=BEI3(IBIN)*BEEX3
67933 ELSE
67934 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
67935 ENDIF
67936 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
67937 240 CONTINUE
67938 DO 250 IBIN=1,NBINW
67939 QBIN=QDELW*(IBIN-0.5D0)
67940 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
67941 IF(MSTJ(51).EQ.1) THEN
67942 BEEXW=BEEXW*BERTW
67943 BEIW(IBIN)=BEIW(IBIN)*BEEXW
67944 ELSE
67945 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
67946 ENDIF
67947 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
67948 250 CONTINUE
67949 DO 260 IBIN=1,NBIN3W
67950 QBIN=QDEL3W*(IBIN-0.5D0)
67951 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
67952 & SQRT(QBIN**2+PMHQ**2)
67953 IF(MSTJ(51).EQ.1) THEN
67954 BEEX3W=BEEX3W*BERT3W
67955 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
67956 ELSE
67957 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
67958 ENDIF
67959 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
67960 260 CONTINUE
67961
67962C...Loop through particle pairs and find old relative momentum.
67963 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
67964 I1=K(I1M,1)
67965 DO 380 I2M=I1M+1,NBE(IBE)
67966 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
67967 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
67968 I2=K(I2M,1)
67969 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
67970 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
67971 IF(Q2OLD.LE.0.0D0) GOTO 380
67972 QOLD=SQRT(Q2OLD)
67973
67974C...Calculate new relative momentum.
67975 QMOV=0.0D0
67976 QMOV3=0.0D0
67977 QMOVW=0.0D0
67978 QMOV3W=0.0D0
67979 IF(QOLD.LT.1D-3*QDEL) THEN
67980 GOTO 280
67981 ELSEIF(QOLD.LE.QDEL) THEN
67982 QMOV=QOLD/3D0
67983 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
67984 RBIN=QOLD/QDEL
67985 IBIN=RBIN
67986 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
67987 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
67988 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
67989 ELSE
67990 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
67991 ENDIF
67992 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
67993 IF(QOLD.LT.1D-3*QDEL3) THEN
67994 GOTO 290
67995 ELSEIF(QOLD.LE.QDEL3) THEN
67996 QMOV3=QOLD/3D0
67997 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
67998 RBIN3=QOLD/QDEL3
67999 IBIN3=RBIN3
68000 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
68001 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
68002 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
68003 ELSE
68004 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68005 ENDIF
68006 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
68007 RSCALE=1.0D0
68008 IF(MSTJ(54).EQ.2)
68009 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
68010 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
68011 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
68012
68013 IF(QOLD.LT.1D-3*QDELW) THEN
68014 GOTO 300
68015 ELSEIF(QOLD.LE.QDELW) THEN
68016 QMOVW=QOLD/3D0
68017 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
68018 RBINW=QOLD/QDELW
68019 IBINW=RBINW
68020 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
68021 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
68022 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
68023 ELSE
68024 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68025 ENDIF
68026 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
68027 IF(QOLD.LT.1D-3*QDEL3W) THEN
68028 GOTO 310
68029 ELSEIF(QOLD.LE.QDEL3W) THEN
68030 QMOV3W=QOLD/3D0
68031 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
68032 RBIN3W=QOLD/QDEL3W
68033 IBIN3W=RBIN3W
68034 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
68035 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
68036 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68037 ELSE
68038 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
68039 ENDIF
68040 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
68041 IF(MSTJ(54).EQ.2)
68042 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
68043
68044 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
68045 DO 330 J=1,3
68046 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
68047 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
68048 330 CONTINUE
68049 IF(MSTJ(54).GE.1) THEN
68050 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
68051 DO 340 J=1,3
68052 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
68053 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
68054 340 CONTINUE
68055 ELSEIF(MSTJ(54).LE.-1) THEN
68056 EDEL=P(I1,4)+P(I2,4)-
68057 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
68058 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
68059 & (P(I1,3)-P(I2,3))**2
68060 WMAX=-1.0D20
68061 MI3=0
68062 MI4=0
68063 S12=SDIP(I1,I2)
68064 SM1=(P(I1,5)+SMMIN)**2
68065 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
68066 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
68067 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
68068 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
68069 & K(I3M,5).NE.K(I1M,5)) GOTO 360
68070 I3=K(I3M,1)
68071 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
68072 S13=SDIP(I1,I3)
68073 S23=SDIP(I2,I3)
68074 SM3=(P(I3,5)+SMMIN)**2
68075 IF(MSTJ(54).EQ.-2) THEN
68076 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
68077 & S23*MIN(SM1,SM3))*SM1)
68078 ELSE
68079 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
68080 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
68081 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
68082 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
68083 ENDIF
68084 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
68085 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
68086 & GOTO 360
68087 ELSE
68088 IF(WMAX*WI.GE.1.0) GOTO 360
68089 ENDIF
68090 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
68091 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
68092 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
68093 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
68094 & K(I4M,5).NE.K(I1M,5)) GOTO 350
68095 I4=K(I4M,1)
68096 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
68097 & GOTO 350
68098 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
68099 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
68100 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
68101 & GOTO 350
68102 IF(MSTJ(54).EQ.-2) THEN
68103 S14=SDIP(I1,I4)
68104 S24=SDIP(I2,I4)
68105 S34=SDIP(I3,I4)
68106 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
68107 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
68108 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
68109 W=MIN(W,MIN(S23,S24)*S13*S14)
68110 W=1.0D0/W
68111 ELSE
68112C...weight=1-cos(theta)/mtot2
68113 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
68114 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
68115 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
68116 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
68117 W=1.0D0/S1234
68118 IF(W.LE.WMAX) GOTO 350
68119 ENDIF
68120 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
68121 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
68122 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
68123 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
68124 IF(W.LE.WMAX) GOTO 350
68125 MI3=I3M
68126 MI4=I4M
68127 WMAX=W
68128 350 CONTINUE
68129 360 CONTINUE
68130 IF(MI4.EQ.0) GOTO 380
68131 I3=K(MI3,1)
68132 I4=K(MI4,1)
68133 EOLD=P(I3,4)+P(I4,4)
68134 ENEW=EOLD+EDEL
68135 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
68136 & (P(I3,3)+P(I4,3))**2
68137 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
68138 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
68139 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
68140 DO 370 J=1,3
68141 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
68142 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
68143 370 CONTINUE
68144 ENDIF
68145 380 CONTINUE
68146 390 CONTINUE
68147 400 CONTINUE
68148
68149C...Shift momenta and recalculate energies.
68150 ESUMP=0.0D0
68151 ESUM=0.0D0
68152 PROD=0.0D0
68153 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
68154 I=K(IM,1)
68155 ESUMP=ESUMP+P(I,4)
68156 DO 410 J=1,3
68157 P(I,J)=P(I,J)+P(IM,J)
68158 410 CONTINUE
68159 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
68160 ESUM=ESUM+P(I,4)
68161 DO 420 J=1,3
68162 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
68163 420 CONTINUE
68164 430 CONTINUE
68165
68166 PARJ(96)=0.0D0
68167 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
68168 440 ALPHA=(ESUMP-ESUM)/PROD
68169 PARJ(96)=PARJ(96)+ALPHA
68170 PROD=0.0D0
68171 ESUM=0.0D0
68172 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
68173 I=K(IM,1)
68174 DO 450 J=1,3
68175 P(I,J)=P(I,J)+ALPHA*V(IM,J)
68176 450 CONTINUE
68177 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
68178 ESUM=ESUM+P(I,4)
68179 DO 460 J=1,3
68180 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
68181 460 CONTINUE
68182 470 CONTINUE
68183 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
68184 & GOTO 440
68185 ENDIF
68186
68187C...Rescale all momenta for energy conservation.
68188 PES=0D0
68189 PQS=0D0
68190 DO 480 I=1,N
68191 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
68192 PES=PES+P(I,4)
68193 PQS=PQS+P(I,5)**2/P(I,4)
68194 480 CONTINUE
68195 PARJ(95)=PES-PECM
68196 FAC=(PECM-PQS)/(PES-PQS)
68197 DO 500 I=1,N
68198 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
68199 DO 490 J=1,3
68200 P(I,J)=FAC*P(I,J)
68201 490 CONTINUE
68202 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
68203 500 CONTINUE
68204
68205C...Boost back to correct reference frame.
68206 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
68207 DO 520 I=1,N
68208 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
68209 520 CONTINUE
68210
68211 RETURN
68212 END
68213
68214C*********************************************************************
68215
68216C...PYBESQ
68217C...Calculates the momentum shift in a system of two particles assuming
68218C...the relative momentum squared should be shifted to Q2NEW. NI is the
68219C...last position occupied in /PYJETS/.
68220
68221 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
68222
68223C...Double precision and integer declarations.
68224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68225 IMPLICIT INTEGER(I-N)
68226 INTEGER PYK,PYCHGE,PYCOMP
68227C...Parameter statement to help give large particle numbers.
68228 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68229 &KEXCIT=4000000,KDIMEN=5000000)
68230C...Commonblocks.
68231 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68233 SAVE /PYJETS/,/PYDAT1/
68234C...Local arrays and data.
68235 DIMENSION DP(5)
68236 SAVE HC1
68237
68238 IF(MSTJ(55).EQ.0) THEN
68239 DQ2=Q2NEW-Q2OLD
68240 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
68241 & (P(I1,3)-P(I2,3))**2
68242 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
68243 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
68244 SE=P(I1,4)+P(I2,4)
68245 DE=P(I1,4)-P(I2,4)
68246 DQ2SE=DQ2+SE**2
68247 DA=SE*DE*DP12-DP2*DQ2SE
68248 DB=DP2*DQ2SE-DP12**2
68249 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
68250 DO 100 J=1,3
68251 PD=HA*(P(I1,J)-P(I2,J))
68252 P(NI+1,J)=PD
68253 P(NI+2,J)=-PD
68254 100 CONTINUE
68255 RETURN
68256 ENDIF
68257
68258 K(NI+1,1)=1
68259 K(NI+2,1)=1
68260 DO 110 J=1,5
68261 P(NI+1,J)=P(I1,J)
68262 P(NI+2,J)=P(I2,J)
68263 DP(J)=P(I1,J)+P(I2,J)
68264 110 CONTINUE
68265
68266C...Boost to cms and rotate first particle to z-axis
68267 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
68268 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
68269 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
68270 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
68271 S=Q2NEW+(P(I1,5)+P(I2,5))**2
68272 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
68273 P(NI+1,1)=0.0D0
68274 P(NI+1,2)=0.0D0
68275 P(NI+1,3)=PZ
68276 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
68277 P(NI+2,1)=0.0D0
68278 P(NI+2,2)=0.0D0
68279 P(NI+2,3)=-PZ
68280 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
68281 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
68282 CALL PYROBO(NI+1,NI+2,THE,PHI,
68283 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
68284
68285 DO 120 J=1,3
68286 P(NI+1,J)=P(NI+1,J)-P(I1,J)
68287 P(NI+2,J)=P(NI+2,J)-P(I2,J)
68288 120 CONTINUE
68289
68290 RETURN
68291 END
68292
68293C*********************************************************************
68294
68295C...PYMASS
68296C...Gives the mass of a particle/parton.
68297
68298 FUNCTION PYMASS(KF)
68299
68300C...Double precision and integer declarations.
68301 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68302 IMPLICIT INTEGER(I-N)
68303 INTEGER PYK,PYCHGE,PYCOMP
68304C...Commonblocks.
68305 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68306 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68307 SAVE /PYDAT1/,/PYDAT2/
68308
68309C...Reset variables. Compressed code. Special case for popcorn diquarks.
68310 PYMASS=0D0
68311 KFA=IABS(KF)
68312 KC=PYCOMP(KF)
68313 IF(KC.EQ.0) THEN
68314 MSTJ(93)=0
68315 RETURN
68316 ENDIF
68317
68318C...Guarantee use of constituent masses for internal checks.
68319 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
68320 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
68321 IF(KFA.LE.5) THEN
68322 PYMASS=PARF(100+KFA)
68323 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
68324 ELSEIF(KFA.LE.10) THEN
68325 PYMASS=PMAS(KFA,1)
68326 ELSEIF(MSTJ(93).EQ.1) THEN
68327 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
68328 ELSE
68329 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
68330 ENDIF
68331
68332C...Other masses can be read directly off table.
68333 ELSE
68334 PYMASS=PMAS(KC,1)
68335 ENDIF
68336
68337C...Optional mass broadening according to truncated Breit-Wigner
68338C...(either in m or in m^2).
68339 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
68340 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
68341 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
68342 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
68343 ELSE
68344 PM0=PYMASS
68345 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
68346 & (PM0*PMAS(KC,2)))
68347 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
68348 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
68349 & (PMUPP-PMLOW)*PYR(0))))
68350 ENDIF
68351 ENDIF
68352 MSTJ(93)=0
68353
68354 RETURN
68355 END
68356
68357C*********************************************************************
68358
68359C...PYMRUN
68360C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
68361C...for Higgs couplings. Everything else sent on to PYMASS.
68362
68363 FUNCTION PYMRUN(KF,Q2)
68364
68365C...Double precision and integer declarations.
68366 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68367 IMPLICIT INTEGER(I-N)
68368 INTEGER PYK,PYCHGE,PYCOMP
68369C...Commonblocks.
68370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68372 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68373 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
68374
68375C...Most masses not handled here.
68376 KFA=IABS(KF)
68377 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
68378 PYMRUN=PYMASS(KF)
68379
68380C...Current-algebra masses, but no Q2 dependence.
68381 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
68382 PYMRUN=PARF(90+KFA)
68383
68384C...Running current-algebra masses.
68385 ELSE
68386 AS=PYALPS(Q2)
68387 PYMRUN=PARF(90+KFA)*
68388 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
68389 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
68390 ENDIF
68391
68392 RETURN
68393 END
68394
68395C*********************************************************************
68396
68397C...PYNAME
68398C...Gives the particle/parton name as a character string.
68399
68400 SUBROUTINE PYNAME(KF,CHAU)
68401
68402C...Double precision and integer declarations.
68403 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68404 IMPLICIT INTEGER(I-N)
68405 INTEGER PYK,PYCHGE,PYCOMP
68406C...Commonblocks.
68407 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68408 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68409 COMMON/PYDAT4/CHAF(500,2)
68410 CHARACTER CHAF*16
68411 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
68412C...Local character variable.
68413 CHARACTER CHAU*16
68414
68415C...Read out code with distinction particle/antiparticle.
68416 CHAU=' '
68417 KC=PYCOMP(KF)
68418 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
68419
68420
68421 RETURN
68422 END
68423
68424C*********************************************************************
68425
68426C...PYCHGE
68427C...Gives three times the charge for a particle/parton.
68428
68429 FUNCTION PYCHGE(KF)
68430
68431C...Double precision and integer declarations.
68432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68433 IMPLICIT INTEGER(I-N)
68434 INTEGER PYK,PYCHGE,PYCOMP
68435C...Commonblocks.
68436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68437 SAVE /PYDAT2/
68438
68439C...Read out charge and change sign for antiparticle.
68440 PYCHGE=0
68441 KC=PYCOMP(KF)
68442 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
68443
68444 RETURN
68445 END
68446
68447C*********************************************************************
68448
68449C...PYCOMP
68450C...Compress the standard KF codes for use in mass and decay arrays;
68451C...also checks whether a given code actually is defined.
68452
68453 FUNCTION PYCOMP(KF)
68454
68455C...Double precision and integer declarations.
68456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68457 IMPLICIT INTEGER(I-N)
68458 INTEGER PYK,PYCHGE,PYCOMP
68459C...Commonblocks.
68460 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68461 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68462 SAVE /PYDAT1/,/PYDAT2/
68463C...Local arrays and saved data.
68464 DIMENSION KFORD(100:500),KCORD(101:500)
68465 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
68466
68467C...Whenever necessary reorder codes for faster search.
68468 IF(MSTU(20).EQ.0) THEN
68469 NFORD=100
68470 KFORD(100)=0
68471 DO 120 I=101,500
68472 KFA=KCHG(I,4)
68473 IF(KFA.LE.100) GOTO 120
68474 NFORD=NFORD+1
68475 DO 100 I1=NFORD-1,0,-1
68476 IF(KFA.GE.KFORD(I1)) GOTO 110
68477 KFORD(I1+1)=KFORD(I1)
68478 KCORD(I1+1)=KCORD(I1)
68479 100 CONTINUE
68480 110 KFORD(I1+1)=KFA
68481 KCORD(I1+1)=I
68482 120 CONTINUE
68483 MSTU(20)=1
68484 KFLAST=0
68485 KCLAST=0
68486 ENDIF
68487
68488C...Fast action if same code as in latest call.
68489 IF(KF.EQ.KFLAST) THEN
68490 PYCOMP=KCLAST
68491 RETURN
68492 ENDIF
68493
68494C...Starting values. Remove internal diquark flags.
68495 PYCOMP=0
68496 KFA=IABS(KF)
68497 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
68498 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
68499
68500C...Simple cases: direct translation.
68501 IF(KFA.GT.KFORD(NFORD)) THEN
68502 ELSEIF(KFA.LE.100) THEN
68503 PYCOMP=KFA
68504
68505C...Else binary search.
68506 ELSE
68507 IMIN=100
68508 IMAX=NFORD+1
68509 130 IAVG=(IMIN+IMAX)/2
68510 IF(KFORD(IAVG).GT.KFA) THEN
68511 IMAX=IAVG
68512 IF(IMAX.GT.IMIN+1) GOTO 130
68513 ELSEIF(KFORD(IAVG).LT.KFA) THEN
68514 IMIN=IAVG
68515 IF(IMAX.GT.IMIN+1) GOTO 130
68516 ELSE
68517 PYCOMP=KCORD(IAVG)
68518 ENDIF
68519 ENDIF
68520
68521C...Check if antiparticle allowed.
68522 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
68523 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
68524 ENDIF
68525
68526C...Save codes for possible future fast action.
68527 KFLAST=KF
68528 KCLAST=PYCOMP
68529
68530 RETURN
68531 END
68532
68533C*********************************************************************
68534
68535C...PYERRM
68536C...Informs user of errors in program execution.
68537
68538 SUBROUTINE PYERRM(MERR,CHMESS)
68539
68540C...Double precision and integer declarations.
68541 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68542 IMPLICIT INTEGER(I-N)
68543 INTEGER PYK,PYCHGE,PYCOMP
68544C...Commonblocks.
68545 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68546 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68547 SAVE /PYJETS/,/PYDAT1/
68548C...Local character variable.
68549 CHARACTER CHMESS*(*)
68550
68551C...Write first few warnings, then be silent.
68552 IF(MERR.LE.10) THEN
68553 MSTU(27)=MSTU(27)+1
68554 MSTU(28)=MERR
68555 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
68556 & MERR,MSTU(31),CHMESS
68557
68558C...Write first few errors, then be silent or stop program.
68559 ELSEIF(MERR.LE.20) THEN
68560 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
68561 MSTU(30)=MSTU(30)+1
68562 MSTU(24)=MERR-10
68563 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
68564 & MERR-10,MSTU(31),CHMESS
68565 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
68566 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
68567 WRITE(MSTU(11),5200)
68568 IF(MERR.NE.17) CALL PYLIST(2)
68569 STOP
68570 ENDIF
68571
68572C...Stop program in case of irreparable error.
68573 ELSE
68574 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
68575 STOP
68576 ENDIF
68577
68578C...Formats for output.
68579 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
68580 &' PYEXEC calls:'/5X,A)
68581 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
68582 &' PYEXEC calls:'/5X,A)
68583 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
68584 &'event!')
68585 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
68586 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
68587
68588 RETURN
68589 END
68590
68591C*********************************************************************
68592
68593C...PYALEM
68594C...Calculates the running alpha_electromagnetic.
68595
68596 FUNCTION PYALEM(Q2)
68597
68598C...Double precision and integer declarations.
68599 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68600 IMPLICIT INTEGER(I-N)
68601 INTEGER PYK,PYCHGE,PYCOMP
68602C...Commonblocks.
68603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68604 SAVE /PYDAT1/
68605
68606C...Calculate real part of photon vacuum polarization.
68607C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
68608C...For hadrons use parametrization of H. Burkhardt et al.
68609C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
68610 AEMPI=PARU(101)/(3D0*PARU(1))
68611 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
68612 RPIGG=0D0
68613 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
68614 RPIGG=0D0
68615 ELSEIF(MSTU(101).EQ.2) THEN
68616 RPIGG=1D0-PARU(101)/PARU(103)
68617 ELSEIF(Q2.LT.0.09D0) THEN
68618 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
68619 ELSEIF(Q2.LT.9D0) THEN
68620 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
68621 & 0.00238D0*LOG(1D0+3.927D0*Q2)
68622 ELSEIF(Q2.LT.1D4) THEN
68623 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
68624 & 0.00299D0*LOG(1D0+Q2)
68625 ELSE
68626 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
68627 & 0.00293D0*LOG(1D0+Q2)
68628 ENDIF
68629
68630C...Calculate running alpha_em.
68631 PYALEM=PARU(101)/(1D0-RPIGG)
68632 PARU(108)=PYALEM
68633
68634 RETURN
68635 END
68636
68637C*********************************************************************
68638
68639C...PYALPS
68640C...Gives the value of alpha_strong.
68641
68642 FUNCTION PYALPS(Q2)
68643
68644C...Double precision and integer declarations.
68645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68646 IMPLICIT INTEGER(I-N)
68647 INTEGER PYK,PYCHGE,PYCOMP
68648C...Commonblocks.
68649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68650 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68651 SAVE /PYDAT1/,/PYDAT2/
68652C...Coefficients for second-order threshold matching.
68653C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
68654 DIMENSION STEPDN(6),STEPUP(6)
68655c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
68656c &(2D0*321D0/3703D0),0D0/
68657c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
68658c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
68659 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
68660 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
68661
68662C...Constant alpha_strong trivial. Pick artificial Lambda.
68663 IF(MSTU(111).LE.0) THEN
68664 PYALPS=PARU(111)
68665 MSTU(118)=MSTU(112)
68666 PARU(117)=0.2D0
68667 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
68668 & ((33D0-2D0*MSTU(112))*PARU(111)))
68669 PARU(118)=PARU(111)
68670 RETURN
68671 ENDIF
68672
68673C...Find effective Q2, number of flavours and Lambda.
68674 Q2EFF=Q2
68675 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
68676 NF=MSTU(112)
68677 ALAM2=PARU(112)**2
68678 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
68679 Q2THR=PARU(113)*PMAS(NF,1)**2
68680 IF(Q2EFF.LT.Q2THR) THEN
68681 NF=NF-1
68682 Q2RAT=Q2THR/ALAM2
68683 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
68684 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
68685 GOTO 100
68686 ENDIF
68687 ENDIF
68688 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
68689 Q2THR=PARU(113)*PMAS(NF+1,1)**2
68690 IF(Q2EFF.GT.Q2THR) THEN
68691 NF=NF+1
68692 Q2RAT=Q2THR/ALAM2
68693 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
68694 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
68695 GOTO 110
68696 ENDIF
68697 ENDIF
68698 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
68699 PARU(117)=SQRT(ALAM2)
68700
68701C...Evaluate first or second order alpha_strong.
68702 B0=(33D0-2D0*NF)/6D0
68703 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
68704 IF(MSTU(111).EQ.1) THEN
68705 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
68706 ELSE
68707 B1=(153D0-19D0*NF)/6D0
68708 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
68709 & (B0**2*ALGQ)))
68710 ENDIF
68711 MSTU(118)=NF
68712 PARU(118)=PYALPS
68713
68714 RETURN
68715 END
68716
68717C*********************************************************************
68718
68719C...PYANGL
68720C...Reconstructs an angle from given x and y coordinates.
68721
68722 FUNCTION PYANGL(X,Y)
68723
68724C...Double precision and integer declarations.
68725 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68726 IMPLICIT INTEGER(I-N)
68727 INTEGER PYK,PYCHGE,PYCOMP
68728C...Commonblocks.
68729 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68730 SAVE /PYDAT1/
68731
68732 PYANGL=0D0
68733 R=SQRT(X**2+Y**2)
68734 IF(R.LT.1D-20) RETURN
68735 IF(ABS(X)/R.LT.0.8D0) THEN
68736 PYANGL=SIGN(ACOS(X/R),Y)
68737 ELSE
68738 PYANGL=ASIN(Y/R)
68739 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
68740 PYANGL=PARU(1)-PYANGL
68741 ELSEIF(X.LT.0D0) THEN
68742 PYANGL=-PARU(1)-PYANGL
68743 ENDIF
68744 ENDIF
68745
68746 RETURN
68747 END
68748
68749C*********************************************************************
68750
68751C...PYR
68752C...Generates random numbers uniformly distributed between
68753C...0 and 1, excluding the endpoints.
68754
68755 FUNCTION PYR(IDUMMY)
68756
68757C...Double precision and integer declarations.
68758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68759 IMPLICIT INTEGER(I-N)
68760 INTEGER PYK,PYCHGE,PYCOMP
68761C...Commonblocks.
68762 COMMON/PYDATR/MRPY(6),RRPY(100)
68763 SAVE /PYDATR/
68764C...Equivalence between commonblock and local variables.
68765 EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
68766 &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
68767 &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
68768
68769C...Initialize generation from given seed.
68770 IF(MRPY2.EQ.0) THEN
68771 IJ=MOD(MRPY1/30082,31329)
68772 KL=MOD(MRPY1,30082)
68773 I=MOD(IJ/177,177)+2
68774 J=MOD(IJ,177)+2
68775 K=MOD(KL/169,178)+1
68776 L=MOD(KL,169)
68777 DO 110 II=1,97
68778 S=0D0
68779 T=0.5D0
68780 DO 100 JJ=1,48
68781 M=MOD(MOD(I*J,179)*K,179)
68782 I=J
68783 J=K
68784 K=M
68785 L=MOD(53*L+1,169)
68786 IF(MOD(L*M,64).GE.32) S=S+T
68787 T=0.5D0*T
68788 100 CONTINUE
68789 RRPY(II)=S
68790 110 CONTINUE
68791 TWOM24=1D0
68792 DO 120 I24=1,24
68793 TWOM24=0.5D0*TWOM24
68794 120 CONTINUE
68795 RRPY98=362436D0*TWOM24
68796 RRPY99=7654321D0*TWOM24
68797 RRPY00=16777213D0*TWOM24
68798 MRPY2=1
68799 MRPY3=0
68800 MRPY4=97
68801 MRPY5=33
68802 ENDIF
68803
68804C...Generate next random number.
68805 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
68806 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
68807 RRPY(MRPY4)=RUNI
68808 MRPY4=MRPY4-1
68809 IF(MRPY4.EQ.0) MRPY4=97
68810 MRPY5=MRPY5-1
68811 IF(MRPY5.EQ.0) MRPY5=97
68812 RRPY98=RRPY98-RRPY99
68813 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
68814 RUNI=RUNI-RRPY98
68815 IF(RUNI.LT.0D0) RUNI=RUNI+1D0
68816 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
68817
68818C...Update counters. Random number to output.
68819 MRPY3=MRPY3+1
68820 IF(MRPY3.EQ.1000000000) THEN
68821 MRPY2=MRPY2+1
68822 MRPY3=0
68823 ENDIF
68824 PYR=RUNI
68825
68826 RETURN
68827 END
68828
68829C*********************************************************************
68830
68831C...PYRGET
68832C...Dumps the state of the random number generator on a file
68833C...for subsequent startup from this state onwards.
68834
68835 SUBROUTINE PYRGET(LFN,MOVE)
68836
68837C...Double precision and integer declarations.
68838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68839 IMPLICIT INTEGER(I-N)
68840 INTEGER PYK,PYCHGE,PYCOMP
68841C...Commonblocks.
68842 COMMON/PYDATR/MRPY(6),RRPY(100)
68843 SAVE /PYDATR/
68844C...Local character variable.
68845 CHARACTER CHERR*8
68846
68847C...Backspace required number of records (or as many as there are).
68848 IF(MOVE.LT.0) THEN
68849 NBCK=MIN(MRPY(6),-MOVE)
68850 DO 100 IBCK=1,NBCK
68851 BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
68852 100 CONTINUE
68853 MRPY(6)=MRPY(6)-NBCK
68854 ENDIF
68855
68856C...Unformatted write on unit LFN.
68857 WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
68858 &(RRPY(I2),I2=1,100)
68859 MRPY(6)=MRPY(6)+1
68860 RETURN
68861
68862C...Write error.
68863 110 WRITE(CHERR,'(I8)') IERR
68864 CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
68865 &CHERR)
68866
68867 RETURN
68868 END
68869
68870C*********************************************************************
68871
68872C...PYRSET
68873C...Reads a state of the random number generator from a file
68874C...for subsequent generation from this state onwards.
68875
68876 SUBROUTINE PYRSET(LFN,MOVE)
68877
68878C...Double precision and integer declarations.
68879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68880 IMPLICIT INTEGER(I-N)
68881 INTEGER PYK,PYCHGE,PYCOMP
68882C...Commonblocks.
68883 COMMON/PYDATR/MRPY(6),RRPY(100)
68884 SAVE /PYDATR/
68885C...Local character variable.
68886 CHARACTER CHERR*8
68887
68888C...Backspace required number of records (or as many as there are).
68889 IF(MOVE.LT.0) THEN
68890 NBCK=MIN(MRPY(6),-MOVE)
68891 DO 100 IBCK=1,NBCK
68892 BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
68893 100 CONTINUE
68894 MRPY(6)=MRPY(6)-NBCK
68895 ENDIF
68896
68897C...Unformatted read from unit LFN.
68898 NFOR=1+MAX(0,MOVE)
68899 DO 110 IFOR=1,NFOR
68900 READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
68901 & (RRPY(I2),I2=1,100)
68902 110 CONTINUE
68903 MRPY(6)=MRPY(6)+NFOR
68904 RETURN
68905
68906C...Write error.
68907 120 WRITE(CHERR,'(I8)') IERR
68908 CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
68909 &CHERR)
68910
68911 RETURN
68912 END
68913
68914C*********************************************************************
68915
68916C...PYROBO
68917C...Performs rotations and boosts.
68918
68919 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
68920
68921C...Double precision and integer declarations.
68922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68923 IMPLICIT INTEGER(I-N)
68924 INTEGER PYK,PYCHGE,PYCOMP
68925C...Commonblocks.
68926 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68928 SAVE /PYJETS/,/PYDAT1/
68929C...Local arrays.
68930 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
68931
68932C...Find and check range of rotation/boost.
68933 IMIN=IMI
68934 IF(IMIN.LE.0) IMIN=1
68935 IF(MSTU(1).GT.0) IMIN=MSTU(1)
68936 IMAX=IMA
68937 IF(IMAX.LE.0) IMAX=N
68938 IF(MSTU(2).GT.0) IMAX=MSTU(2)
68939 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
68940 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
68941 RETURN
68942 ENDIF
68943
68944C...Optional resetting of V (when not set before.)
68945 IF(MSTU(33).NE.0) THEN
68946 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
68947 DO 100 J=1,5
68948 V(I,J)=0D0
68949 100 CONTINUE
68950 110 CONTINUE
68951 MSTU(33)=0
68952 ENDIF
68953
68954C...Rotate, typically from z axis to direction (theta,phi).
68955 IF(THE**2+PHI**2.GT.1D-20) THEN
68956 ROT(1,1)=COS(THE)*COS(PHI)
68957 ROT(1,2)=-SIN(PHI)
68958 ROT(1,3)=SIN(THE)*COS(PHI)
68959 ROT(2,1)=COS(THE)*SIN(PHI)
68960 ROT(2,2)=COS(PHI)
68961 ROT(2,3)=SIN(THE)*SIN(PHI)
68962 ROT(3,1)=-SIN(THE)
68963 ROT(3,2)=0D0
68964 ROT(3,3)=COS(THE)
68965 DO 140 I=IMIN,IMAX
68966 IF(K(I,1).LE.0) GOTO 140
68967 DO 120 J=1,3
68968 PR(J)=P(I,J)
68969 VR(J)=V(I,J)
68970 120 CONTINUE
68971 DO 130 J=1,3
68972 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
68973 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
68974 130 CONTINUE
68975 140 CONTINUE
68976 ENDIF
68977
68978C...Boost, typically from rest to momentum/energy=beta.
68979 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
68980 DBX=BEX
68981 DBY=BEY
68982 DBZ=BEZ
68983 DB=SQRT(DBX**2+DBY**2+DBZ**2)
68984 EPS1=1D0-1D-12
68985 IF(DB.GT.EPS1) THEN
68986C...Rescale boost vector if too close to unity.
68987 CALL PYERRM(3,'(PYROBO:) boost vector too large')
68988 DBX=DBX*(EPS1/DB)
68989 DBY=DBY*(EPS1/DB)
68990 DBZ=DBZ*(EPS1/DB)
68991 DB=EPS1
68992 ENDIF
68993 DGA=1D0/SQRT(1D0-DB**2)
68994 DO 160 I=IMIN,IMAX
68995 IF(K(I,1).LE.0) GOTO 160
68996 DO 150 J=1,4
68997 DP(J)=P(I,J)
68998 DV(J)=V(I,J)
68999 150 CONTINUE
69000 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
69001 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
69002 P(I,1)=DP(1)+DGABP*DBX
69003 P(I,2)=DP(2)+DGABP*DBY
69004 P(I,3)=DP(3)+DGABP*DBZ
69005 P(I,4)=DGA*(DP(4)+DBP)
69006 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
69007 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
69008 V(I,1)=DV(1)+DGABV*DBX
69009 V(I,2)=DV(2)+DGABV*DBY
69010 V(I,3)=DV(3)+DGABV*DBZ
69011 V(I,4)=DGA*(DV(4)+DBV)
69012 160 CONTINUE
69013 ENDIF
69014
69015 RETURN
69016 END
69017
69018C*********************************************************************
69019
69020C...PYEDIT
69021C...Performs global manipulations on the event record, in particular
69022C...to exclude unstable or undetectable partons/particles.
69023
69024 SUBROUTINE PYEDIT(MEDIT)
69025
69026C...Double precision and integer declarations.
69027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69028 IMPLICIT INTEGER(I-N)
69029 INTEGER PYK,PYCHGE,PYCOMP
69030C...Parameter statement to help give large particle numbers.
69031 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69032 &KEXCIT=4000000,KDIMEN=5000000)
69033C...Commonblocks.
69034 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69036 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69037 COMMON/PYCTAG/NCT,MCT(4000,2)
69038 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
69039C...Local arrays.
69040 DIMENSION NS(2),PTS(2),PLS(2)
69041
69042C...Remove unwanted partons/particles.
69043 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
69044 IMAX=N
69045 IF(MSTU(2).GT.0) IMAX=MSTU(2)
69046 I1=MAX(1,MSTU(1))-1
69047 DO 110 I=MAX(1,MSTU(1)),IMAX
69048 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
69049 IF(MEDIT.EQ.1) THEN
69050 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
69051 ELSEIF(MEDIT.EQ.2) THEN
69052 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
69053 KC=PYCOMP(K(I,2))
69054 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
69055 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
69056 & K(I,2).EQ.KSUSY1+39) GOTO 110
69057 ELSEIF(MEDIT.EQ.3) THEN
69058 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
69059 KC=PYCOMP(K(I,2))
69060 IF(KC.EQ.0) GOTO 110
69061 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
69062 ELSEIF(MEDIT.EQ.5) THEN
69063 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
69064 KC=PYCOMP(K(I,2))
69065 IF(KC.EQ.0) GOTO 110
69066 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
69067 & KCHG(KC,2).EQ.0) GOTO 110
69068 ENDIF
69069
69070C...Pack remaining partons/particles. Origin no longer known.
69071 I1=I1+1
69072 DO 100 J=1,5
69073 K(I1,J)=K(I,J)
69074 P(I1,J)=P(I,J)
69075 V(I1,J)=V(I,J)
69076 100 CONTINUE
69077 K(I1,3)=0
69078 110 CONTINUE
69079 IF(I1.LT.N) MSTU(3)=0
69080 IF(I1.LT.N) MSTU(70)=0
69081 N=I1
69082
69083C...Selective removal of class of entries. New position of retained.
69084 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
69085 I1=0
69086 DO 120 I=1,N
69087 K(I,3)=MOD(K(I,3),MSTU(5))
69088 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
69089 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
69090 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
69091 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
69092 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
69093 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
69094 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
69095 I1=I1+1
69096 K(I,3)=K(I,3)+MSTU(5)*I1
69097 120 CONTINUE
69098
69099C...Find new event history information and replace old.
69100 DO 140 I=1,N
69101 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
69102 & K(I,3)/MSTU(5).EQ.0) GOTO 140
69103 ID=I
69104 130 IM=MOD(K(ID,3),MSTU(5))
69105 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
69106 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
69107 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
69108 ID=IM
69109 GOTO 130
69110 ENDIF
69111 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
69112 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
69113 & K(IM,2).EQ.94) THEN
69114 ID=IM
69115 GOTO 130
69116 ENDIF
69117 ENDIF
69118 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
69119 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
69120 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
69121 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
69122 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
69123 & K(K(I,4),3)/MSTU(5)
69124 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
69125 & K(K(I,5),3)/MSTU(5)
69126 ELSE
69127 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
69128 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
69129 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
69130 KCD=MOD(K(I,4),MSTU(5))
69131 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
69132 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
69133 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
69134 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
69135 KCD=MOD(K(I,5),MSTU(5))
69136 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
69137 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
69138 ENDIF
69139 140 CONTINUE
69140
69141C...Pack remaining entries.
69142 I1=0
69143 MSTU90=MSTU(90)
69144 MSTU(90)=0
69145 DO 170 I=1,N
69146 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
69147 I1=I1+1
69148 DO 150 J=1,5
69149 K(I1,J)=K(I,J)
69150 P(I1,J)=P(I,J)
69151 V(I1,J)=V(I,J)
69152 150 CONTINUE
69153C...Also update LHA1 colour tags
69154 MCT(I1,1)=MCT(I,1)
69155 MCT(I1,2)=MCT(I,2)
69156 K(I1,3)=MOD(K(I1,3),MSTU(5))
69157 DO 160 IZ=1,MSTU90
69158 IF(I.EQ.MSTU(90+IZ)) THEN
69159 MSTU(90)=MSTU(90)+1
69160 MSTU(90+MSTU(90))=I1
69161 PARU(90+MSTU(90))=PARU(90+IZ)
69162 ENDIF
69163 160 CONTINUE
69164 170 CONTINUE
69165 IF(I1.LT.N) MSTU(3)=0
69166 IF(I1.LT.N) MSTU(70)=0
69167 N=I1
69168
69169C...Fill in some missing daughter pointers (lost in colour flow).
69170 ELSEIF(MEDIT.EQ.16) THEN
69171 DO 220 I=1,N
69172 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
69173 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
69174C...Find daughters who point to mother.
69175 DO 180 I1=I+1,N
69176 IF(K(I1,3).NE.I) THEN
69177 ELSEIF(K(I,4).EQ.0) THEN
69178 K(I,4)=I1
69179 ELSE
69180 K(I,5)=I1
69181 ENDIF
69182 180 CONTINUE
69183 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
69184 IF(K(I,4).NE.0) GOTO 220
69185C...Find daughters who point to documentation version of mother.
69186 IM=K(I,3)
69187 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
69188 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
69189 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
69190 DO 190 I1=I+1,N
69191 IF(K(I1,3).NE.IM) THEN
69192 ELSEIF(K(I,4).EQ.0) THEN
69193 K(I,4)=I1
69194 ELSE
69195 K(I,5)=I1
69196 ENDIF
69197 190 CONTINUE
69198 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
69199 IF(K(I,4).NE.0) GOTO 220
69200C...Find daughters who point to documentation daughters who,
69201C...in their turn, point to documentation mother.
69202 ID1=IM
69203 ID2=IM
69204 DO 200 I1=IM+1,I-1
69205 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
69206 ID2=I1
69207 IF(ID1.EQ.IM) ID1=I1
69208 ENDIF
69209 200 CONTINUE
69210 DO 210 I1=I+1,N
69211 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
69212 ELSEIF(K(I,4).EQ.0) THEN
69213 K(I,4)=I1
69214 ELSE
69215 K(I,5)=I1
69216 ENDIF
69217 210 CONTINUE
69218 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
69219 220 CONTINUE
69220
69221C...Save top entries at bottom of PYJETS commonblock.
69222 ELSEIF(MEDIT.EQ.21) THEN
69223 IF(2*N.GE.MSTU(4)) THEN
69224 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
69225 RETURN
69226 ENDIF
69227 DO 240 I=1,N
69228 DO 230 J=1,5
69229 K(MSTU(4)-I,J)=K(I,J)
69230 P(MSTU(4)-I,J)=P(I,J)
69231 V(MSTU(4)-I,J)=V(I,J)
69232 230 CONTINUE
69233 240 CONTINUE
69234 MSTU(32)=N
69235
69236C...Restore bottom entries of commonblock PYJETS to top.
69237 ELSEIF(MEDIT.EQ.22) THEN
69238 DO 260 I=1,MSTU(32)
69239 DO 250 J=1,5
69240 K(I,J)=K(MSTU(4)-I,J)
69241 P(I,J)=P(MSTU(4)-I,J)
69242 V(I,J)=V(MSTU(4)-I,J)
69243 250 CONTINUE
69244 260 CONTINUE
69245 N=MSTU(32)
69246
69247C...Mark primary entries at top of commonblock PYJETS as untreated.
69248 ELSEIF(MEDIT.EQ.23) THEN
69249 I1=0
69250 DO 270 I=1,N
69251 KH=K(I,3)
69252 IF(KH.GE.1) THEN
69253 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
69254 ENDIF
69255 IF(KH.NE.0) GOTO 280
69256 I1=I1+1
69257 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
69258 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
69259 270 CONTINUE
69260 280 N=I1
69261
69262C...Place largest axis along z axis and second largest in xy plane.
69263 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
69264 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
69265 & P(MSTU(61),2)),0D0,0D0,0D0)
69266 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
69267 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
69268 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
69269 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
69270 IF(MEDIT.EQ.31) RETURN
69271
69272C...Rotate to put slim jet along +z axis.
69273 DO 290 IS=1,2
69274 NS(IS)=0
69275 PTS(IS)=0D0
69276 PLS(IS)=0D0
69277 290 CONTINUE
69278 DO 300 I=1,N
69279 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
69280 IF(MSTU(41).GE.2) THEN
69281 KC=PYCOMP(K(I,2))
69282 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
69283 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
69284 & K(I,2).EQ.KSUSY1+39) GOTO 300
69285 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
69286 & .EQ.0) GOTO 300
69287 ENDIF
69288 IS=2D0-SIGN(0.5D0,P(I,3))
69289 NS(IS)=NS(IS)+1
69290 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
69291 300 CONTINUE
69292 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
69293 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
69294
69295C...Rotate to put second largest jet into -z,+x quadrant.
69296 DO 310 I=1,N
69297 IF(P(I,3).GE.0D0) GOTO 310
69298 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
69299 IF(MSTU(41).GE.2) THEN
69300 KC=PYCOMP(K(I,2))
69301 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
69302 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
69303 & K(I,2).EQ.KSUSY1+39) GOTO 310
69304 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
69305 & .EQ.0) GOTO 310
69306 ENDIF
69307 IS=2D0-SIGN(0.5D0,P(I,1))
69308 PLS(IS)=PLS(IS)-P(I,3)
69309 310 CONTINUE
69310 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
69311 & 0D0,0D0,0D0)
69312 ENDIF
69313
69314 RETURN
69315 END
69316
69317C*********************************************************************
69318
69319C...PYLIST
69320C...Gives program heading, or lists an event, or particle
69321C...data, or current parameter values.
69322
69323 SUBROUTINE PYLIST(MLIST)
69324
69325C...Double precision and integer declarations.
69326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69327 IMPLICIT INTEGER(I-N)
69328 INTEGER PYK,PYCHGE,PYCOMP
69329C...Parameter statement to help give large particle numbers.
69330 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69331 &KEXCIT=4000000,KDIMEN=5000000)
69332
69333C...HEPEVT commonblock.
69334 PARAMETER (NMXHEP=4000)
69335 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
69336 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
69337 DOUBLE PRECISION PHEP,VHEP
69338 SAVE /HEPEVT/
69339
69340C...User process event common block.
69341 INTEGER MAXNUP
69342 PARAMETER (MAXNUP=500)
69343 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
69344 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
69345 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
69346 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
69347 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
69348 SAVE /HEPEUP/
69349
69350C...Commonblocks.
69351 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69352 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69353 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69354 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
69355 COMMON/PYCTAG/NCT,MCT(4000,2)
69356 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
69357C...Local arrays, character variables and data.
69358 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
69359 DIMENSION PS(6)
69360 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
69361
69362C...Initialization printout: version number and date of last change.
69363 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
69364 CALL PYLOGO
69365 MSTU(12)=12345
69366 IF(MLIST.EQ.0) RETURN
69367 ENDIF
69368
69369C...List event data, including additional lines after N.
69370 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
69371 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
69372 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
69373 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
69374 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
69375 LMX=12
69376 IF(MLIST.GE.2) LMX=16
69377 ISTR=0
69378 IMAX=N
69379 IF(MSTU(2).GT.0) IMAX=MSTU(2)
69380 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
69381 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
69382 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
69383 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
69384
69385C...Get particle name, pad it and check it is not too long.
69386 CALL PYNAME(K(I,2),CHAP)
69387 LEN=0
69388 DO 100 LEM=1,16
69389 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
69390 100 CONTINUE
69391 MDL=(K(I,1)+19)/10
69392 LDL=0
69393 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
69394 CHAC=CHAP
69395 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
69396 ELSE
69397 LDL=1
69398 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
69399 IF(LEN.EQ.0) THEN
69400 CHAC=CHDL(MDL)(1:2*LDL)//' '
69401 ELSE
69402 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
69403 & CHDL(MDL)(LDL+1:2*LDL)//' '
69404 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
69405 ENDIF
69406 ENDIF
69407
69408C...Add information on string connection.
69409 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
69410 & THEN
69411 KC=PYCOMP(K(I,2))
69412 KCC=0
69413 IF(KC.NE.0) KCC=KCHG(KC,2)
69414 IF(IABS(K(I,2)).EQ.39) THEN
69415 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
69416 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
69417 ISTR=1
69418 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
69419 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
69420 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
69421 ELSEIF(KCC.NE.0) THEN
69422 ISTR=0
69423 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
69424 ENDIF
69425 ENDIF
69426 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
69427 & CHAC(LMX-1:LMX-1)='I'
69428
69429C...Write data for particle/jet.
69430 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
69431 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
69432 & (P(I,J2),J2=1,5)
69433 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
69434 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
69435 & (P(I,J2),J2=1,5)
69436 ELSEIF(MLIST.EQ.1) THEN
69437 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
69438 & (P(I,J2),J2=1,5)
69439 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
69440 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
69441 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
69442 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
69443 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
69444 & (P(I,J2),J2=1,5)
69445 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
69446 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
69447 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
69448 & ,10000),MCT(I,1),MCT(I,2)
69449 ELSE
69450 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
69451 & (P(I,J2),J2=1,5)
69452 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
69453 & ,MCT(I,1),MCT(I,2)
69454 ENDIF
69455 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
69456
69457C...Insert extra separator lines specified by user.
69458 IF(MSTU(70).GE.1) THEN
69459 ISEP=0
69460 DO 110 J=1,MIN(10,MSTU(70))
69461 IF(I.EQ.MSTU(70+J)) ISEP=1
69462 110 CONTINUE
69463 IF(ISEP.EQ.1) THEN
69464 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
69465 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
69466 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
69467 ENDIF
69468 ENDIF
69469 120 CONTINUE
69470
69471C...Sum of charges and momenta.
69472 DO 130 J=1,6
69473 PS(J)=PYP(0,J)
69474 130 CONTINUE
69475 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
69476 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
69477 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
69478 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
69479 ELSEIF(MLIST.EQ.1) THEN
69480 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
69481 ELSEIF(MLIST.LE.3) THEN
69482 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
69483 ELSE
69484 WRITE(MSTU(11),7000) PS(6)
69485 ENDIF
69486
69487C...Simple listing of HEPEVT entries (mainly for test purposes).
69488 ELSEIF(MLIST.EQ.5) THEN
69489 WRITE(MSTU(11),7100)
69490 DO 140 I=1,NHEP
69491 IF(ISTHEP(I).EQ.0) GOTO 140
69492 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
69493 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
69494 140 CONTINUE
69495
69496
69497C...Simple listing of user-process entries (mainly for test purposes).
69498 ELSEIF(MLIST.EQ.7) THEN
69499 WRITE(MSTU(11),7300)
69500 DO 150 I=1,NUP
69501 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
69502 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
69503 150 CONTINUE
69504
69505C...Give simple list of KF codes defined in program.
69506 ELSEIF(MLIST.EQ.11) THEN
69507 WRITE(MSTU(11),7500)
69508 DO 160 KF=1,80
69509 CALL PYNAME(KF,CHAP)
69510 CALL PYNAME(-KF,CHAN)
69511 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
69512 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69513 160 CONTINUE
69514 DO 190 KFLS=1,3,2
69515 DO 180 KFLA=1,5
69516 DO 170 KFLB=1,KFLA-(3-KFLS)/2
69517 KF=1000*KFLA+100*KFLB+KFLS
69518 CALL PYNAME(KF,CHAP)
69519 CALL PYNAME(-KF,CHAN)
69520 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69521 170 CONTINUE
69522 180 CONTINUE
69523 190 CONTINUE
69524 DO 220 KMUL=0,5
69525 KFLS=3
69526 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
69527 IF(KMUL.EQ.5) KFLS=5
69528 KFLR=0
69529 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
69530 IF(KMUL.EQ.4) KFLR=2
69531 DO 210 KFLB=1,5
69532 DO 200 KFLC=1,KFLB-1
69533 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
69534 CALL PYNAME(KF,CHAP)
69535 CALL PYNAME(-KF,CHAN)
69536 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69537 IF(KF.EQ.311) THEN
69538 KFK=130
69539 CALL PYNAME(KFK,CHAP)
69540 WRITE(MSTU(11),7600) KFK,CHAP
69541 KFK=310
69542 CALL PYNAME(KFK,CHAP)
69543 WRITE(MSTU(11),7600) KFK,CHAP
69544 ENDIF
69545 200 CONTINUE
69546 KF=10000*KFLR+110*KFLB+KFLS
69547 CALL PYNAME(KF,CHAP)
69548 WRITE(MSTU(11),7600) KF,CHAP
69549 210 CONTINUE
69550 220 CONTINUE
69551 KF=100443
69552 CALL PYNAME(KF,CHAP)
69553 WRITE(MSTU(11),7600) KF,CHAP
69554 KF=100553
69555 CALL PYNAME(KF,CHAP)
69556 WRITE(MSTU(11),7600) KF,CHAP
69557 DO 260 KFLSP=1,3
69558 KFLS=2+2*(KFLSP/3)
69559 DO 250 KFLA=1,5
69560 DO 240 KFLB=1,KFLA
69561 DO 230 KFLC=1,KFLB
69562 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
69563 & GOTO 230
69564 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
69565 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
69566 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
69567 CALL PYNAME(KF,CHAP)
69568 CALL PYNAME(-KF,CHAN)
69569 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69570 230 CONTINUE
69571 240 CONTINUE
69572 250 CONTINUE
69573 260 CONTINUE
69574 DO 270 KC=1,500
69575 KF=KCHG(KC,4)
69576 IF(KF.LT.1000000) GOTO 270
69577 CALL PYNAME(KF,CHAP)
69578 CALL PYNAME(-KF,CHAN)
69579 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
69580 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
69581 270 CONTINUE
69582
69583C...List parton/particle data table. Check whether to be listed.
69584 ELSEIF(MLIST.EQ.12) THEN
69585 WRITE(MSTU(11),7700)
69586 DO 300 KC=1,MSTU(6)
69587 KF=KCHG(KC,4)
69588 IF(KF.EQ.0) GOTO 300
69589 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
69590 & GOTO 300
69591
69592C...Find particle name and mass. Print information.
69593 CALL PYNAME(KF,CHAP)
69594 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
69595 CALL PYNAME(-KF,CHAN)
69596 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
69597 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
69598
69599C...Particle decay: channel number, branching ratios, matrix element,
69600C...decay products.
69601 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
69602 DO 280 J=1,5
69603 CALL PYNAME(KFDP(IDC,J),CHAD(J))
69604 280 CONTINUE
69605 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
69606 & (CHAD(J),J=1,5)
69607 290 CONTINUE
69608 300 CONTINUE
69609
69610C...List parameter value table.
69611 ELSEIF(MLIST.EQ.13) THEN
69612 WRITE(MSTU(11),8000)
69613 DO 310 I=1,200
69614 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
69615 310 CONTINUE
69616 ENDIF
69617
69618C...Format statements for output on unit MSTU(11) (by default 6).
69619 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
69620 &5X,'KF orig p_x p_y p_z E m'/)
69621 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
69622 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
69623 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
69624 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
69625 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
69626 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
69627 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
69628 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
69629 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
69630 & ,' C tag AC tag'/)
69631 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
69632 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
69633 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
69634 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
69635 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
69636 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
69637 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
69638 6200 FORMAT(66X,5(1X,F12.3))
69639 6300 FORMAT(1X,78('='))
69640 6400 FORMAT(1X,130('='))
69641 6500 FORMAT(1X,65('='))
69642 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
69643 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
69644 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
69645 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
69646 &5F13.5)
69647 7000 FORMAT(19X,'sum charge:',F6.2)
69648 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
69649 &//' I IST ID Mothers Daughters p_x p_y p_z',
69650 &' E m')
69651 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
69652 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
69653 &//' I IST ID Mothers Colours p_x p_y p_z',
69654 &' E m')
69655 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
69656 7500 FORMAT(///20X,'List of KF codes in program'/)
69657 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
69658 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
69659 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
69660 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
69661 &1X,'ME',3X,'Br.rat.',4X,'decay products')
69662 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
69663 &1X,1P,E13.5,3X,I2)
69664 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
69665 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
69666 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
69667 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
69668
69669 RETURN
69670 END
69671
69672C*********************************************************************
69673
69674C...PYLOGO
69675C...Writes a logo for the program.
69676
69677 SUBROUTINE PYLOGO
69678
69679C...Double precision and integer declarations.
69680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69681 IMPLICIT INTEGER(I-N)
69682 INTEGER PYK,PYCHGE,PYCOMP
69683C...Parameter for length of information block.
69684 PARAMETER (IREFER=20)
69685C...Commonblocks.
69686 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69687 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69688 SAVE /PYDAT1/,/PYPARS/
69689C...Local arrays and character variables.
69690 INTEGER IDATI(6)
69691 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
69692 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
69693
69694C...Data on months, logo, titles, and references.
69695 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
69696 &'Oct','Nov','Dec'/
69697 DATA (LOGO(J),J=1,19)/
69698 &' *......* ',
69699 &' *:::!!:::::::::::* ',
69700 &' *::::::!!::::::::::::::* ',
69701 &' *::::::::!!::::::::::::::::* ',
69702 &' *:::::::::!!:::::::::::::::::* ',
69703 &' *:::::::::!!:::::::::::::::::* ',
69704 &' *::::::::!!::::::::::::::::*! ',
69705 &' *::::::!!::::::::::::::* !! ',
69706 &' !! *:::!!:::::::::::* !! ',
69707 &' !! !* -><- * !! ',
69708 &' !! !! !! ',
69709 &' !! !! !! ',
69710 &' !! !! ',
69711 &' !! lh !! ',
69712 &' !! !! ',
69713 &' !! hh !! ',
69714 &' !! ll !! ',
69715 &' !! !! ',
69716 &' !! '/
69717 DATA (LOGO(J),J=20,38)/
69718 &'Welcome to the Lund Monte Carlo!',
69719 &' ',
69720 &'PPP Y Y TTTTT H H III A ',
69721 &'P P Y Y T H H I A A ',
69722 &'PPP Y T HHHHH I AAAAA',
69723 &'P Y T H H I A A',
69724 &'P Y T H H III A A',
69725 &' ',
69726 &'This is PYTHIA version x.xxx ',
69727 &'Last date of change: xx xxx 200x',
69728 &' ',
69729 &'Now is xx xxx 200x at xx:xx:xx ',
69730 &' ',
69731 &'Disclaimer: this program comes ',
69732 &'without any guarantees. Beware ',
69733 &'of errors and use common sense ',
69734 &'when interpreting results. ',
69735 &' ',
69736 &'Copyright T. Sjostrand (2007) '/
69737 DATA (REFER(J),J=1,14)/
69738 &'An archive of program versions and d',
69739 &'ocumentation is found on the web: ',
69740 &'http://www.thep.lu.se/~torbjorn/Pyth',
69741 &'ia.html ',
69742 &' ',
69743 &' ',
69744 &'When you cite this program, the offi',
69745 &'cial reference is to the 6.4 manual:',
69746 &'T. Sjostrand, S. Mrenna and P. Skand',
69747 &'s, JHEP05 (2006) 026 ',
69748 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
69749 &'-T) [hep-ph/0603175]. ',
69750 &' ',
69751 &' '/
69752 DATA (REFER(J),J=15,32)/
69753 &'Also remember that the program, to a',
69754 &' large extent, represents original ',
69755 &'physics research. Other publications',
69756 &' of special relevance to your ',
69757 &'studies may therefore deserve separa',
69758 &'te mention. ',
69759 &' ',
69760 &' ',
69761 &'Main author: Torbjorn Sjostrand; CER',
69762 &'N/PH, CH-1211 Geneva, Switzerland, ',
69763 &' and Department of Theoretical Phys',
69764 &'ics, Lund University, Lund, Sweden; ',
69765 &' phone: + 41 - 22 - 767 82 27; e-ma',
69766 &'il: torbjorn@thep.lu.se ',
69767 &'Author: Stephen Mrenna; Computing Di',
69768 &'vision, GDS Group, ',
69769 &' Fermi National Accelerator Laborat',
69770 &'ory, MS 234, Batavia, IL 60510, USA;'/
69771 DATA (REFER(J),J=33,2*IREFER)/
69772 &' phone: + 1 - 630 - 840 - 2556; e-m',
69773 &'ail: mrenna@fnal.gov ',
69774 &'Author: Peter Skands; Theoretical Ph',
69775 &'ysics Department, ',
69776 &' Fermi National Accelerator Laborat',
69777 &'ory, MS 106, Batavia, IL 60510, USA;',
69778 &' phone: + 1 - 630 - 840 - 2270; e-m',
69779 &'ail: skands@fnal.gov '/
69780
69781C...Check that PYDATA linked.
69782 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
69783 WRITE(*,'(1X,A)')
69784 & 'Error: PYDATA has not been linked.'
69785 WRITE(*,'(1X,A)') 'Execution stopped!'
69786 STOP
69787
69788C...Write current version number and current date+time.
69789 ELSE
69790 WRITE(VERS,'(I1)') MSTP(181)
69791 LOGO(28)(24:24)=VERS
69792 WRITE(SUBV,'(I3)') MSTP(182)
69793 LOGO(28)(26:28)=SUBV
69794 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
69795 WRITE(DATE,'(I2)') MSTP(185)
69796 LOGO(29)(22:23)=DATE
69797 LOGO(29)(25:27)=MONTH(MSTP(184))
69798 WRITE(YEAR,'(I4)') MSTP(183)
69799 LOGO(29)(29:32)=YEAR
69800 CALL PYTIME(IDATI)
69801 IF(IDATI(1).LE.0) THEN
69802 LOGO(31)=' '
69803 ELSE
69804 WRITE(DATE,'(I2)') IDATI(3)
69805 LOGO(31)(8:9)=DATE
69806 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
69807 WRITE(YEAR,'(I4)') IDATI(1)
69808 LOGO(31)(15:18)=YEAR
69809 WRITE(HOUR,'(I2)') IDATI(4)
69810 LOGO(31)(23:24)=HOUR
69811 WRITE(MINU,'(I2)') IDATI(5)
69812 LOGO(31)(26:27)=MINU
69813 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
69814 WRITE(SECO,'(I2)') IDATI(6)
69815 LOGO(31)(29:30)=SECO
69816 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
69817 ENDIF
69818 ENDIF
69819
69820C...Loop over lines in header. Define page feed and side borders.
69821 DO 100 ILIN=1,29+IREFER
69822 LINE=' '
69823 IF(ILIN.EQ.1) THEN
69824 LINE(1:1)='1'
69825 ELSE
69826 LINE(2:3)='**'
69827 LINE(78:79)='**'
69828 ENDIF
69829
69830C...Separator lines and logos.
69831 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
69832 LINE(4:77)='***********************************************'//
69833 & '***************************'
69834 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
69835 LINE(6:37)=LOGO(ILIN-5)
69836 LINE(44:75)=LOGO(ILIN+14)
69837 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
69838 LINE(5:40)=REFER(2*ILIN-51)
69839 LINE(41:76)=REFER(2*ILIN-50)
69840 ENDIF
69841
69842C...Write lines to appropriate unit.
69843 WRITE(MSTU(11),'(A79)') LINE
69844 100 CONTINUE
69845
69846 RETURN
69847 END
69848
69849C*********************************************************************
69850
69851C...PYUPDA
69852C...Facilitates the updating of particle and decay data
69853C...by allowing it to be done in an external file.
69854
69855 SUBROUTINE PYUPDA(MUPDA,LFN)
69856
69857C...Double precision and integer declarations.
69858 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69859 IMPLICIT INTEGER(I-N)
69860 INTEGER PYK,PYCHGE,PYCOMP
69861C...Commonblocks.
69862 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69863 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69864 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
69865 COMMON/PYDAT4/CHAF(500,2)
69866 CHARACTER CHAF*16
69867 COMMON/PYINT4/MWID(500),WIDS(500,5)
69868 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
69869C...Local arrays, character variables and data.
69870 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
69871 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
69872 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
69873 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
69874 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
69875 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
69876 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
69877
69878C...Write header if not yet done.
69879 IF(MSTU(12).NE.12345) CALL PYLIST(0)
69880
69881C...Write information on file for editing.
69882 IF(MUPDA.EQ.1) THEN
69883 DO 110 KC=1,500
69884 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
69885 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
69886 & MWID(KC),MDCY(KC,1)
69887 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
69888 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
69889 & (KFDP(IDC,J),J=1,5)
69890 100 CONTINUE
69891 110 CONTINUE
69892
69893C...Read complete set of information from edited file or
69894C...read partial set of new or updated information from edited file.
69895 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
69896
69897C...Reset counters.
69898 KCC=100
69899 NDC=0
69900 CHKF=' '
69901 IF(MUPDA.EQ.2) THEN
69902 DO 120 I=1,MSTU(6)
69903 KCHG(I,4)=0
69904 120 CONTINUE
69905 ELSE
69906 DO 130 KC=1,MSTU(6)
69907 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
69908 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
69909 130 CONTINUE
69910 ENDIF
69911
69912C...Begin of loop: read new line; unknown whether particle or
69913C...decay data.
69914 140 READ(LFN,5200,END=190) CHINL
69915
69916C...Identify particle code and whether already defined (for MUPDA=3).
69917 IF(CHINL(2:10).NE.' ') THEN
69918 CHKF=CHINL(2:10)
69919 READ(CHKF,5300) KF
69920 IF(MUPDA.EQ.2) THEN
69921 IF(KF.LE.100) THEN
69922 KC=KF
69923 ELSE
69924 KCC=KCC+1
69925 KC=KCC
69926 ENDIF
69927 ELSE
69928 KCREP=0
69929 IF(KF.LE.100) THEN
69930 KCREP=KF
69931 ELSE
69932 DO 150 KCR=101,KCC
69933 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
69934 150 CONTINUE
69935 ENDIF
69936C...Remove duplicate old decay data.
69937 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
69938 IDCREP=MDCY(KCREP,2)
69939 NDCREP=MDCY(KCREP,3)
69940 DO 160 I=1,KCC
69941 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
69942 160 CONTINUE
69943 DO 180 I=IDCREP,NDC-NDCREP
69944 MDME(I,1)=MDME(I+NDCREP,1)
69945 MDME(I,2)=MDME(I+NDCREP,2)
69946 BRAT(I)=BRAT(I+NDCREP)
69947 DO 170 J=1,5
69948 KFDP(I,J)=KFDP(I+NDCREP,J)
69949 170 CONTINUE
69950 180 CONTINUE
69951 NDC=NDC-NDCREP
69952 KC=KCREP
69953 ELSEIF(KCREP.NE.0) THEN
69954 KC=KCREP
69955 ELSE
69956 KCC=KCC+1
69957 KC=KCC
69958 ENDIF
69959 ENDIF
69960
69961C...Study line with particle data.
69962 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
69963 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
69964 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
69965 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
69966 & MWID(KC),MDCY(KC,1)
69967 MDCY(KC,2)=0
69968 MDCY(KC,3)=0
69969
69970C...Study line with decay data.
69971 ELSE
69972 NDC=NDC+1
69973 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
69974 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
69975 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
69976 MDCY(KC,3)=MDCY(KC,3)+1
69977 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
69978 & (KFDP(NDC,J),J=1,5)
69979 ENDIF
69980
69981C...End of loop; ensure that PYCOMP tables are updated.
69982 GOTO 140
69983 190 CONTINUE
69984 MSTU(20)=0
69985
69986C...Perform possible tests that new information is consistent.
69987 DO 220 KC=1,MSTU(6)
69988 KF=KCHG(KC,4)
69989 IF(KF.EQ.0) GOTO 220
69990 WRITE(CHKF,5300) KF
69991 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
69992 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
69993 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
69994 BRSUM=0D0
69995 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
69996 IF(MDME(IDC,2).GT.80) GOTO 210
69997 KQ=KCHG(KC,1)
69998 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
69999 MERR=0
70000 DO 200 J=1,5
70001 KP=KFDP(IDC,J)
70002 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
70003 IF(KP.EQ.81) KQ=0
70004 ELSEIF(PYCOMP(KP).EQ.0) THEN
70005 MERR=3
70006 ELSE
70007 KQ=KQ-PYCHGE(KP)
70008 KPC=PYCOMP(KP)
70009 PMS=PMS-PMAS(KPC,1)
70010 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
70011 & PMAS(KPC,3))
70012 ENDIF
70013 200 CONTINUE
70014 IF(KQ.NE.0) MERR=MAX(2,MERR)
70015 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
70016 & MERR=MAX(1,MERR)
70017 IF(MERR.EQ.3) CALL PYERRM(17,
70018 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
70019 IF(MERR.EQ.2) CALL PYERRM(17,
70020 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
70021 IF(MERR.EQ.1) CALL PYERRM(7,
70022 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
70023 BRSUM=BRSUM+BRAT(IDC)
70024 210 CONTINUE
70025 WRITE(CHTMP,5500) BRSUM
70026 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
70027 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
70028 & CHTMP(9:16)//' for KF ='//CHKF)
70029 220 CONTINUE
70030
70031C...Write DATA statements for inclusion in program.
70032 ELSEIF(MUPDA.EQ.4) THEN
70033
70034C...Find out how many codes and decay channels are actually used.
70035 KCC=0
70036 NDC=0
70037 DO 230 I=1,MSTU(6)
70038 IF(KCHG(I,4).NE.0) THEN
70039 KCC=I
70040 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
70041 ENDIF
70042 230 CONTINUE
70043
70044C...Initialize writing of DATA statements for inclusion in program.
70045 DO 300 IVAR=1,22
70046 NDIM=MSTU(6)
70047 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
70048 NLIN=1
70049 CHLIN=' '
70050 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
70051 LLIN=35
70052 CHOLD='START'
70053
70054C...Loop through variables for conversion to characters.
70055 DO 280 IDIM=1,NDIM
70056 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
70057 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
70058 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
70059 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
70060 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
70061 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
70062 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
70063 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
70064 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
70065 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
70066 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
70067 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
70068 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
70069 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
70070 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
70071 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
70072 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
70073 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
70074 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
70075 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
70076 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
70077 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
70078
70079C...Replace variables beyond what is properly defined.
70080 IF(IVAR.LE.4) THEN
70081 IF(IDIM.GT.KCC) CHTMP=' 0'
70082 ELSEIF(IVAR.LE.8) THEN
70083 IF(IDIM.GT.KCC) CHTMP=' 0.0'
70084 ELSEIF(IVAR.LE.11) THEN
70085 IF(IDIM.GT.KCC) CHTMP=' 0'
70086 ELSEIF(IVAR.LE.13) THEN
70087 IF(IDIM.GT.NDC) CHTMP=' 0'
70088 ELSEIF(IVAR.LE.14) THEN
70089 IF(IDIM.GT.NDC) CHTMP=' 0.0'
70090 ELSEIF(IVAR.LE.19) THEN
70091 IF(IDIM.GT.NDC) CHTMP=' 0'
70092 ELSEIF(IVAR.LE.21) THEN
70093 IF(IDIM.GT.KCC) CHTMP=' '
70094 ELSE
70095 IF(IDIM.GT.KCC) CHTMP=' 0'
70096 ENDIF
70097
70098C...Length of variable, trailing decimal zeros, quotation marks.
70099 LLOW=1
70100 LHIG=1
70101 DO 240 LL=1,16
70102 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
70103 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
70104 240 CONTINUE
70105 CHNEW=CHTMP(LLOW:LHIG)//' '
70106 LNEW=1+LHIG-LLOW
70107 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
70108 LNEW=LNEW+1
70109 250 LNEW=LNEW-1
70110 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
70111 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
70112 IF(LNEW.EQ.0) THEN
70113 CHNEW(1:3)='0D0'
70114 LNEW=3
70115 ELSE
70116 CHNEW(LNEW+1:LNEW+2)='D0'
70117 LNEW=LNEW+2
70118 ENDIF
70119 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
70120 DO 260 LL=LNEW,1,-1
70121 IF(CHNEW(LL:LL).EQ.'''') THEN
70122 CHTMP=CHNEW
70123 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
70124 LNEW=LNEW+1
70125 ENDIF
70126 260 CONTINUE
70127 LNEW=MIN(14,LNEW)
70128 CHTMP=CHNEW
70129 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
70130 LNEW=LNEW+2
70131 ENDIF
70132
70133C...Form composite character string, often including repetition counter.
70134 IF(CHNEW.NE.CHOLD) THEN
70135 NRPT=1
70136 CHOLD=CHNEW
70137 CHCOM=CHNEW
70138 LCOM=LNEW
70139 ELSE
70140 LRPT=LNEW+1
70141 IF(NRPT.GE.2) LRPT=LNEW+3
70142 IF(NRPT.GE.10) LRPT=LNEW+4
70143 IF(NRPT.GE.100) LRPT=LNEW+5
70144 IF(NRPT.GE.1000) LRPT=LNEW+6
70145 LLIN=LLIN-LRPT
70146 NRPT=NRPT+1
70147 WRITE(CHTMP,5400) NRPT
70148 LRPT=1
70149 IF(NRPT.GE.10) LRPT=2
70150 IF(NRPT.GE.100) LRPT=3
70151 IF(NRPT.GE.1000) LRPT=4
70152 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
70153 LCOM=LRPT+1+LNEW
70154 ENDIF
70155
70156C...Add characters to end of line, to new line (after storing old line),
70157C...or to new block of lines (after writing old block).
70158 IF(LLIN+LCOM.LE.70) THEN
70159 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
70160 LLIN=LLIN+LCOM+1
70161 ELSEIF(NLIN.LE.19) THEN
70162 CHLIN(LLIN+1:72)=' '
70163 CHBLK(NLIN)=CHLIN
70164 NLIN=NLIN+1
70165 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
70166 LLIN=6+LCOM+1
70167 ELSE
70168 CHLIN(LLIN:72)='/'//' '
70169 CHBLK(NLIN)=CHLIN
70170 WRITE(CHTMP,5400) IDIM-NRPT
70171 CHBLK(1)(30:33)=CHTMP(13:16)
70172 DO 270 ILIN=1,NLIN
70173 WRITE(LFN,5700) CHBLK(ILIN)
70174 270 CONTINUE
70175 NLIN=1
70176 CHLIN=' '
70177 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
70178 & ',I= , )/'//CHCOM(1:LCOM)//','
70179 WRITE(CHTMP,5400) IDIM-NRPT+1
70180 CHLIN(25:28)=CHTMP(13:16)
70181 LLIN=35+LCOM+1
70182 ENDIF
70183 280 CONTINUE
70184
70185C...Write final block of lines.
70186 CHLIN(LLIN:72)='/'//' '
70187 CHBLK(NLIN)=CHLIN
70188 WRITE(CHTMP,5400) NDIM
70189 CHBLK(1)(30:33)=CHTMP(13:16)
70190 DO 290 ILIN=1,NLIN
70191 WRITE(LFN,5700) CHBLK(ILIN)
70192 290 CONTINUE
70193 300 CONTINUE
70194 ENDIF
70195
70196C...Formats for reading and writing particle data.
70197 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
70198 5100 FORMAT(10X,2I5,F12.6,5I10)
70199 5200 FORMAT(A120)
70200 5300 FORMAT(I9)
70201 5400 FORMAT(I16)
70202 5500 FORMAT(F16.5)
70203 5600 FORMAT(F16.6)
70204 5700 FORMAT(A72)
70205
70206 RETURN
70207 END
70208
70209C*********************************************************************
70210
70211C...PYK
70212C...Provides various integer-valued event related data.
70213
70214 FUNCTION PYK(I,J)
70215
70216C...Double precision and integer declarations.
70217 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70218 IMPLICIT INTEGER(I-N)
70219 INTEGER PYK,PYCHGE,PYCOMP
70220C...Commonblocks.
70221 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70224 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70225
70226C...Default value. For I=0 number of entries, number of stable entries
70227C...or 3 times total charge.
70228 PYK=0
70229 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
70230 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
70231 PYK=N
70232 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
70233 DO 100 I1=1,N
70234 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
70235 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
70236 & PYCHGE(K(I1,2))
70237 100 CONTINUE
70238 ELSEIF(I.EQ.0) THEN
70239
70240C...For I > 0 direct readout of K matrix or charge.
70241 ELSEIF(J.LE.5) THEN
70242 PYK=K(I,J)
70243 ELSEIF(J.EQ.6) THEN
70244 PYK=PYCHGE(K(I,2))
70245
70246C...Status (existing/fragmented/decayed), parton/hadron separation.
70247 ELSEIF(J.LE.8) THEN
70248 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
70249 IF(J.EQ.8) PYK=PYK*K(I,2)
70250 ELSEIF(J.LE.12) THEN
70251 KFA=IABS(K(I,2))
70252 KC=PYCOMP(KFA)
70253 KQ=0
70254 IF(KC.NE.0) KQ=KCHG(KC,2)
70255 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
70256 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
70257 IF(J.EQ.11) PYK=KC
70258 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
70259
70260C...Heaviest flavour in hadron/diquark.
70261 ELSEIF(J.EQ.13) THEN
70262 KFA=IABS(K(I,2))
70263 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
70264 IF(KFA.LT.10) PYK=KFA
70265 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
70266 PYK=PYK*ISIGN(1,K(I,2))
70267
70268C...Particle history: generation, ancestor, rank.
70269 ELSEIF(J.LE.15) THEN
70270 I2=I
70271 I1=I
70272 110 PYK=PYK+1
70273 I2=I1
70274 I1=K(I1,3)
70275 IF(I1.GT.0) THEN
70276 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
70277 ENDIF
70278 IF(J.EQ.15) PYK=I2
70279 ELSEIF(J.EQ.16) THEN
70280 KFA=IABS(K(I,2))
70281 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
70282 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
70283 I1=I
70284 120 I2=I1
70285 I1=K(I1,3)
70286 IF(I1.GT.0) THEN
70287 KFAM=IABS(K(I1,2))
70288 ILP=1
70289 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
70290 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
70291 & ILP=0
70292 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
70293 IF(ILP.EQ.1) GOTO 120
70294 ENDIF
70295 IF(K(I1,1).EQ.12) THEN
70296 DO 130 I3=I1+1,I2
70297 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
70298 & .AND.K(I3,2).NE.93) PYK=PYK+1
70299 130 CONTINUE
70300 ELSE
70301 I3=I2
70302 140 PYK=PYK+1
70303 I3=I3+1
70304 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
70305 ENDIF
70306 ENDIF
70307
70308C...Particle coming from collapsing jet system or not.
70309 ELSEIF(J.EQ.17) THEN
70310 I1=I
70311 150 PYK=PYK+1
70312 I3=I1
70313 I1=K(I1,3)
70314 I0=MAX(1,I1)
70315 KC=PYCOMP(K(I0,2))
70316 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
70317 IF(PYK.EQ.1) PYK=-1
70318 IF(PYK.GT.1) PYK=0
70319 RETURN
70320 ENDIF
70321 IF(KCHG(KC,2).EQ.0) GOTO 150
70322 IF(K(I1,1).NE.12) PYK=0
70323 IF(K(I1,1).NE.12) RETURN
70324 I2=I1
70325 160 I2=I2+1
70326 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
70327 K3M=K(I3-1,3)
70328 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
70329 K3P=K(I3+1,3)
70330 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
70331
70332C...Number of decay products. Colour flow.
70333 ELSEIF(J.EQ.18) THEN
70334 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
70335 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
70336 ELSEIF(J.LE.22) THEN
70337 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
70338 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
70339 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
70340 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
70341 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
70342 ELSE
70343 ENDIF
70344
70345 RETURN
70346 END
70347
70348C*********************************************************************
70349
70350C...PYP
70351C...Provides various real-valued event related data.
70352
70353 FUNCTION PYP(I,J)
70354
70355C...Double precision and integer declarations.
70356 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70357 IMPLICIT INTEGER(I-N)
70358 INTEGER PYK,PYCHGE,PYCOMP
70359C...Commonblocks.
70360 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70361 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70362 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70363 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70364C...Local array.
70365 DIMENSION PSUM(4)
70366
70367C...Set default value. For I = 0 sum of momenta or charges,
70368C...or invariant mass of system.
70369 PYP=0D0
70370 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
70371 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
70372 DO 100 I1=1,N
70373 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
70374 100 CONTINUE
70375 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
70376 DO 120 J1=1,4
70377 PSUM(J1)=0D0
70378 DO 110 I1=1,N
70379 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
70380 & P(I1,J1)
70381 110 CONTINUE
70382 120 CONTINUE
70383 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70384 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
70385 DO 130 I1=1,N
70386 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
70387 130 CONTINUE
70388 ELSEIF(I.EQ.0) THEN
70389
70390C...Direct readout of P matrix.
70391 ELSEIF(J.LE.5) THEN
70392 PYP=P(I,J)
70393
70394C...Charge, total momentum, transverse momentum, transverse mass.
70395 ELSEIF(J.LE.12) THEN
70396 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
70397 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
70398 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
70399 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
70400 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
70401
70402C...Theta and phi angle in radians or degrees.
70403 ELSEIF(J.LE.16) THEN
70404 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
70405 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
70406 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
70407
70408C...True rapidity, rapidity with pion mass, pseudorapidity.
70409 ELSEIF(J.LE.19) THEN
70410 PMR=0D0
70411 IF(J.EQ.17) PMR=P(I,5)
70412 IF(J.EQ.18) PMR=PYMASS(211)
70413 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
70414 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
70415 & 1D20)),P(I,3))
70416
70417C...Energy and momentum fractions (only to be used in CM frame).
70418 ELSEIF(J.LE.25) THEN
70419 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
70420 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
70421 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
70422 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
70423 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
70424 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
70425 ENDIF
70426
70427 RETURN
70428 END
70429
70430C*********************************************************************
70431
70432C...PYSPHE
70433C...Performs sphericity tensor analysis to give sphericity,
70434C...aplanarity and the related event axes.
70435
70436 SUBROUTINE PYSPHE(SPH,APL)
70437
70438C...Double precision and integer declarations.
70439 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70440 IMPLICIT INTEGER(I-N)
70441 INTEGER PYK,PYCHGE,PYCOMP
70442C...Parameter statement to help give large particle numbers.
70443 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70444 &KEXCIT=4000000,KDIMEN=5000000)
70445C...Commonblocks.
70446 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70448 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70449 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70450C...Local arrays.
70451 DIMENSION SM(3,3),SV(3,3)
70452
70453C...Calculate matrix to be diagonalized.
70454 NP=0
70455 DO 110 J1=1,3
70456 DO 100 J2=J1,3
70457 SM(J1,J2)=0D0
70458 100 CONTINUE
70459 110 CONTINUE
70460 PS=0D0
70461 DO 140 I=1,N
70462 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
70463 IF(MSTU(41).GE.2) THEN
70464 KC=PYCOMP(K(I,2))
70465 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70466 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70467 & K(I,2).EQ.KSUSY1+39) GOTO 140
70468 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
70469 & GOTO 140
70470 ENDIF
70471 NP=NP+1
70472 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70473 PWT=1D0
70474 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
70475 & MAX(1D-10,PA)**(PARU(41)-2D0)
70476 DO 130 J1=1,3
70477 DO 120 J2=J1,3
70478 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
70479 120 CONTINUE
70480 130 CONTINUE
70481 PS=PS+PWT*PA**2
70482 140 CONTINUE
70483
70484C...Very low multiplicities (0 or 1) not considered.
70485 IF(NP.LE.1) THEN
70486 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
70487 SPH=-1D0
70488 APL=-1D0
70489 RETURN
70490 ENDIF
70491 DO 160 J1=1,3
70492 DO 150 J2=J1,3
70493 SM(J1,J2)=SM(J1,J2)/PS
70494 150 CONTINUE
70495 160 CONTINUE
70496
70497C...Find eigenvalues to matrix (third degree equation).
70498 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
70499 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
70500 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
70501 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
70502 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
70503 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
70504 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
70505 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
70506 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
70507 IF(P(N+2,4).LT.1D-5) THEN
70508 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
70509 SPH=-1D0
70510 APL=-1D0
70511 RETURN
70512 ENDIF
70513
70514C...Find first and last eigenvector by solving equation system.
70515 DO 240 I=1,3,2
70516 DO 180 J1=1,3
70517 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
70518 DO 170 J2=J1+1,3
70519 SV(J1,J2)=SM(J1,J2)
70520 SV(J2,J1)=SM(J1,J2)
70521 170 CONTINUE
70522 180 CONTINUE
70523 SMAX=0D0
70524 DO 200 J1=1,3
70525 DO 190 J2=1,3
70526 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
70527 JA=J1
70528 JB=J2
70529 SMAX=ABS(SV(J1,J2))
70530 190 CONTINUE
70531 200 CONTINUE
70532 SMAX=0D0
70533 DO 220 J3=JA+1,JA+2
70534 J1=J3-3*((J3-1)/3)
70535 RL=SV(J1,JB)/SV(JA,JB)
70536 DO 210 J2=1,3
70537 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
70538 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
70539 JC=J1
70540 SMAX=ABS(SV(J1,J2))
70541 210 CONTINUE
70542 220 CONTINUE
70543 JB1=JB+1-3*(JB/3)
70544 JB2=JB+2-3*((JB+1)/3)
70545 P(N+I,JB1)=-SV(JC,JB2)
70546 P(N+I,JB2)=SV(JC,JB1)
70547 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
70548 & SV(JA,JB)
70549 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
70550 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70551 DO 230 J=1,3
70552 P(N+I,J)=SGN*P(N+I,J)/PA
70553 230 CONTINUE
70554 240 CONTINUE
70555
70556C...Middle axis orthogonal to other two. Fill other codes.
70557 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70558 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
70559 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
70560 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
70561 DO 260 I=1,3
70562 K(N+I,1)=31
70563 K(N+I,2)=95
70564 K(N+I,3)=I
70565 K(N+I,4)=0
70566 K(N+I,5)=0
70567 P(N+I,5)=0D0
70568 DO 250 J=1,5
70569 V(I,J)=0D0
70570 250 CONTINUE
70571 260 CONTINUE
70572
70573C...Calculate sphericity and aplanarity. Select storing option.
70574 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
70575 APL=1.5D0*P(N+3,4)
70576 MSTU(61)=N+1
70577 MSTU(62)=NP
70578 IF(MSTU(43).LE.1) MSTU(3)=3
70579 IF(MSTU(43).GE.2) N=N+3
70580
70581 RETURN
70582 END
70583
70584C*********************************************************************
70585
70586C...PYTHRU
70587C...Performs thrust analysis to give thrust, oblateness
70588C...and the related event axes.
70589
70590 SUBROUTINE PYTHRU(THR,OBL)
70591
70592C...Double precision and integer declarations.
70593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70594 IMPLICIT INTEGER(I-N)
70595 INTEGER PYK,PYCHGE,PYCOMP
70596C...Parameter statement to help give large particle numbers.
70597 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70598 &KEXCIT=4000000,KDIMEN=5000000)
70599C...Commonblocks.
70600 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70601 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70602 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70603 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70604C...Local arrays.
70605 DIMENSION TDI(3),TPR(3)
70606
70607C...Take copy of particles that are to be considered in thrust analysis.
70608 NP=0
70609 PS=0D0
70610 DO 100 I=1,N
70611 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
70612 IF(MSTU(41).GE.2) THEN
70613 KC=PYCOMP(K(I,2))
70614 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70615 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70616 & K(I,2).EQ.KSUSY1+39) GOTO 100
70617 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
70618 & GOTO 100
70619 ENDIF
70620 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
70621 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
70622 THR=-2D0
70623 OBL=-2D0
70624 RETURN
70625 ENDIF
70626 NP=NP+1
70627 K(N+NP,1)=23
70628 P(N+NP,1)=P(I,1)
70629 P(N+NP,2)=P(I,2)
70630 P(N+NP,3)=P(I,3)
70631 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70632 P(N+NP,5)=1D0
70633 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
70634 & P(N+NP,4)**(PARU(42)-1D0)
70635 PS=PS+P(N+NP,4)*P(N+NP,5)
70636 100 CONTINUE
70637
70638C...Very low multiplicities (0 or 1) not considered.
70639 IF(NP.LE.1) THEN
70640 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
70641 THR=-1D0
70642 OBL=-1D0
70643 RETURN
70644 ENDIF
70645
70646C...Loop over thrust and major. T axis along z direction in latter case.
70647 DO 320 ILD=1,2
70648 IF(ILD.EQ.2) THEN
70649 K(N+NP+1,1)=31
70650 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
70651 MSTU(33)=1
70652 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
70653 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
70654 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
70655 ENDIF
70656
70657C...Find and order particles with highest p (pT for major).
70658 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
70659 P(ILF,4)=0D0
70660 110 CONTINUE
70661 DO 160 I=N+1,N+NP
70662 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
70663 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
70664 IF(P(I,4).LE.P(ILF,4)) GOTO 140
70665 DO 120 J=1,5
70666 P(ILF+1,J)=P(ILF,J)
70667 120 CONTINUE
70668 130 CONTINUE
70669 ILF=N+NP+3
70670 140 DO 150 J=1,5
70671 P(ILF+1,J)=P(I,J)
70672 150 CONTINUE
70673 160 CONTINUE
70674
70675C...Find and order initial axes with highest thrust (major).
70676 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
70677 P(ILG,4)=0D0
70678 170 CONTINUE
70679 NC=2**(MIN(MSTU(44),NP)-1)
70680 DO 250 ILC=1,NC
70681 DO 180 J=1,3
70682 TDI(J)=0D0
70683 180 CONTINUE
70684 DO 200 ILF=1,MIN(MSTU(44),NP)
70685 SGN=P(N+NP+ILF+3,5)
70686 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
70687 DO 190 J=1,4-ILD
70688 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
70689 190 CONTINUE
70690 200 CONTINUE
70691 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
70692 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
70693 IF(TDS.LE.P(ILG,4)) GOTO 230
70694 DO 210 J=1,4
70695 P(ILG+1,J)=P(ILG,J)
70696 210 CONTINUE
70697 220 CONTINUE
70698 ILG=N+NP+MSTU(44)+4
70699 230 DO 240 J=1,3
70700 P(ILG+1,J)=TDI(J)
70701 240 CONTINUE
70702 P(ILG+1,4)=TDS
70703 250 CONTINUE
70704
70705C...Iterate direction of axis until stable maximum.
70706 P(N+NP+ILD,4)=0D0
70707 ILG=0
70708 260 ILG=ILG+1
70709 THP=0D0
70710 270 THPS=THP
70711 DO 280 J=1,3
70712 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
70713 IF(THP.GT.1D-10) TDI(J)=TPR(J)
70714 TPR(J)=0D0
70715 280 CONTINUE
70716 DO 300 I=N+1,N+NP
70717 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
70718 DO 290 J=1,4-ILD
70719 TPR(J)=TPR(J)+SGN*P(I,J)
70720 290 CONTINUE
70721 300 CONTINUE
70722 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
70723 IF(THP.GE.THPS+PARU(48)) GOTO 270
70724
70725C...Save good axis. Try new initial axis until a number of tries agree.
70726 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
70727 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
70728 IAGR=0
70729 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70730 DO 310 J=1,3
70731 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
70732 310 CONTINUE
70733 P(N+NP+ILD,4)=THP
70734 P(N+NP+ILD,5)=0D0
70735 ENDIF
70736 IAGR=IAGR+1
70737 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
70738 320 CONTINUE
70739
70740C...Find minor axis and value by orthogonality.
70741 SGN=(-1D0)**INT(PYR(0)+0.5D0)
70742 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
70743 P(N+NP+3,2)=SGN*P(N+NP+2,1)
70744 P(N+NP+3,3)=0D0
70745 THP=0D0
70746 DO 330 I=N+1,N+NP
70747 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
70748 330 CONTINUE
70749 P(N+NP+3,4)=THP/PS
70750 P(N+NP+3,5)=0D0
70751
70752C...Fill axis information. Rotate back to original coordinate system.
70753 DO 350 ILD=1,3
70754 K(N+ILD,1)=31
70755 K(N+ILD,2)=96
70756 K(N+ILD,3)=ILD
70757 K(N+ILD,4)=0
70758 K(N+ILD,5)=0
70759 DO 340 J=1,5
70760 P(N+ILD,J)=P(N+NP+ILD,J)
70761 V(N+ILD,J)=0D0
70762 340 CONTINUE
70763 350 CONTINUE
70764 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
70765
70766C...Calculate thrust and oblateness. Select storing option.
70767 THR=P(N+1,4)
70768 OBL=P(N+2,4)-P(N+3,4)
70769 MSTU(61)=N+1
70770 MSTU(62)=NP
70771 IF(MSTU(43).LE.1) MSTU(3)=3
70772 IF(MSTU(43).GE.2) N=N+3
70773
70774 RETURN
70775 END
70776
70777C*********************************************************************
70778
70779C...PYCLUS
70780C...Subdivides the particle content of an event into jets/clusters.
70781
70782 SUBROUTINE PYCLUS(NJET)
70783
70784C...Double precision and integer declarations.
70785 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70786 IMPLICIT INTEGER(I-N)
70787 INTEGER PYK,PYCHGE,PYCOMP
70788C...Parameter statement to help give large particle numbers.
70789 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70790 &KEXCIT=4000000,KDIMEN=5000000)
70791C...Commonblocks.
70792 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70793 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70794 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70795 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
70796C...Local arrays and saved variables.
70797 DIMENSION PS(5)
70798 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
70799
70800C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
70801 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
70802 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
70803 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
70804 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
70805 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
70806 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
70807
70808C...If first time, reset. If reentering, skip preliminaries.
70809 IF(MSTU(48).LE.0) THEN
70810 NP=0
70811 DO 100 J=1,5
70812 PS(J)=0D0
70813 100 CONTINUE
70814 PSS=0D0
70815 PIMASS=PMAS(PYCOMP(211),1)
70816 ELSE
70817 NJET=NSAV
70818 IF(MSTU(43).GE.2) N=N-NJET
70819 DO 110 I=N+1,N+NJET
70820 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70821 110 CONTINUE
70822 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
70823 R2ACC=PARU(44)**2
70824 ELSE
70825 R2ACC=PARU(45)*PS(5)**2
70826 ENDIF
70827 NLOOP=0
70828 GOTO 300
70829 ENDIF
70830
70831C...Find which particles are to be considered in cluster search.
70832 DO 140 I=1,N
70833 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
70834 IF(MSTU(41).GE.2) THEN
70835 KC=PYCOMP(K(I,2))
70836 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70837 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70838 & K(I,2).EQ.KSUSY1+39) GOTO 140
70839 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
70840 & GOTO 140
70841 ENDIF
70842 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
70843 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
70844 NJET=-1
70845 RETURN
70846 ENDIF
70847
70848C...Take copy of these particles, with space left for jets later on.
70849 NP=NP+1
70850 K(N+NP,3)=I
70851 DO 120 J=1,5
70852 P(N+NP,J)=P(I,J)
70853 120 CONTINUE
70854 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
70855 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
70856 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
70857 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
70858 DO 130 J=1,4
70859 PS(J)=PS(J)+P(N+NP,J)
70860 130 CONTINUE
70861 PSS=PSS+P(N+NP,5)
70862 140 CONTINUE
70863 DO 160 I=N+1,N+NP
70864 K(I+NP,3)=K(I,3)
70865 DO 150 J=1,5
70866 P(I+NP,J)=P(I,J)
70867 150 CONTINUE
70868 160 CONTINUE
70869 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
70870
70871C...Very low multiplicities not considered.
70872 IF(NP.LT.MSTU(47)) THEN
70873 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
70874 NJET=-1
70875 RETURN
70876 ENDIF
70877
70878C...Find precluster configuration. If too few jets, make harder cuts.
70879 NLOOP=0
70880 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
70881 R2ACC=PARU(44)**2
70882 ELSE
70883 R2ACC=PARU(45)*PS(5)**2
70884 ENDIF
70885 RINIT=1.25D0*PARU(43)
70886 IF(NP.LE.MSTU(47)+2) RINIT=0D0
70887 170 RINIT=0.8D0*RINIT
70888 NPRE=0
70889 NREM=NP
70890 DO 180 I=N+NP+1,N+2*NP
70891 K(I,4)=0
70892 180 CONTINUE
70893
70894C...Sum up small momentum region. Jet if enough absolute momentum.
70895 IF(MSTU(46).LE.2) THEN
70896 DO 190 J=1,4
70897 P(N+1,J)=0D0
70898 190 CONTINUE
70899 DO 210 I=N+NP+1,N+2*NP
70900 IF(P(I,5).GT.2D0*RINIT) GOTO 210
70901 NREM=NREM-1
70902 K(I,4)=1
70903 DO 200 J=1,4
70904 P(N+1,J)=P(N+1,J)+P(I,J)
70905 200 CONTINUE
70906 210 CONTINUE
70907 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
70908 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
70909 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
70910 IF(NREM.EQ.0) GOTO 170
70911 ENDIF
70912
70913C...Find fastest remaining particle.
70914 220 NPRE=NPRE+1
70915 PMAX=0D0
70916 DO 230 I=N+NP+1,N+2*NP
70917 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
70918 IMAX=I
70919 PMAX=P(I,5)
70920 230 CONTINUE
70921 DO 240 J=1,5
70922 P(N+NPRE,J)=P(IMAX,J)
70923 240 CONTINUE
70924 NREM=NREM-1
70925 K(IMAX,4)=NPRE
70926
70927C...Sum up precluster around it according to pT separation.
70928 IF(MSTU(46).LE.2) THEN
70929 DO 260 I=N+NP+1,N+2*NP
70930 IF(K(I,4).NE.0) GOTO 260
70931 R2=R2T(I,IMAX)
70932 IF(R2.GT.RINIT**2) GOTO 260
70933 NREM=NREM-1
70934 K(I,4)=NPRE
70935 DO 250 J=1,4
70936 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
70937 250 CONTINUE
70938 260 CONTINUE
70939 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
70940
70941C...Sum up precluster around it according to mass or
70942C...Durham pT separation.
70943 ELSE
70944 270 IMIN=0
70945 R2MIN=RINIT**2
70946 DO 280 I=N+NP+1,N+2*NP
70947 IF(K(I,4).NE.0) GOTO 280
70948 IF(MSTU(46).LE.4) THEN
70949 R2=R2M(I,N+NPRE)
70950 ELSE
70951 R2=R2D(I,N+NPRE)
70952 ENDIF
70953 IF(R2.GE.R2MIN) GOTO 280
70954 IMIN=I
70955 R2MIN=R2
70956 280 CONTINUE
70957 IF(IMIN.NE.0) THEN
70958 DO 290 J=1,4
70959 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
70960 290 CONTINUE
70961 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
70962 NREM=NREM-1
70963 K(IMIN,4)=NPRE
70964 GOTO 270
70965 ENDIF
70966 ENDIF
70967
70968C...Check if more preclusters to be found. Start over if too few.
70969 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
70970 IF(NREM.GT.0) GOTO 220
70971 NJET=NPRE
70972
70973C...Reassign all particles to nearest jet. Sum up new jet momenta.
70974 300 TSAV=0D0
70975 PSJT=0D0
70976 310 IF(MSTU(46).LE.1) THEN
70977 DO 330 I=N+1,N+NJET
70978 DO 320 J=1,4
70979 V(I,J)=0D0
70980 320 CONTINUE
70981 330 CONTINUE
70982 DO 360 I=N+NP+1,N+2*NP
70983 R2MIN=PSS**2
70984 DO 340 IJET=N+1,N+NJET
70985 IF(P(IJET,5).LT.RINIT) GOTO 340
70986 R2=R2T(I,IJET)
70987 IF(R2.GE.R2MIN) GOTO 340
70988 IMIN=IJET
70989 R2MIN=R2
70990 340 CONTINUE
70991 K(I,4)=IMIN-N
70992 DO 350 J=1,4
70993 V(IMIN,J)=V(IMIN,J)+P(I,J)
70994 350 CONTINUE
70995 360 CONTINUE
70996 PSJT=0D0
70997 DO 380 I=N+1,N+NJET
70998 DO 370 J=1,4
70999 P(I,J)=V(I,J)
71000 370 CONTINUE
71001 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71002 PSJT=PSJT+P(I,5)
71003 380 CONTINUE
71004 ENDIF
71005
71006C...Find two closest jets.
71007 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
71008 DO 400 ITRY1=N+1,N+NJET-1
71009 DO 390 ITRY2=ITRY1+1,N+NJET
71010 IF(MSTU(46).LE.2) THEN
71011 R2=R2T(ITRY1,ITRY2)
71012 ELSEIF(MSTU(46).LE.4) THEN
71013 R2=R2M(ITRY1,ITRY2)
71014 ELSE
71015 R2=R2D(ITRY1,ITRY2)
71016 ENDIF
71017 IF(R2.GE.R2MIN) GOTO 390
71018 IMIN1=ITRY1
71019 IMIN2=ITRY2
71020 R2MIN=R2
71021 390 CONTINUE
71022 400 CONTINUE
71023
71024C...If allowed, join two closest jets and start over.
71025 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
71026 IREC=MIN(IMIN1,IMIN2)
71027 IDEL=MAX(IMIN1,IMIN2)
71028 DO 410 J=1,4
71029 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
71030 410 CONTINUE
71031 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
71032 DO 430 I=IDEL+1,N+NJET
71033 DO 420 J=1,5
71034 P(I-1,J)=P(I,J)
71035 420 CONTINUE
71036 430 CONTINUE
71037 IF(MSTU(46).GE.2) THEN
71038 DO 440 I=N+NP+1,N+2*NP
71039 IORI=N+K(I,4)
71040 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
71041 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
71042 440 CONTINUE
71043 ENDIF
71044 NJET=NJET-1
71045 GOTO 300
71046
71047C...Divide up broad jet if empty cluster in list of final ones.
71048 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
71049 DO 450 I=N+1,N+NJET
71050 K(I,5)=0
71051 450 CONTINUE
71052 DO 460 I=N+NP+1,N+2*NP
71053 K(N+K(I,4),5)=K(N+K(I,4),5)+1
71054 460 CONTINUE
71055 IEMP=0
71056 DO 470 I=N+1,N+NJET
71057 IF(K(I,5).EQ.0) IEMP=I
71058 470 CONTINUE
71059 IF(IEMP.NE.0) THEN
71060 NLOOP=NLOOP+1
71061 ISPL=0
71062 R2MAX=0D0
71063 DO 480 I=N+NP+1,N+2*NP
71064 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
71065 IJET=N+K(I,4)
71066 R2=R2T(I,IJET)
71067 IF(R2.LE.R2MAX) GOTO 480
71068 ISPL=I
71069 R2MAX=R2
71070 480 CONTINUE
71071 IF(ISPL.NE.0) THEN
71072 IJET=N+K(ISPL,4)
71073 DO 490 J=1,4
71074 P(IEMP,J)=P(ISPL,J)
71075 P(IJET,J)=P(IJET,J)-P(ISPL,J)
71076 490 CONTINUE
71077 P(IEMP,5)=P(ISPL,5)
71078 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
71079 IF(NLOOP.LE.2) GOTO 300
71080 ENDIF
71081 ENDIF
71082 ENDIF
71083
71084C...If generalized thrust has not yet converged, continue iteration.
71085 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
71086 &THEN
71087 TSAV=PSJT/PSS
71088 GOTO 310
71089 ENDIF
71090
71091C...Reorder jets according to energy.
71092 DO 510 I=N+1,N+NJET
71093 DO 500 J=1,5
71094 V(I,J)=P(I,J)
71095 500 CONTINUE
71096 510 CONTINUE
71097 DO 540 INEW=N+1,N+NJET
71098 PEMAX=0D0
71099 DO 520 ITRY=N+1,N+NJET
71100 IF(V(ITRY,4).LE.PEMAX) GOTO 520
71101 IMAX=ITRY
71102 PEMAX=V(ITRY,4)
71103 520 CONTINUE
71104 K(INEW,1)=31
71105 K(INEW,2)=97
71106 K(INEW,3)=INEW-N
71107 K(INEW,4)=0
71108 DO 530 J=1,5
71109 P(INEW,J)=V(IMAX,J)
71110 530 CONTINUE
71111 V(IMAX,4)=-1D0
71112 K(IMAX,5)=INEW
71113 540 CONTINUE
71114
71115C...Clean up particle-jet assignments and jet information.
71116 DO 550 I=N+NP+1,N+2*NP
71117 IORI=K(N+K(I,4),5)
71118 K(I,4)=IORI-N
71119 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
71120 K(IORI,4)=K(IORI,4)+1
71121 550 CONTINUE
71122 IEMP=0
71123 PSJT=0D0
71124 DO 570 I=N+1,N+NJET
71125 K(I,5)=0
71126 PSJT=PSJT+P(I,5)
71127 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
71128 DO 560 J=1,5
71129 V(I,J)=0D0
71130 560 CONTINUE
71131 IF(K(I,4).EQ.0) IEMP=I
71132 570 CONTINUE
71133
71134C...Select storing option. Output variables. Check for failure.
71135 MSTU(61)=N+1
71136 MSTU(62)=NP
71137 MSTU(63)=NPRE
71138 PARU(61)=PS(5)
71139 PARU(62)=PSJT/PSS
71140 PARU(63)=SQRT(R2MIN)
71141 IF(NJET.LE.1) PARU(63)=0D0
71142 IF(IEMP.NE.0) THEN
71143 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
71144 NJET=-1
71145 RETURN
71146 ENDIF
71147 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
71148 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
71149 NSAV=NJET
71150
71151 RETURN
71152 END
71153
71154C*********************************************************************
71155
71156C...PYCELL
71157C...Provides a simple way of jet finding in eta-phi-ET coordinates,
71158C...as used for calorimeters at hadron colliders.
71159
71160 SUBROUTINE PYCELL(NJET)
71161
71162C...Double precision and integer declarations.
71163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71164 IMPLICIT INTEGER(I-N)
71165 INTEGER PYK,PYCHGE,PYCOMP
71166C...Parameter statement to help give large particle numbers.
71167 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71168 &KEXCIT=4000000,KDIMEN=5000000)
71169C...Commonblocks.
71170 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71172 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71173 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71174
71175C...Loop over all particles. Find cell that was hit by given particle.
71176 PTLRAT=1D0/SINH(PARU(51))**2
71177 NP=0
71178 NC=N
71179 DO 110 I=1,N
71180 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
71181 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
71182 IF(MSTU(41).GE.2) THEN
71183 KC=PYCOMP(K(I,2))
71184 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71185 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71186 & K(I,2).EQ.KSUSY1+39) GOTO 110
71187 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71188 & GOTO 110
71189 ENDIF
71190 NP=NP+1
71191 PT=SQRT(P(I,1)**2+P(I,2)**2)
71192 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
71193 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
71194 & (ETA/PARU(51)+1D0))))
71195 PHI=PYANGL(P(I,1),P(I,2))
71196 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
71197 & (PHI/PARU(1)+1D0))))
71198 IETPH=MSTU(52)*IETA+IPHI
71199
71200C...Add to cell already hit, or book new cell.
71201 DO 100 IC=N+1,NC
71202 IF(IETPH.EQ.K(IC,3)) THEN
71203 K(IC,4)=K(IC,4)+1
71204 P(IC,5)=P(IC,5)+PT
71205 GOTO 110
71206 ENDIF
71207 100 CONTINUE
71208 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
71209 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
71210 NJET=-2
71211 RETURN
71212 ENDIF
71213 NC=NC+1
71214 K(NC,3)=IETPH
71215 K(NC,4)=1
71216 K(NC,5)=2
71217 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
71218 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
71219 P(NC,5)=PT
71220 110 CONTINUE
71221
71222C...Smear true bin content by calorimeter resolution.
71223 IF(MSTU(53).GE.1) THEN
71224 DO 130 IC=N+1,NC
71225 PEI=P(IC,5)
71226 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
71227 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
71228 & COS(PARU(2)*PYR(0))
71229 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
71230 P(IC,5)=PEF
71231 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
71232 130 CONTINUE
71233 ENDIF
71234
71235C...Remove cells below threshold.
71236 IF(PARU(58).GT.0D0) THEN
71237 NCC=NC
71238 NC=N
71239 DO 140 IC=N+1,NCC
71240 IF(P(IC,5).GT.PARU(58)) THEN
71241 NC=NC+1
71242 K(NC,3)=K(IC,3)
71243 K(NC,4)=K(IC,4)
71244 K(NC,5)=K(IC,5)
71245 P(NC,1)=P(IC,1)
71246 P(NC,2)=P(IC,2)
71247 P(NC,5)=P(IC,5)
71248 ENDIF
71249 140 CONTINUE
71250 ENDIF
71251
71252C...Find initiator cell: the one with highest pT of not yet used ones.
71253 NJ=NC
71254 150 ETMAX=0D0
71255 DO 160 IC=N+1,NC
71256 IF(K(IC,5).NE.2) GOTO 160
71257 IF(P(IC,5).LE.ETMAX) GOTO 160
71258 ICMAX=IC
71259 ETA=P(IC,1)
71260 PHI=P(IC,2)
71261 ETMAX=P(IC,5)
71262 160 CONTINUE
71263 IF(ETMAX.LT.PARU(52)) GOTO 220
71264 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
71265 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
71266 NJET=-2
71267 RETURN
71268 ENDIF
71269 K(ICMAX,5)=1
71270 NJ=NJ+1
71271 K(NJ,4)=0
71272 K(NJ,5)=1
71273 P(NJ,1)=ETA
71274 P(NJ,2)=PHI
71275 P(NJ,3)=0D0
71276 P(NJ,4)=0D0
71277 P(NJ,5)=0D0
71278
71279C...Sum up unused cells within required distance of initiator.
71280 DO 170 IC=N+1,NC
71281 IF(K(IC,5).EQ.0) GOTO 170
71282 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
71283 DPHIA=ABS(P(IC,2)-PHI)
71284 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
71285 PHIC=P(IC,2)
71286 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
71287 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
71288 K(IC,5)=-K(IC,5)
71289 K(NJ,4)=K(NJ,4)+K(IC,4)
71290 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
71291 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
71292 P(NJ,5)=P(NJ,5)+P(IC,5)
71293 170 CONTINUE
71294
71295C...Reject cluster below minimum ET, else accept.
71296 IF(P(NJ,5).LT.PARU(53)) THEN
71297 NJ=NJ-1
71298 DO 180 IC=N+1,NC
71299 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
71300 180 CONTINUE
71301 ELSEIF(MSTU(54).LE.2) THEN
71302 P(NJ,3)=P(NJ,3)/P(NJ,5)
71303 P(NJ,4)=P(NJ,4)/P(NJ,5)
71304 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
71305 & P(NJ,4))
71306 DO 190 IC=N+1,NC
71307 IF(K(IC,5).LT.0) K(IC,5)=0
71308 190 CONTINUE
71309 ELSE
71310 DO 200 J=1,4
71311 P(NJ,J)=0D0
71312 200 CONTINUE
71313 DO 210 IC=N+1,NC
71314 IF(K(IC,5).GE.0) GOTO 210
71315 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
71316 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
71317 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
71318 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
71319 K(IC,5)=0
71320 210 CONTINUE
71321 ENDIF
71322 GOTO 150
71323
71324C...Arrange clusters in falling ET sequence.
71325 220 DO 250 I=1,NJ-NC
71326 ETMAX=0D0
71327 DO 230 IJ=NC+1,NJ
71328 IF(K(IJ,5).EQ.0) GOTO 230
71329 IF(P(IJ,5).LT.ETMAX) GOTO 230
71330 IJMAX=IJ
71331 ETMAX=P(IJ,5)
71332 230 CONTINUE
71333 K(IJMAX,5)=0
71334 K(N+I,1)=31
71335 K(N+I,2)=98
71336 K(N+I,3)=I
71337 K(N+I,4)=K(IJMAX,4)
71338 K(N+I,5)=0
71339 DO 240 J=1,5
71340 P(N+I,J)=P(IJMAX,J)
71341 V(N+I,J)=0D0
71342 240 CONTINUE
71343 250 CONTINUE
71344 NJET=NJ-NC
71345
71346C...Convert to massless or massive four-vectors.
71347 IF(MSTU(54).EQ.2) THEN
71348 DO 260 I=N+1,N+NJET
71349 ETA=P(I,3)
71350 P(I,1)=P(I,5)*COS(P(I,4))
71351 P(I,2)=P(I,5)*SIN(P(I,4))
71352 P(I,3)=P(I,5)*SINH(ETA)
71353 P(I,4)=P(I,5)*COSH(ETA)
71354 P(I,5)=0D0
71355 260 CONTINUE
71356 ELSEIF(MSTU(54).GE.3) THEN
71357 DO 270 I=N+1,N+NJET
71358 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
71359 270 CONTINUE
71360 ENDIF
71361
71362C...Information about storage.
71363 MSTU(61)=N+1
71364 MSTU(62)=NP
71365 MSTU(63)=NC-N
71366 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
71367 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
71368
71369 RETURN
71370 END
71371
71372C*********************************************************************
71373
71374C...PYJMAS
71375C...Determines, approximately, the two jet masses that minimize
71376C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
71377
71378 SUBROUTINE PYJMAS(PMH,PML)
71379
71380C...Double precision and integer declarations.
71381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71382 IMPLICIT INTEGER(I-N)
71383 INTEGER PYK,PYCHGE,PYCOMP
71384C...Parameter statement to help give large particle numbers.
71385 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71386 &KEXCIT=4000000,KDIMEN=5000000)
71387C...Commonblocks.
71388 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71392C...Local arrays.
71393 DIMENSION SM(3,3),SAX(3),PS(3,5)
71394
71395C...Reset.
71396 NP=0
71397 DO 120 J1=1,3
71398 DO 100 J2=J1,3
71399 SM(J1,J2)=0D0
71400 100 CONTINUE
71401 DO 110 J2=1,4
71402 PS(J1,J2)=0D0
71403 110 CONTINUE
71404 120 CONTINUE
71405 PSS=0D0
71406 PIMASS=PMAS(PYCOMP(211),1)
71407
71408C...Take copy of particles that are to be considered in mass analysis.
71409 DO 170 I=1,N
71410 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
71411 IF(MSTU(41).GE.2) THEN
71412 KC=PYCOMP(K(I,2))
71413 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71414 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71415 & K(I,2).EQ.KSUSY1+39) GOTO 170
71416 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71417 & GOTO 170
71418 ENDIF
71419 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
71420 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
71421 PMH=-2D0
71422 PML=-2D0
71423 RETURN
71424 ENDIF
71425 NP=NP+1
71426 DO 130 J=1,5
71427 P(N+NP,J)=P(I,J)
71428 130 CONTINUE
71429 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
71430 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
71431 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
71432
71433C...Fill information in sphericity tensor and total momentum vector.
71434 DO 150 J1=1,3
71435 DO 140 J2=J1,3
71436 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
71437 140 CONTINUE
71438 150 CONTINUE
71439 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71440 DO 160 J=1,4
71441 PS(3,J)=PS(3,J)+P(N+NP,J)
71442 160 CONTINUE
71443 170 CONTINUE
71444
71445C...Very low multiplicities (0 or 1) not considered.
71446 IF(NP.LE.1) THEN
71447 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
71448 PMH=-1D0
71449 PML=-1D0
71450 RETURN
71451 ENDIF
71452 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
71453 &PS(3,3)**2))
71454
71455C...Find largest eigenvalue to matrix (third degree equation).
71456 DO 190 J1=1,3
71457 DO 180 J2=J1,3
71458 SM(J1,J2)=SM(J1,J2)/PSS
71459 180 CONTINUE
71460 190 CONTINUE
71461 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71462 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71463 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71464 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71465 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71466 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71467 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71468
71469C...Find largest eigenvector by solving equation system.
71470 DO 210 J1=1,3
71471 SM(J1,J1)=SM(J1,J1)-SMA
71472 DO 200 J2=J1+1,3
71473 SM(J2,J1)=SM(J1,J2)
71474 200 CONTINUE
71475 210 CONTINUE
71476 SMAX=0D0
71477 DO 230 J1=1,3
71478 DO 220 J2=1,3
71479 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
71480 JA=J1
71481 JB=J2
71482 SMAX=ABS(SM(J1,J2))
71483 220 CONTINUE
71484 230 CONTINUE
71485 SMAX=0D0
71486 DO 250 J3=JA+1,JA+2
71487 J1=J3-3*((J3-1)/3)
71488 RL=SM(J1,JB)/SM(JA,JB)
71489 DO 240 J2=1,3
71490 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
71491 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
71492 JC=J1
71493 SMAX=ABS(SM(J1,J2))
71494 240 CONTINUE
71495 250 CONTINUE
71496 JB1=JB+1-3*(JB/3)
71497 JB2=JB+2-3*((JB+1)/3)
71498 SAX(JB1)=-SM(JC,JB2)
71499 SAX(JB2)=SM(JC,JB1)
71500 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
71501
71502C...Divide particles into two initial clusters by hemisphere.
71503 DO 270 I=N+1,N+NP
71504 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
71505 IS=1
71506 IF(PSAX.LT.0D0) IS=2
71507 K(I,3)=IS
71508 DO 260 J=1,4
71509 PS(IS,J)=PS(IS,J)+P(I,J)
71510 260 CONTINUE
71511 270 CONTINUE
71512 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
71513 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
71514
71515C...Reassign one particle at a time; find maximum decrease of m^2 sum.
71516 280 PMD=0D0
71517 IM=0
71518 DO 290 J=1,4
71519 PS(3,J)=PS(1,J)-PS(2,J)
71520 290 CONTINUE
71521 DO 300 I=N+1,N+NP
71522 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)
71523 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
71524 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
71525 IF(PMDI.LT.PMD) THEN
71526 PMD=PMDI
71527 IM=I
71528 ENDIF
71529 300 CONTINUE
71530
71531C...Loop back if significant reduction in sum of m^2.
71532 IF(PMD.LT.-PARU(48)*PMS) THEN
71533 PMS=PMS+PMD
71534 IS=K(IM,3)
71535 DO 310 J=1,4
71536 PS(IS,J)=PS(IS,J)-P(IM,J)
71537 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
71538 310 CONTINUE
71539 K(IM,3)=3-IS
71540 GOTO 280
71541 ENDIF
71542
71543C...Final masses and output.
71544 MSTU(61)=N+1
71545 MSTU(62)=NP
71546 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
71547 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
71548 PMH=MAX(PS(1,5),PS(2,5))
71549 PML=MIN(PS(1,5),PS(2,5))
71550
71551 RETURN
71552 END
71553
71554C*********************************************************************
71555
71556C...PYFOWO
71557C...Calculates the first few Fox-Wolfram moments.
71558
71559 SUBROUTINE PYFOWO(H10,H20,H30,H40)
71560
71561C...Double precision and integer declarations.
71562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71563 IMPLICIT INTEGER(I-N)
71564 INTEGER PYK,PYCHGE,PYCOMP
71565C...Parameter statement to help give large particle numbers.
71566 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71567 &KEXCIT=4000000,KDIMEN=5000000)
71568C...Commonblocks.
71569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71572 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71573
71574C...Copy momenta for particles and calculate H0.
71575 NP=0
71576 H0=0D0
71577 HD=0D0
71578 DO 110 I=1,N
71579 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
71580 IF(MSTU(41).GE.2) THEN
71581 KC=PYCOMP(K(I,2))
71582 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71583 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71584 & K(I,2).EQ.KSUSY1+39) GOTO 110
71585 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71586 & GOTO 110
71587 ENDIF
71588 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
71589 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
71590 H10=-1D0
71591 H20=-1D0
71592 H30=-1D0
71593 H40=-1D0
71594 RETURN
71595 ENDIF
71596 NP=NP+1
71597 DO 100 J=1,3
71598 P(N+NP,J)=P(I,J)
71599 100 CONTINUE
71600 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71601 H0=H0+P(N+NP,4)
71602 HD=HD+P(N+NP,4)**2
71603 110 CONTINUE
71604 H0=H0**2
71605
71606C...Very low multiplicities (0 or 1) not considered.
71607 IF(NP.LE.1) THEN
71608 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
71609 H10=-1D0
71610 H20=-1D0
71611 H30=-1D0
71612 H40=-1D0
71613 RETURN
71614 ENDIF
71615
71616C...Calculate H1 - H4.
71617 H10=0D0
71618 H20=0D0
71619 H30=0D0
71620 H40=0D0
71621 DO 130 I1=N+1,N+NP
71622 DO 120 I2=I1+1,N+NP
71623 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
71624 & (P(I1,4)*P(I2,4))
71625 H10=H10+P(I1,4)*P(I2,4)*CTHE
71626 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
71627 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
71628 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
71629 & 0.375D0)
71630 120 CONTINUE
71631 130 CONTINUE
71632
71633C...Calculate H1/H0 - H4/H0. Output.
71634 MSTU(61)=N+1
71635 MSTU(62)=NP
71636 H10=(HD+2D0*H10)/H0
71637 H20=(HD+2D0*H20)/H0
71638 H30=(HD+2D0*H30)/H0
71639 H40=(HD+2D0*H40)/H0
71640
71641 RETURN
71642 END
71643
71644C*********************************************************************
71645
71646C...PYTABU
71647C...Evaluates various properties of an event, with statistics
71648C...accumulated during the course of the run and
71649C...printed at the end.
71650
71651 SUBROUTINE PYTABU(MTABU)
71652
71653C...Double precision and integer declarations.
71654 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71655 IMPLICIT INTEGER(I-N)
71656 INTEGER PYK,PYCHGE,PYCOMP
71657C...Parameter statement to help give large particle numbers.
71658 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71659 &KEXCIT=4000000,KDIMEN=5000000)
71660C...Commonblocks.
71661 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71662 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71663 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71664 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71665 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
71666C...Local arrays, character variables, saved variables and data.
71667 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
71668 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
71669 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
71670 &KFDM(8),KFDC(200,0:8),NPDC(200)
71671 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
71672 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
71673 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
71674 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
71675 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
71676 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
71677 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
71678 &NEVDC/0/,NKFDC/0/,NREDC/0/
71679
71680C...Reset statistics on initial parton state.
71681 IF(MTABU.EQ.10) THEN
71682 NEVIS=0
71683 NKFIS=0
71684
71685C...Identify and order flavour content of initial state.
71686 ELSEIF(MTABU.EQ.11) THEN
71687 NEVIS=NEVIS+1
71688 KFM1=2*IABS(MSTU(161))
71689 IF(MSTU(161).GT.0) KFM1=KFM1-1
71690 KFM2=2*IABS(MSTU(162))
71691 IF(MSTU(162).GT.0) KFM2=KFM2-1
71692 KFMN=MIN(KFM1,KFM2)
71693 KFMX=MAX(KFM1,KFM2)
71694 DO 100 I=1,NKFIS
71695 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
71696 IKFIS=-I
71697 GOTO 110
71698 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
71699 & KFMX.LT.KFIS(I,2))) THEN
71700 IKFIS=I
71701 GOTO 110
71702 ENDIF
71703 100 CONTINUE
71704 IKFIS=NKFIS+1
71705 110 IF(IKFIS.LT.0) THEN
71706 IKFIS=-IKFIS
71707 ELSE
71708 IF(NKFIS.GE.100) RETURN
71709 DO 130 I=NKFIS,IKFIS,-1
71710 KFIS(I+1,1)=KFIS(I,1)
71711 KFIS(I+1,2)=KFIS(I,2)
71712 DO 120 J=0,10
71713 NPIS(I+1,J)=NPIS(I,J)
71714 120 CONTINUE
71715 130 CONTINUE
71716 NKFIS=NKFIS+1
71717 KFIS(IKFIS,1)=KFMN
71718 KFIS(IKFIS,2)=KFMX
71719 DO 140 J=0,10
71720 NPIS(IKFIS,J)=0
71721 140 CONTINUE
71722 ENDIF
71723 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
71724
71725C...Count number of partons in initial state.
71726 NP=0
71727 DO 160 I=1,N
71728 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
71729 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
71730 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
71731 & THEN
71732 ELSE
71733 IM=I
71734 150 IM=K(IM,3)
71735 IF(IM.LE.0.OR.IM.GT.N) THEN
71736 NP=NP+1
71737 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
71738 NP=NP+1
71739 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
71740 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
71741 & .NE.0) THEN
71742 ELSE
71743 GOTO 150
71744 ENDIF
71745 ENDIF
71746 160 CONTINUE
71747 NPCO=MAX(NP,1)
71748 IF(NP.GE.6) NPCO=6
71749 IF(NP.GE.8) NPCO=7
71750 IF(NP.GE.11) NPCO=8
71751 IF(NP.GE.16) NPCO=9
71752 IF(NP.GE.26) NPCO=10
71753 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
71754 MSTU(62)=NP
71755
71756C...Write statistics on initial parton state.
71757 ELSEIF(MTABU.EQ.12) THEN
71758 FAC=1D0/MAX(1,NEVIS)
71759 WRITE(MSTU(11),5000) NEVIS
71760 DO 170 I=1,NKFIS
71761 KFMN=KFIS(I,1)
71762 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
71763 KFM1=(KFMN+1)/2
71764 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
71765 CALL PYNAME(KFM1,CHAU)
71766 CHIS(1)=CHAU(1:12)
71767 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
71768 KFMX=KFIS(I,2)
71769 IF(KFIS(I,1).EQ.0) KFMX=0
71770 KFM2=(KFMX+1)/2
71771 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
71772 CALL PYNAME(KFM2,CHAU)
71773 CHIS(2)=CHAU(1:12)
71774 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
71775 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
71776 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
71777 170 CONTINUE
71778
71779C...Copy statistics on initial parton state into /PYJETS/.
71780 ELSEIF(MTABU.EQ.13) THEN
71781 FAC=1D0/MAX(1,NEVIS)
71782 DO 190 I=1,NKFIS
71783 KFMN=KFIS(I,1)
71784 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
71785 KFM1=(KFMN+1)/2
71786 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
71787 KFMX=KFIS(I,2)
71788 IF(KFIS(I,1).EQ.0) KFMX=0
71789 KFM2=(KFMX+1)/2
71790 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
71791 K(I,1)=32
71792 K(I,2)=99
71793 K(I,3)=KFM1
71794 K(I,4)=KFM2
71795 K(I,5)=NPIS(I,0)
71796 DO 180 J=1,5
71797 P(I,J)=FAC*NPIS(I,J)
71798 V(I,J)=FAC*NPIS(I,J+5)
71799 180 CONTINUE
71800 190 CONTINUE
71801 N=NKFIS
71802 DO 200 J=1,5
71803 K(N+1,J)=0
71804 P(N+1,J)=0D0
71805 V(N+1,J)=0D0
71806 200 CONTINUE
71807 K(N+1,1)=32
71808 K(N+1,2)=99
71809 K(N+1,5)=NEVIS
71810 MSTU(3)=1
71811
71812C...Reset statistics on number of particles/partons.
71813 ELSEIF(MTABU.EQ.20) THEN
71814 NEVFS=0
71815 NPRFS=0
71816 NFIFS=0
71817 NCHFS=0
71818 NKFFS=0
71819
71820C...Identify whether particle/parton is primary or not.
71821 ELSEIF(MTABU.EQ.21) THEN
71822 NEVFS=NEVFS+1
71823 MSTU(62)=0
71824 DO 260 I=1,N
71825 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
71826 MSTU(62)=MSTU(62)+1
71827 KC=PYCOMP(K(I,2))
71828 MPRI=0
71829 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
71830 MPRI=1
71831 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
71832 MPRI=1
71833 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
71834 MPRI=1
71835 ELSEIF(KC.EQ.0) THEN
71836 ELSEIF(K(K(I,3),1).EQ.13) THEN
71837 IM=K(K(I,3),3)
71838 IF(IM.LE.0.OR.IM.GT.N) THEN
71839 MPRI=1
71840 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
71841 MPRI=1
71842 ENDIF
71843 ELSEIF(KCHG(KC,2).EQ.0) THEN
71844 KCM=PYCOMP(K(K(I,3),2))
71845 IF(KCM.NE.0) THEN
71846 IF(KCHG(KCM,2).NE.0) MPRI=1
71847 ENDIF
71848 ENDIF
71849 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
71850 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
71851 ENDIF
71852 IF(K(I,1).LE.10) THEN
71853 NFIFS=NFIFS+1
71854 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
71855 ENDIF
71856
71857C...Fill statistics on number of particles/partons in event.
71858 KFA=IABS(K(I,2))
71859 KFS=3-ISIGN(1,K(I,2))-MPRI
71860 DO 210 IP=1,NKFFS
71861 IF(KFA.EQ.KFFS(IP)) THEN
71862 IKFFS=-IP
71863 GOTO 220
71864 ELSEIF(KFA.LT.KFFS(IP)) THEN
71865 IKFFS=IP
71866 GOTO 220
71867 ENDIF
71868 210 CONTINUE
71869 IKFFS=NKFFS+1
71870 220 IF(IKFFS.LT.0) THEN
71871 IKFFS=-IKFFS
71872 ELSE
71873 IF(NKFFS.GE.400) RETURN
71874 DO 240 IP=NKFFS,IKFFS,-1
71875 KFFS(IP+1)=KFFS(IP)
71876 DO 230 J=1,4
71877 NPFS(IP+1,J)=NPFS(IP,J)
71878 230 CONTINUE
71879 240 CONTINUE
71880 NKFFS=NKFFS+1
71881 KFFS(IKFFS)=KFA
71882 DO 250 J=1,4
71883 NPFS(IKFFS,J)=0
71884 250 CONTINUE
71885 ENDIF
71886 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
71887 260 CONTINUE
71888
71889C...Write statistics on particle/parton composition of events.
71890 ELSEIF(MTABU.EQ.22) THEN
71891 FAC=1D0/MAX(1,NEVFS)
71892 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
71893 DO 270 I=1,NKFFS
71894 CALL PYNAME(KFFS(I),CHAU)
71895 KC=PYCOMP(KFFS(I))
71896 MDCYF=0
71897 IF(KC.NE.0) MDCYF=MDCY(KC,1)
71898 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
71899 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
71900 270 CONTINUE
71901
71902C...Copy particle/parton composition information into /PYJETS/.
71903 ELSEIF(MTABU.EQ.23) THEN
71904 FAC=1D0/MAX(1,NEVFS)
71905 DO 290 I=1,NKFFS
71906 K(I,1)=32
71907 K(I,2)=99
71908 K(I,3)=KFFS(I)
71909 K(I,4)=0
71910 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
71911 DO 280 J=1,4
71912 P(I,J)=FAC*NPFS(I,J)
71913 V(I,J)=0D0
71914 280 CONTINUE
71915 P(I,5)=FAC*K(I,5)
71916 V(I,5)=0D0
71917 290 CONTINUE
71918 N=NKFFS
71919 DO 300 J=1,5
71920 K(N+1,J)=0
71921 P(N+1,J)=0D0
71922 V(N+1,J)=0D0
71923 300 CONTINUE
71924 K(N+1,1)=32
71925 K(N+1,2)=99
71926 K(N+1,5)=NEVFS
71927 P(N+1,1)=FAC*NPRFS
71928 P(N+1,2)=FAC*NFIFS
71929 P(N+1,3)=FAC*NCHFS
71930 MSTU(3)=1
71931
71932C...Reset factorial moments statistics.
71933 ELSEIF(MTABU.EQ.30) THEN
71934 NEVFM=0
71935 NMUFM=0
71936 DO 330 IM=1,3
71937 DO 320 IB=1,10
71938 DO 310 IP=1,4
71939 FM1FM(IM,IB,IP)=0D0
71940 FM2FM(IM,IB,IP)=0D0
71941 310 CONTINUE
71942 320 CONTINUE
71943 330 CONTINUE
71944
71945C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
71946 ELSEIF(MTABU.EQ.31) THEN
71947 NEVFM=NEVFM+1
71948 NLOW=N+MSTU(3)
71949 NUPP=NLOW
71950 DO 410 I=1,N
71951 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
71952 IF(MSTU(41).GE.2) THEN
71953 KC=PYCOMP(K(I,2))
71954 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71955 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71956 & K(I,2).EQ.KSUSY1+39) GOTO 410
71957 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
71958 & PYCHGE(K(I,2)).EQ.0) GOTO 410
71959 ENDIF
71960 PMR=0D0
71961 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
71962 IF(MSTU(42).GE.2) PMR=P(I,5)
71963 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71964 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71965 & 1D20)),P(I,3))
71966 IF(ABS(YETA).GT.PARU(57)) GOTO 410
71967 PHI=PYANGL(P(I,1),P(I,2))
71968 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
71969 IYETA=MAX(0,MIN(511,IYETA))
71970 IPHI=512D0*(PHI+PARU(1))/PARU(2)
71971 IPHI=MAX(0,MIN(511,IPHI))
71972 IYEP=0
71973 DO 340 IB=0,9
71974 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
71975 340 CONTINUE
71976
71977C...Order particles in (pseudo)rapidity and/or azimuth.
71978 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
71979 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
71980 RETURN
71981 ENDIF
71982 NUPP=NUPP+1
71983 IF(NUPP.EQ.NLOW+1) THEN
71984 K(NUPP,1)=IYETA
71985 K(NUPP,2)=IPHI
71986 K(NUPP,3)=IYEP
71987 ELSE
71988 DO 350 I1=NUPP-1,NLOW+1,-1
71989 IF(IYETA.GE.K(I1,1)) GOTO 360
71990 K(I1+1,1)=K(I1,1)
71991 350 CONTINUE
71992 360 K(I1+1,1)=IYETA
71993 DO 370 I1=NUPP-1,NLOW+1,-1
71994 IF(IPHI.GE.K(I1,2)) GOTO 380
71995 K(I1+1,2)=K(I1,2)
71996 370 CONTINUE
71997 380 K(I1+1,2)=IPHI
71998 DO 390 I1=NUPP-1,NLOW+1,-1
71999 IF(IYEP.GE.K(I1,3)) GOTO 400
72000 K(I1+1,3)=K(I1,3)
72001 390 CONTINUE
72002 400 K(I1+1,3)=IYEP
72003 ENDIF
72004 410 CONTINUE
72005 K(NUPP+1,1)=2**10
72006 K(NUPP+1,2)=2**10
72007 K(NUPP+1,3)=4**10
72008
72009C...Calculate sum of factorial moments in event.
72010 DO 480 IM=1,3
72011 DO 430 IB=1,10
72012 DO 420 IP=1,4
72013 FEVFM(IB,IP)=0D0
72014 420 CONTINUE
72015 430 CONTINUE
72016 DO 450 IB=1,10
72017 IF(IM.LE.2) IBIN=2**(10-IB)
72018 IF(IM.EQ.3) IBIN=4**(10-IB)
72019 IAGR=K(NLOW+1,IM)/IBIN
72020 NAGR=1
72021 DO 440 I=NLOW+2,NUPP+1
72022 ICUT=K(I,IM)/IBIN
72023 IF(ICUT.EQ.IAGR) THEN
72024 NAGR=NAGR+1
72025 ELSE
72026 IF(NAGR.EQ.1) THEN
72027 ELSEIF(NAGR.EQ.2) THEN
72028 FEVFM(IB,1)=FEVFM(IB,1)+2D0
72029 ELSEIF(NAGR.EQ.3) THEN
72030 FEVFM(IB,1)=FEVFM(IB,1)+6D0
72031 FEVFM(IB,2)=FEVFM(IB,2)+6D0
72032 ELSEIF(NAGR.EQ.4) THEN
72033 FEVFM(IB,1)=FEVFM(IB,1)+12D0
72034 FEVFM(IB,2)=FEVFM(IB,2)+24D0
72035 FEVFM(IB,3)=FEVFM(IB,3)+24D0
72036 ELSE
72037 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
72038 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
72039 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
72040 & (NAGR-3D0)
72041 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
72042 & (NAGR-3D0)*(NAGR-4D0)
72043 ENDIF
72044 IAGR=ICUT
72045 NAGR=1
72046 ENDIF
72047 440 CONTINUE
72048 450 CONTINUE
72049
72050C...Add results to total statistics.
72051 DO 470 IB=10,1,-1
72052 DO 460 IP=1,4
72053 IF(FEVFM(1,IP).LT.0.5D0) THEN
72054 FEVFM(IB,IP)=0D0
72055 ELSEIF(IM.LE.2) THEN
72056 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
72057 ELSE
72058 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
72059 ENDIF
72060 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
72061 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
72062 460 CONTINUE
72063 470 CONTINUE
72064 480 CONTINUE
72065 NMUFM=NMUFM+(NUPP-NLOW)
72066 MSTU(62)=NUPP-NLOW
72067
72068C...Write accumulated statistics on factorial moments.
72069 ELSEIF(MTABU.EQ.32) THEN
72070 FAC=1D0/MAX(1,NEVFM)
72071 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
72072 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
72073 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
72074 DO 510 IM=1,3
72075 WRITE(MSTU(11),5500)
72076 DO 500 IB=1,10
72077 BYETA=2D0*PARU(57)
72078 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
72079 BPHI=PARU(2)
72080 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
72081 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
72082 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
72083 DO 490 IP=1,4
72084 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
72085 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
72086 & FMOMA(IP)**2)))
72087 490 CONTINUE
72088 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
72089 & IP=1,4)
72090 500 CONTINUE
72091 510 CONTINUE
72092
72093C...Copy statistics on factorial moments into /PYJETS/.
72094 ELSEIF(MTABU.EQ.33) THEN
72095 FAC=1D0/MAX(1,NEVFM)
72096 DO 540 IM=1,3
72097 DO 530 IB=1,10
72098 I=10*(IM-1)+IB
72099 K(I,1)=32
72100 K(I,2)=99
72101 K(I,3)=1
72102 IF(IM.NE.2) K(I,3)=2**(IB-1)
72103 K(I,4)=1
72104 IF(IM.NE.1) K(I,4)=2**(IB-1)
72105 K(I,5)=0
72106 P(I,1)=2D0*PARU(57)/K(I,3)
72107 V(I,1)=PARU(2)/K(I,4)
72108 DO 520 IP=1,4
72109 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
72110 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
72111 & P(I,IP+1)**2)))
72112 520 CONTINUE
72113 530 CONTINUE
72114 540 CONTINUE
72115 N=30
72116 DO 550 J=1,5
72117 K(N+1,J)=0
72118 P(N+1,J)=0D0
72119 V(N+1,J)=0D0
72120 550 CONTINUE
72121 K(N+1,1)=32
72122 K(N+1,2)=99
72123 K(N+1,5)=NEVFM
72124 MSTU(3)=1
72125
72126C...Reset statistics on Energy-Energy Correlation.
72127 ELSEIF(MTABU.EQ.40) THEN
72128 NEVEE=0
72129 DO 560 J=1,25
72130 FE1EC(J)=0D0
72131 FE2EC(J)=0D0
72132 FE1EC(51-J)=0D0
72133 FE2EC(51-J)=0D0
72134 FE1EA(J)=0D0
72135 FE2EA(J)=0D0
72136 560 CONTINUE
72137
72138C...Find particles to include, with proper assumed mass.
72139 ELSEIF(MTABU.EQ.41) THEN
72140 NEVEE=NEVEE+1
72141 NLOW=N+MSTU(3)
72142 NUPP=NLOW
72143 ECM=0D0
72144 DO 570 I=1,N
72145 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
72146 IF(MSTU(41).GE.2) THEN
72147 KC=PYCOMP(K(I,2))
72148 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72149 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72150 & K(I,2).EQ.KSUSY1+39) GOTO 570
72151 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
72152 & PYCHGE(K(I,2)).EQ.0) GOTO 570
72153 ENDIF
72154 PMR=0D0
72155 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
72156 IF(MSTU(42).GE.2) PMR=P(I,5)
72157 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
72158 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
72159 RETURN
72160 ENDIF
72161 NUPP=NUPP+1
72162 P(NUPP,1)=P(I,1)
72163 P(NUPP,2)=P(I,2)
72164 P(NUPP,3)=P(I,3)
72165 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72166 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
72167 ECM=ECM+P(NUPP,4)
72168 570 CONTINUE
72169 IF(NUPP.EQ.NLOW) RETURN
72170
72171C...Analyze Energy-Energy Correlation in event.
72172 FAC=(2D0/ECM**2)*50D0/PARU(1)
72173 DO 580 J=1,50
72174 FEVEE(J)=0D0
72175 580 CONTINUE
72176 DO 600 I1=NLOW+2,NUPP
72177 DO 590 I2=NLOW+1,I1-1
72178 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72179 & (P(I1,5)*P(I2,5))
72180 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
72181 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
72182 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
72183 590 CONTINUE
72184 600 CONTINUE
72185 DO 610 J=1,25
72186 FE1EC(J)=FE1EC(J)+FEVEE(J)
72187 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
72188 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
72189 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
72190 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
72191 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
72192 610 CONTINUE
72193 MSTU(62)=NUPP-NLOW
72194
72195C...Write statistics on Energy-Energy Correlation.
72196 ELSEIF(MTABU.EQ.42) THEN
72197 FAC=1D0/MAX(1,NEVEE)
72198 WRITE(MSTU(11),5700) NEVEE
72199 DO 620 J=1,25
72200 FEEC1=FAC*FE1EC(J)
72201 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
72202 FEEC2=FAC*FE1EC(51-J)
72203 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
72204 FEECA=FAC*FE1EA(J)
72205 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
72206 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
72207 & FEEC2,FEES2,FEECA,FEESA
72208 620 CONTINUE
72209
72210C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
72211 ELSEIF(MTABU.EQ.43) THEN
72212 FAC=1D0/MAX(1,NEVEE)
72213 DO 630 I=1,25
72214 K(I,1)=32
72215 K(I,2)=99
72216 K(I,3)=0
72217 K(I,4)=0
72218 K(I,5)=0
72219 P(I,1)=FAC*FE1EC(I)
72220 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
72221 P(I,2)=FAC*FE1EC(51-I)
72222 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
72223 P(I,3)=FAC*FE1EA(I)
72224 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
72225 P(I,4)=PARU(1)*(I-1)/50D0
72226 P(I,5)=PARU(1)*I/50D0
72227 V(I,4)=3.6D0*(I-1)
72228 V(I,5)=3.6D0*I
72229 630 CONTINUE
72230 N=25
72231 DO 640 J=1,5
72232 K(N+1,J)=0
72233 P(N+1,J)=0D0
72234 V(N+1,J)=0D0
72235 640 CONTINUE
72236 K(N+1,1)=32
72237 K(N+1,2)=99
72238 K(N+1,5)=NEVEE
72239 MSTU(3)=1
72240
72241C...Reset statistics on decay channels.
72242 ELSEIF(MTABU.EQ.50) THEN
72243 NEVDC=0
72244 NKFDC=0
72245 NREDC=0
72246
72247C...Identify and order flavour content of final state.
72248 ELSEIF(MTABU.EQ.51) THEN
72249 NEVDC=NEVDC+1
72250 NDS=0
72251 DO 670 I=1,N
72252 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
72253 NDS=NDS+1
72254 IF(NDS.GT.8) THEN
72255 NREDC=NREDC+1
72256 RETURN
72257 ENDIF
72258 KFM=2*IABS(K(I,2))
72259 IF(K(I,2).LT.0) KFM=KFM-1
72260 DO 650 IDS=NDS-1,1,-1
72261 IIN=IDS+1
72262 IF(KFM.LT.KFDM(IDS)) GOTO 660
72263 KFDM(IDS+1)=KFDM(IDS)
72264 650 CONTINUE
72265 IIN=1
72266 660 KFDM(IIN)=KFM
72267 670 CONTINUE
72268
72269C...Find whether old or new final state.
72270 DO 690 IDC=1,NKFDC
72271 IF(NDS.LT.KFDC(IDC,0)) THEN
72272 IKFDC=IDC
72273 GOTO 700
72274 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
72275 DO 680 I=1,NDS
72276 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
72277 IKFDC=IDC
72278 GOTO 700
72279 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
72280 GOTO 690
72281 ENDIF
72282 680 CONTINUE
72283 IKFDC=-IDC
72284 GOTO 700
72285 ENDIF
72286 690 CONTINUE
72287 IKFDC=NKFDC+1
72288 700 IF(IKFDC.LT.0) THEN
72289 IKFDC=-IKFDC
72290 ELSEIF(NKFDC.GE.200) THEN
72291 NREDC=NREDC+1
72292 RETURN
72293 ELSE
72294 DO 720 IDC=NKFDC,IKFDC,-1
72295 NPDC(IDC+1)=NPDC(IDC)
72296 DO 710 I=0,8
72297 KFDC(IDC+1,I)=KFDC(IDC,I)
72298 710 CONTINUE
72299 720 CONTINUE
72300 NKFDC=NKFDC+1
72301 KFDC(IKFDC,0)=NDS
72302 DO 730 I=1,NDS
72303 KFDC(IKFDC,I)=KFDM(I)
72304 730 CONTINUE
72305 NPDC(IKFDC)=0
72306 ENDIF
72307 NPDC(IKFDC)=NPDC(IKFDC)+1
72308
72309C...Write statistics on decay channels.
72310 ELSEIF(MTABU.EQ.52) THEN
72311 FAC=1D0/MAX(1,NEVDC)
72312 WRITE(MSTU(11),5900) NEVDC
72313 DO 750 IDC=1,NKFDC
72314 DO 740 I=1,KFDC(IDC,0)
72315 KFM=KFDC(IDC,I)
72316 KF=(KFM+1)/2
72317 IF(2*KF.NE.KFM) KF=-KF
72318 CALL PYNAME(KF,CHAU)
72319 CHDC(I)=CHAU(1:12)
72320 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
72321 740 CONTINUE
72322 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
72323 750 CONTINUE
72324 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
72325
72326C...Copy statistics on decay channels into /PYJETS/.
72327 ELSEIF(MTABU.EQ.53) THEN
72328 FAC=1D0/MAX(1,NEVDC)
72329 DO 780 IDC=1,NKFDC
72330 K(IDC,1)=32
72331 K(IDC,2)=99
72332 K(IDC,3)=0
72333 K(IDC,4)=0
72334 K(IDC,5)=KFDC(IDC,0)
72335 DO 760 J=1,5
72336 P(IDC,J)=0D0
72337 V(IDC,J)=0D0
72338 760 CONTINUE
72339 DO 770 I=1,KFDC(IDC,0)
72340 KFM=KFDC(IDC,I)
72341 KF=(KFM+1)/2
72342 IF(2*KF.NE.KFM) KF=-KF
72343 IF(I.LE.5) P(IDC,I)=KF
72344 IF(I.GE.6) V(IDC,I-5)=KF
72345 770 CONTINUE
72346 V(IDC,5)=FAC*NPDC(IDC)
72347 780 CONTINUE
72348 N=NKFDC
72349 DO 790 J=1,5
72350 K(N+1,J)=0
72351 P(N+1,J)=0D0
72352 V(N+1,J)=0D0
72353 790 CONTINUE
72354 K(N+1,1)=32
72355 K(N+1,2)=99
72356 K(N+1,5)=NEVDC
72357 V(N+1,5)=FAC*NREDC
72358 MSTU(3)=1
72359 ENDIF
72360
72361C...Format statements for output on unit MSTU(11) (default 6).
72362 5000 FORMAT(///20X,'Event statistics - initial state'/
72363 &20X,'based on an analysis of ',I6,' events'//
72364 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
72365 &'according to fragmenting system multiplicity'/
72366 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
72367 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
72368 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
72369 5200 FORMAT(///20X,'Event statistics - final state'/
72370 &20X,'based on an analysis of ',I7,' events'//
72371 &5X,'Mean primary multiplicity =',F10.4/
72372 &5X,'Mean final multiplicity =',F10.4/
72373 &5X,'Mean charged multiplicity =',F10.4//
72374 &5X,'Number of particles produced per event (directly and via ',
72375 &'decays/branchings)'/
72376 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
72377 &8X,'Total'/35X,'prim seco prim seco'/)
72378 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
72379 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
72380 &20X,'based on an analysis of ',I6,' events'//
72381 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
72382 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
72383 5500 FORMAT(10X)
72384 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
72385 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
72386 &20X,'based on an analysis of ',I6,' events'//
72387 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
72388 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
72389 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
72390 5900 FORMAT(///20X,'Decay channel analysis - final state'/
72391 &20X,'based on an analysis of ',I6,' events'//
72392 &2X,'Probability',10X,'Complete final state'/)
72393 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
72394 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
72395 &'or table overflow)')
72396
72397 RETURN
72398 END
72399
72400C*********************************************************************
72401
72402C...PYEEVT
72403C...Handles the generation of an e+e- annihilation jet event.
72404
72405 SUBROUTINE PYEEVT(KFL,ECM)
72406
72407C...Double precision and integer declarations.
72408 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72409 IMPLICIT INTEGER(I-N)
72410 INTEGER PYK,PYCHGE,PYCOMP
72411C...Commonblocks.
72412 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72413 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72414 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72415 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72416
72417C...Check input parameters.
72418 IF(MSTU(12).NE.12345) CALL PYLIST(0)
72419 IF(KFL.LT.0.OR.KFL.GT.8) THEN
72420 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
72421 IF(MSTU(21).GE.1) RETURN
72422 ENDIF
72423 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
72424 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
72425 IF(ECM.LT.ECMMIN) THEN
72426 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
72427 IF(MSTU(21).GE.1) RETURN
72428 ENDIF
72429
72430C...Check consistency of MSTJ options set.
72431 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
72432 CALL PYERRM(6,
72433 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
72434 MSTJ(110)=1
72435 ENDIF
72436 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
72437 CALL PYERRM(6,
72438 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
72439 MSTJ(111)=0
72440 ENDIF
72441
72442C...Initialize alpha_strong and total cross-section.
72443 MSTU(111)=MSTJ(108)
72444 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
72445 &MSTU(111)=1
72446 PARU(112)=PARJ(121)
72447 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
72448 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
72449 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
72450 &XTOT)
72451 IF(MSTJ(116).GE.3) MSTJ(116)=1
72452 PARJ(171)=0D0
72453
72454C...Add initial e+e- to event record (documentation only).
72455 NTRY=0
72456 100 NTRY=NTRY+1
72457 IF(NTRY.GT.100) THEN
72458 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
72459 RETURN
72460 ENDIF
72461 MSTU(24)=0
72462 NC=0
72463 IF(MSTJ(115).GE.2) THEN
72464 NC=NC+2
72465 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
72466 K(NC-1,1)=21
72467 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
72468 K(NC,1)=21
72469 ENDIF
72470
72471C...Radiative photon (in initial state).
72472 MK=0
72473 ECMC=ECM
72474 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
72475 &THEK,PHIK,ALPK)
72476 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
72477 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
72478 NC=NC+1
72479 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
72480 K(NC,3)=MIN(MSTJ(115)/2,1)
72481 ENDIF
72482
72483C...Virtual exchange boson (gamma or Z0).
72484 IF(MSTJ(115).GE.3) THEN
72485 NC=NC+1
72486 KF=22
72487 IF(MSTJ(102).EQ.2) KF=23
72488 MSTU10=MSTU(10)
72489 MSTU(10)=1
72490 P(NC,5)=ECMC
72491 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
72492 K(NC,1)=21
72493 K(NC,3)=1
72494 MSTU(10)=MSTU10
72495 ENDIF
72496
72497C...Choice of flavour and jet configuration.
72498 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
72499 IF(KFLC.EQ.0) GOTO 100
72500 CALL PYXJET(ECMC,NJET,CUT)
72501 KFLN=21
72502 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
72503 &X12,X14)
72504 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
72505 IF(NJET.EQ.2) MSTJ(120)=1
72506
72507C...Fill jet configuration and origin.
72508 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
72509 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
72510 &ECMC)
72511 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
72512 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
72513 &-KFLC,ECMC,X1,X2,X4,X12,X14)
72514 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
72515 &-KFLC,ECMC,X1,X2,X4,X12,X14)
72516 IF(MSTU(24).NE.0) GOTO 100
72517 DO 110 IP=NC+1,N
72518 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
72519 110 CONTINUE
72520
72521C...Angular orientation according to matrix element.
72522 IF(MSTJ(106).EQ.1) THEN
72523 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
72524 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
72525 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
72526 ENDIF
72527
72528C...Rotation and boost from radiative photon.
72529 IF(MK.EQ.1) THEN
72530 DBEK=-PAK/(ECM-PAK)
72531 NMIN=NC+1-MSTJ(115)/3
72532 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
72533 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
72534 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
72535 ENDIF
72536
72537C...Generate parton shower. Rearrange along strings and check.
72538 IF(MSTJ(101).EQ.5) THEN
72539 CALL PYSHOW(N-1,N,ECMC)
72540 MSTJ14=MSTJ(14)
72541 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
72542 IF(MSTJ(105).GE.0) MSTU(28)=0
72543 CALL PYPREP(0)
72544 MSTJ(14)=MSTJ14
72545 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
72546 ENDIF
72547
72548C...Fragmentation/decay generation. Information for PYTABU.
72549 IF(MSTJ(105).EQ.1) CALL PYEXEC
72550 MSTU(161)=KFLC
72551 MSTU(162)=-KFLC
72552
72553 RETURN
72554 END
72555
72556C*********************************************************************
72557
72558C...PYXTEE
72559C...Calculates total cross-section, including initial state
72560C...radiation effects.
72561
72562 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
72563
72564C...Double precision and integer declarations.
72565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72566 IMPLICIT INTEGER(I-N)
72567 INTEGER PYK,PYCHGE,PYCOMP
72568C...Commonblocks.
72569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72570 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72571 SAVE /PYDAT1/,/PYDAT2/
72572
72573C...Status, (optimized) Q^2 scale, alpha_strong.
72574 PARJ(151)=ECM
72575 MSTJ(119)=10*MSTJ(102)+KFL
72576 IF(MSTJ(111).EQ.0) THEN
72577 Q2R=ECM**2
72578 ELSEIF(MSTU(111).EQ.0) THEN
72579 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
72580 & ((33D0-2D0*MSTU(112))*PARU(111)))))
72581 Q2R=PARJ(168)*ECM**2
72582 ELSE
72583 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
72584 & (2D0*PARU(112)/ECM)**2))
72585 Q2R=PARJ(168)*ECM**2
72586 ENDIF
72587 ALSPI=PYALPS(Q2R)/PARU(1)
72588
72589C...QCD corrections factor in R.
72590 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
72591 RQCD=1D0
72592 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
72593 RQCD=1D0+ALSPI
72594 ELSEIF(MSTJ(109).EQ.0) THEN
72595 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
72596 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
72597 & LOG(PARJ(168))*ALSPI**2)
72598 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
72599 RQCD=1D0+(3D0/4D0)*ALSPI
72600 ELSE
72601 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
72602 ENDIF
72603
72604C...Calculate Z0 width if default value not acceptable.
72605 IF(MSTJ(102).GE.3) THEN
72606 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
72607 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
72608 DO 100 KFLC=5,6
72609 VQ=1D0
72610 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
72611 & (2D0*PYMASS(KFLC)/ ECM)**2))
72612 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
72613 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
72614 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
72615 100 CONTINUE
72616 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
72617 & (1D0-PARU(102)))
72618 ENDIF
72619
72620C...Calculate propagator and related constants for QFD case.
72621 POLL=1D0-PARJ(131)*PARJ(132)
72622 IF(MSTJ(102).GE.2) THEN
72623 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
72624 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
72625 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
72626 VE=4D0*PARU(102)-1D0
72627 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
72628 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
72629 HF1I=SFI*SF1I
72630 HF1W=SFW*SF1W
72631 ENDIF
72632
72633C...Loop over different flavours: charge, velocity.
72634 RTOT=0D0
72635 RQQ=0D0
72636 RQV=0D0
72637 RVA=0D0
72638 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
72639 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
72640 MSTJ(93)=1
72641 PMQ=PYMASS(KFLC)
72642 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
72643 QF=KCHG(KFLC,1)/3D0
72644 VQ=1D0
72645 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
72646
72647C...Calculate R and sum of charges for QED or QFD case.
72648 RQQ=RQQ+3D0*QF**2*POLL
72649 IF(MSTJ(102).LE.1) THEN
72650 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
72651 ELSE
72652 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
72653 RQV=RQV-6D0*QF*VF*SF1I
72654 RVA=RVA+3D0*(VF**2+1D0)*SF1W
72655 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
72656 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
72657 ENDIF
72658 110 CONTINUE
72659 RSUM=RQQ
72660 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
72661
72662C...Calculate cross-section, including QCD corrections.
72663 PARJ(141)=RQQ
72664 PARJ(142)=RTOT
72665 PARJ(143)=RTOT*RQCD
72666 PARJ(144)=PARJ(143)
72667 PARJ(145)=PARJ(141)*86.8D0/ECM**2
72668 PARJ(146)=PARJ(142)*86.8D0/ECM**2
72669 PARJ(147)=PARJ(143)*86.8D0/ECM**2
72670 PARJ(148)=PARJ(147)
72671 PARJ(157)=RSUM*RQCD
72672 PARJ(158)=0D0
72673 PARJ(159)=0D0
72674 XTOT=PARJ(147)
72675 IF(MSTJ(107).LE.0) RETURN
72676
72677C...Virtual cross-section.
72678 XKL=PARJ(135)
72679 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
72680 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
72681 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
72682 &1.526D0*LOG(ECM**2/0.932D0)
72683
72684C...Soft and hard radiative cross-section in QED case.
72685 IF(MSTJ(102).LE.1) THEN
72686 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
72687 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
72688 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
72689
72690C...Soft and hard radiative cross-section in QFD case.
72691 ELSE
72692 SZM=1D0-(PARJ(123)/ECM)**2
72693 SZW=PARJ(123)*PARJ(124)/ECM**2
72694 PARJ(161)=-RQQ/RSUM
72695 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
72696 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
72697 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
72698 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
72699 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
72700 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
72701 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
72702 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
72703 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
72704 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
72705 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
72706 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
72707 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
72708 ENDIF
72709
72710C...Total cross-section and fraction of hard photon events.
72711 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
72712 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
72713 PARJ(144)=PARJ(157)
72714 PARJ(148)=PARJ(144)*86.8D0/ECM**2
72715 XTOT=PARJ(148)
72716
72717 RETURN
72718 END
72719
72720C*********************************************************************
72721
72722C...PYRADK
72723C...Generates initial state photon radiation.
72724
72725 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
72726
72727C...Double precision and integer declarations.
72728 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72729 IMPLICIT INTEGER(I-N)
72730 INTEGER PYK,PYCHGE,PYCOMP
72731C...Commonblocks.
72732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72733 SAVE /PYDAT1/
72734
72735C...Function: cumulative hard photon spectrum in QFD case.
72736 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
72737 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
72738
72739C...Determine whether radiative photon or not.
72740 MK=0
72741 PAK=0D0
72742 IF(PARJ(160).LT.PYR(0)) RETURN
72743 MK=1
72744
72745C...Photon energy range. Find photon momentum in QED case.
72746 XKL=PARJ(135)
72747 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
72748 IF(MSTJ(102).LE.1) THEN
72749 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
72750 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
72751
72752C...Ditto in QFD case, by numerical inversion of integrated spectrum.
72753 ELSE
72754 SZM=1D0-(PARJ(123)/ECM)**2
72755 SZW=PARJ(123)*PARJ(124)/ECM**2
72756 FXKL=FXK(XKL)
72757 FXKU=FXK(XKU)
72758 FXKD=1D-4*(FXKU-FXKL)
72759 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
72760 NXK=0
72761 110 NXK=NXK+1
72762 XK=0.5D0*(XKL+XKU)
72763 FXKV=FXK(XK)
72764 IF(FXKV.GT.FXKR) THEN
72765 XKU=XK
72766 FXKU=FXKV
72767 ELSE
72768 XKL=XK
72769 FXKL=FXKV
72770 ENDIF
72771 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
72772 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
72773 ENDIF
72774 PAK=0.5D0*ECM*XK
72775
72776C...Photon polar and azimuthal angle.
72777 PME=2D0*(PYMASS(11)/ECM)**2
72778 120 CTHM=PME*(2D0/PME)**PYR(0)
72779 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
72780 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
72781 CTHE=1D0-CTHM
72782 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
72783 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
72784 THEK=PYANGL(CTHE,STHE)
72785 PHIK=PARU(2)*PYR(0)
72786
72787C...Rotation angle for hadronic system.
72788 SGN=1D0
72789 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
72790 &PYR(0)) SGN=-1D0
72791 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
72792 &(2D0-XK*(1D0-SGN*CTHE)))
72793
72794 RETURN
72795 END
72796
72797C*********************************************************************
72798
72799C...PYXKFL
72800C...Selects flavour for produced qqbar pair.
72801
72802 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
72803
72804C...Double precision and integer declarations.
72805 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72806 IMPLICIT INTEGER(I-N)
72807 INTEGER PYK,PYCHGE,PYCOMP
72808C...Commonblocks.
72809 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72810 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72811 SAVE /PYDAT1/,/PYDAT2/
72812
72813C...Calculate maximum weight in QED or QFD case.
72814 IF(MSTJ(102).LE.1) THEN
72815 RFMAX=4D0/9D0
72816 ELSE
72817 POLL=1D0-PARJ(131)*PARJ(132)
72818 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
72819 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
72820 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
72821 VE=4D0*PARU(102)-1D0
72822 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
72823 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
72824 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
72825 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
72826 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
72827 & 1D0)*HF1W)
72828 ENDIF
72829
72830C...Choose flavour. Gives charge and velocity.
72831 NTRY=0
72832 100 NTRY=NTRY+1
72833 IF(NTRY.GT.100) THEN
72834 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
72835 KFLC=0
72836 RETURN
72837 ENDIF
72838 KFLC=KFL
72839 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
72840 MSTJ(93)=1
72841 PMQ=PYMASS(KFLC)
72842 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
72843 QF=KCHG(KFLC,1)/3D0
72844 VQ=1D0
72845 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
72846
72847C...Calculate weight in QED or QFD case.
72848 IF(MSTJ(102).LE.1) THEN
72849 RF=QF**2
72850 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
72851 ELSE
72852 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
72853 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
72854 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
72855 & VQ**3*HF1W
72856 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
72857 ENDIF
72858
72859C...Weighting or new event (radiative photon). Cross-section update.
72860 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
72861 PARJ(158)=PARJ(158)+1D0
72862 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
72863 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
72864 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
72865 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
72866 PARJ(148)=PARJ(144)*86.8D0/ECM**2
72867
72868 RETURN
72869 END
72870
72871C*********************************************************************
72872
72873C...PYXJET
72874C...Selects number of jets in matrix element approach.
72875
72876 SUBROUTINE PYXJET(ECM,NJET,CUT)
72877
72878C...Double precision and integer declarations.
72879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72880 IMPLICIT INTEGER(I-N)
72881 INTEGER PYK,PYCHGE,PYCOMP
72882C...Commonblocks.
72883 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72884 SAVE /PYDAT1/
72885C...Local array and data.
72886 DIMENSION ZHUT(5)
72887 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
72888
72889C...Trivial result for two-jets only, including parton shower.
72890 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
72891 CUT=0D0
72892
72893C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
72894 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
72895 CF=4D0/3D0
72896 IF(MSTJ(109).EQ.2) CF=1D0
72897 IF(MSTJ(111).EQ.0) THEN
72898 Q2=ECM**2
72899 Q2R=ECM**2
72900 ELSEIF(MSTU(111).EQ.0) THEN
72901 PARJ(169)=MIN(1D0,PARJ(129))
72902 Q2=PARJ(169)*ECM**2
72903 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
72904 & ((33D0-2D0*MSTU(112))*PARU(111)))))
72905 Q2R=PARJ(168)*ECM**2
72906 ELSE
72907 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
72908 Q2=PARJ(169)*ECM**2
72909 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
72910 & (2D0*PARU(112)/ECM)**2))
72911 Q2R=PARJ(168)*ECM**2
72912 ENDIF
72913
72914C...alpha_strong for R and R itself.
72915 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
72916 IF(IABS(MSTJ(101)).EQ.1) THEN
72917 RQCD=1D0+ALSPI
72918 ELSEIF(MSTJ(109).EQ.0) THEN
72919 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
72920 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
72921 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
72922 ELSE
72923 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
72924 ENDIF
72925
72926C...alpha_strong for jet rate. Initial value for y cut.
72927 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
72928 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
72929 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
72930 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
72931 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
72932
72933C...Parametrization of first order three-jet cross-section.
72934 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
72935 PARJ(152)=0D0
72936 ELSE
72937 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
72938 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
72939 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
72940 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
72941 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
72942 & PARJ(152)=0D0
72943 ENDIF
72944
72945C...Parametrization of second order three-jet cross-section.
72946 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
72947 & CUT.GE.0.25D0) THEN
72948 PARJ(153)=0D0
72949 ELSEIF(MSTJ(110).LE.1) THEN
72950 CT=LOG(1D0/CUT-2D0)
72951 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
72952 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
72953
72954C...Interpolation in second/first order ratio for Zhu parametrization.
72955 ELSEIF(MSTJ(110).EQ.2) THEN
72956 IZA=0
72957 DO 110 IY=1,5
72958 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
72959 110 CONTINUE
72960 IF(IZA.NE.0) THEN
72961 ZHURAT=ZHUT(IZA)
72962 ELSE
72963 IZ=100D0*CUT
72964 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
72965 ENDIF
72966 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
72967 ENDIF
72968
72969C...Shift in second order three-jet cross-section with optimized Q^2.
72970 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
72971 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
72972 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
72973
72974C...Parametrization of second order four-jet cross-section.
72975 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
72976 PARJ(154)=0D0
72977 ELSE
72978 CT=LOG(1D0/CUT-5D0)
72979 IF(CUT.LE.0.018D0) THEN
72980 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
72981 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
72982 & 0.4059D0*CT**2)
72983 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
72984 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
72985 ELSE
72986 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
72987 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
72988 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
72989 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
72990 & 0.002093D0*CT**3)
72991 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
72992 ENDIF
72993 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
72994 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
72995 ENDIF
72996
72997C...If negative three-jet rate, change y' optimization parameter.
72998 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
72999 & PARJ(169).LT.0.99D0) THEN
73000 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
73001 Q2=PARJ(169)*ECM**2
73002 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
73003 GOTO 100
73004 ENDIF
73005
73006C...If too high cross-section, use harder cuts, or fail.
73007 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
73008 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
73009 & PARJ(169).LT.0.99D0) THEN
73010 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
73011 Q2=PARJ(169)*ECM**2
73012 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
73013 GOTO 100
73014 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
73015 CALL PYERRM(26,
73016 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
73017 ENDIF
73018 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
73019 & PARJ(154))**(-1D0/3D0)
73020 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
73021 GOTO 100
73022 ENDIF
73023
73024C...Scalar gluon (first order only).
73025 ELSE
73026 ALSPI=PYALPS(ECM**2)/PARU(1)
73027 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
73028 PARJ(152)=0D0
73029 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
73030 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
73031 PARJ(153)=0D0
73032 PARJ(154)=0D0
73033 ENDIF
73034
73035C...Select number of jets.
73036 PARJ(150)=CUT
73037 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
73038 NJET=2
73039 ELSEIF(MSTJ(101).LE.0) THEN
73040 NJET=MIN(4,2-MSTJ(101))
73041 ELSE
73042 RNJ=PYR(0)
73043 NJET=2
73044 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
73045 IF(PARJ(154).GT.RNJ) NJET=4
73046 ENDIF
73047
73048 RETURN
73049 END
73050
73051C*********************************************************************
73052
73053C...PYX3JT
73054C...Selects the kinematical variables of three-jet events.
73055
73056 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
73057
73058C...Double precision and integer declarations.
73059 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73060 IMPLICIT INTEGER(I-N)
73061 INTEGER PYK,PYCHGE,PYCOMP
73062C...Commonblocks.
73063 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73064 SAVE /PYDAT1/
73065C...Local array.
73066 DIMENSION ZHUP(5,12)
73067
73068C...Coefficients of Zhu second order parametrization.
73069 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
73070 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
73071 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
73072 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
73073 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
73074 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
73075 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
73076 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
73077 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
73078 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
73079 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
73080
73081C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
73082 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
73083 &X**7/49D0
73084
73085C...Event type. Mass effect factors and other common constants.
73086 MSTJ(120)=2
73087 MSTJ(121)=0
73088 PMQ=PYMASS(KFL)
73089 QME=(2D0*PMQ/ECM)**2
73090 IF(MSTJ(109).NE.1) THEN
73091 CUTL=LOG(CUT)
73092 CUTD=LOG(1D0/CUT-2D0)
73093 IF(MSTJ(109).EQ.0) THEN
73094 CF=4D0/3D0
73095 CN=3D0
73096 TR=2D0
73097 WTMX=MIN(20D0,37D0-6D0*CUTD)
73098 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
73099 ELSE
73100 CF=1D0
73101 CN=0D0
73102 TR=12D0
73103 WTMX=0D0
73104 ENDIF
73105
73106C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
73107 ALS2PI=PARU(118)/PARU(2)
73108 WTOPT=0D0
73109 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
73110 & LOG(PARJ(169))*ALS2PI
73111 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
73112
73113C...Choose three-jet events in allowed region.
73114 100 NJET=3
73115 110 Y13L=CUTL+CUTD*PYR(0)
73116 Y23L=CUTL+CUTD*PYR(0)
73117 Y13=EXP(Y13L)
73118 Y23=EXP(Y23L)
73119 Y12=1D0-Y13-Y23
73120 IF(Y12.LE.CUT) GOTO 110
73121 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
73122
73123C...Second order corrections.
73124 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
73125 Y12L=LOG(Y12)
73126 Y13M=LOG(1D0-Y13)
73127 Y23M=LOG(1D0-Y23)
73128 Y12M=LOG(1D0-Y12)
73129 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
73130 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
73131 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
73132 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
73133 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
73134 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
73135 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
73136 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
73137 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
73138 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
73139 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
73140 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
73141 & TR*(2D0*CUTL/3D0-10D0/9D0)+
73142 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
73143 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
73144 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
73145 & Y13*Y23)/(Y12+Y13)**2)/WT1+
73146 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
73147 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
73148 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
73149 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
73150 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
73151 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
73152 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
73153 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
73154 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
73155 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
73156
73157 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
73158C...Second order corrections; Zhu parametrization of ERT.
73159 ZX=(Y23-Y13)**2
73160 ZY=1D0-Y12
73161 IZA=0
73162 DO 120 IY=1,5
73163 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
73164 120 CONTINUE
73165 IF(IZA.NE.0) THEN
73166 IZ=IZA
73167 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
73168 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
73169 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
73170 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
73171 ELSE
73172 IZ=100D0*CUT
73173 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
73174 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
73175 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
73176 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
73177 IZ=IZ+1
73178 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
73179 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
73180 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
73181 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
73182 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
73183 ENDIF
73184 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
73185 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
73186 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
73187 ENDIF
73188
73189C...Impose mass cuts (gives two jets). For fixed jet number new try.
73190 X1=1D0-Y23
73191 X2=1D0-Y13
73192 X3=1D0-Y12
73193 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
73194 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
73195 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
73196 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
73197 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
73198
73199C...Scalar gluon model (first order only, no mass effects).
73200 ELSE
73201 130 NJET=3
73202 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
73203 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
73204 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
73205 X1=1D0-0.5D0*(X3+YD)
73206 X2=1D0-0.5D0*(X3-YD)
73207 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
73208 IF(MSTJ(102).GE.2) THEN
73209 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
73210 & X3**2*PYR(0)) NJET=2
73211 ENDIF
73212 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
73213 ENDIF
73214
73215 RETURN
73216 END
73217
73218C*********************************************************************
73219
73220C...PYX4JT
73221C...Selects the kinematical variables of four-jet events.
73222
73223 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
73224
73225C...Double precision and integer declarations.
73226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73227 IMPLICIT INTEGER(I-N)
73228 INTEGER PYK,PYCHGE,PYCOMP
73229C...Commonblocks.
73230 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73231 SAVE /PYDAT1/
73232C...Local arrays.
73233 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
73234
73235C...Common constants. Colour factors for QCD and Abelian gluon theory.
73236 PMQ=PYMASS(KFL)
73237 QME=(2D0*PMQ/ECM)**2
73238 CT=LOG(1D0/CUT-5D0)
73239 IF(MSTJ(109).EQ.0) THEN
73240 CF=4D0/3D0
73241 CN=3D0
73242 TR=2.5D0
73243 ELSE
73244 CF=1D0
73245 CN=0D0
73246 TR=15D0
73247 ENDIF
73248
73249C...Choice of process (qqbargg or qqbarqqbar).
73250 100 NJET=4
73251 IT=1
73252 IF(PARJ(155).GT.PYR(0)) IT=2
73253 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
73254 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
73255 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
73256 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
73257 ID=1
73258
73259C...Sample the five kinematical variables (for qqgg preweighted in y34).
73260 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
73261 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
73262 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
73263 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
73264 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
73265 VT=PYR(0)
73266 CP=COS(PARU(1)*PYR(0))
73267 Y14=(Y134-Y34)*VT
73268 Y13=Y134-Y14-Y34
73269 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
73270 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
73271 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
73272 Y23=Y234-Y34-Y24
73273 Y12=1D0-Y134-Y23-Y24
73274 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
73275 Y123=Y12+Y13+Y23
73276 Y124=Y12+Y14+Y24
73277
73278C...Calculate matrix elements for qqgg or qqqq process.
73279 IC=0
73280 WTTOT=0D0
73281 120 IC=IC+1
73282 IF(IT.EQ.1) THEN
73283 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
73284 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
73285 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
73286 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
73287 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
73288 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
73289 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
73290 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
73291 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
73292 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
73293 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
73294 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
73295 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
73296 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
73297 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
73298 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
73299 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
73300 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
73301 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
73302 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
73303 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
73304 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
73305 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
73306 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
73307 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
73308 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
73309 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
73310 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
73311 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
73312 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
73313 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
73314 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
73315 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
73316 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
73317 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
73318 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
73319 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
73320 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
73321 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
73322 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
73323 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
73324 & CN*WTC(IC))/8D0
73325 ELSE
73326 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
73327 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
73328 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
73329 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
73330 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
73331 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
73332 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
73333 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
73334 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
73335 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
73336 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
73337 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
73338 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
73339 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
73340 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
73341 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
73342 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
73343 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
73344 ENDIF
73345
73346C...Permutations of momenta in matrix element. Weighting.
73347 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
73348 YSAV=Y13
73349 Y13=Y14
73350 Y14=YSAV
73351 YSAV=Y23
73352 Y23=Y24
73353 Y24=YSAV
73354 YSAV=Y123
73355 Y123=Y124
73356 Y124=YSAV
73357 ENDIF
73358 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
73359 YSAV=Y13
73360 Y13=Y23
73361 Y23=YSAV
73362 YSAV=Y14
73363 Y14=Y24
73364 Y24=YSAV
73365 YSAV=Y134
73366 Y134=Y234
73367 Y234=YSAV
73368 ENDIF
73369 IF(IC.LE.3) GOTO 120
73370 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
73371 IC=5
73372
73373C...qqgg events: string configuration and event type.
73374 IF(IT.EQ.1) THEN
73375 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
73376 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
73377 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
73378 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
73379 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
73380 IF(ID.EQ.2) GOTO 130
73381 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
73382 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
73383 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
73384 IF(ID.EQ.2) GOTO 130
73385 ENDIF
73386 MSTJ(120)=3
73387 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
73388 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
73389 KFLN=21
73390
73391C...Mass cuts. Kinematical variables out.
73392 IF(Y12.LE.CUT+QME) NJET=2
73393 IF(NJET.EQ.2) GOTO 150
73394 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
73395 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
73396 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
73397 X2=1D0-Y124
73398 X12=(1D0-Q12)*Y13+Q12*Y23
73399 X14=Y12-0.5D0*QME
73400 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
73401
73402C...qqbarqqbar events: string configuration, choose new flavour.
73403 ELSE
73404 IF(ID.EQ.1) THEN
73405 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
73406 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
73407 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
73408 IF(WTR.LT.WTD(4)) ID=4
73409 IF(ID.GE.2) GOTO 130
73410 ENDIF
73411 MSTJ(120)=5
73412 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
73413 140 KFLN=1+INT(5D0*PYR(0))
73414 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
73415 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
73416 IF(KFLN.GT.MSTJ(104)) NJET=2
73417 PMQN=PYMASS(KFLN)
73418 QMEN=(2D0*PMQN/ECM)**2
73419
73420C...Mass cuts. Kinematical variables out.
73421 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
73422 IF(NJET.EQ.2) GOTO 150
73423 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
73424 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
73425 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
73426 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
73427 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
73428 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
73429 & Q13*Y23)
73430 X14=Y24-0.5D0*QME
73431 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
73432 & Q13*Y14)
73433 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
73434 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
73435 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
73436 ENDIF
73437 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
73438
73439 RETURN
73440 END
73441
73442C*********************************************************************
73443
73444C...PYXDIF
73445C...Gives the angular orientation of events.
73446
73447 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
73448
73449C...Double precision and integer declarations.
73450 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73451 IMPLICIT INTEGER(I-N)
73452 INTEGER PYK,PYCHGE,PYCOMP
73453C...Commonblocks.
73454 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73455 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73456 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73457 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73458
73459C...Charge. Factors depending on polarization for QED case.
73460 QF=KCHG(KFL,1)/3D0
73461 POLL=1D0-PARJ(131)*PARJ(132)
73462 POLD=PARJ(132)-PARJ(131)
73463 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
73464 HF1=POLL
73465 HF2=0D0
73466 HF3=PARJ(133)**2
73467 HF4=0D0
73468
73469C...Factors depending on flavour, energy and polarization for QFD case.
73470 ELSE
73471 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73472 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73473 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73474 AE=-1D0
73475 VE=4D0*PARU(102)-1D0
73476 AF=SIGN(1D0,QF)
73477 VF=AF-4D0*QF*PARU(102)
73478 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
73479 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
73480 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
73481 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
73482 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
73483 & SFW*SFF**2*(VE**2-AE**2))
73484 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
73485 & SFF*AE
73486 ENDIF
73487
73488C...Mass factor. Differential cross-sections for two-jet events.
73489 SQ2=SQRT(2D0)
73490 QME=0D0
73491 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
73492 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
73493 IF(NJET.EQ.2) THEN
73494 SIGU=4D0*SQRT(1D0-QME)
73495 SIGL=2D0*QME*SQRT(1D0-QME)
73496 SIGT=0D0
73497 SIGI=0D0
73498 SIGA=0D0
73499 SIGP=4D0
73500
73501C...Kinematical variables. Reduce four-jet event to three-jet one.
73502 ELSE
73503 IF(NJET.EQ.3) THEN
73504 X1=2D0*P(NC+1,4)/ECM
73505 X2=2D0*P(NC+3,4)/ECM
73506 ELSE
73507 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
73508 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
73509 X1=2D0*P(NC+1,4)/ECMR
73510 X2=2D0*P(NC+4,4)/ECMR
73511 ENDIF
73512
73513C...Differential cross-sections for three-jet (or reduced four-jet).
73514 XQ=(1D0-X1)/(1D0-X2)
73515 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
73516 ST12=SQRT(1D0-CT12**2)
73517 IF(MSTJ(109).NE.1) THEN
73518 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
73519 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
73520 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
73521 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
73522 & X2)*XQ
73523 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
73524 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
73525 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
73526 SIGA=X2**2*ST12/SQ2
73527 SIGP=2D0*(X1**2-X2**2*CT12)
73528
73529C...Differential cross-sect for scalar gluons (no mass effects).
73530 ELSE
73531 X3=2D0-X1-X2
73532 XT=X2*ST12
73533 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
73534 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
73535 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
73536 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
73537 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
73538 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
73539 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
73540 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
73541 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
73542 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
73543 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
73544 ENDIF
73545 ENDIF
73546
73547C...Upper bounds for differential cross-section.
73548 HF1A=ABS(HF1)
73549 HF2A=ABS(HF2)
73550 HF3A=ABS(HF3)
73551 HF4A=ABS(HF4)
73552 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
73553 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
73554 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
73555 &2D0*HF2A*ABS(SIGP)
73556
73557C...Generate angular orientation according to differential cross-sect.
73558 100 CHI=PARU(2)*PYR(0)
73559 CTHE=2D0*PYR(0)-1D0
73560 PHI=PARU(2)*PYR(0)
73561 CCHI=COS(CHI)
73562 SCHI=SIN(CHI)
73563 C2CHI=COS(2D0*CHI)
73564 S2CHI=SIN(2D0*CHI)
73565 THE=ACOS(CTHE)
73566 STHE=SIN(THE)
73567 C2PHI=COS(2D0*(PHI-PARJ(134)))
73568 S2PHI=SIN(2D0*(PHI-PARJ(134)))
73569 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
73570 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
73571 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
73572 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
73573 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
73574 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
73575 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
73576 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
73577
73578 RETURN
73579 END
73580
73581C*********************************************************************
73582
73583C...PYONIA
73584C...Generates Upsilon and toponium decays into three gluons
73585C...or two gluons and a photon.
73586
73587 SUBROUTINE PYONIA(KFL,ECM)
73588
73589C...Double precision and integer declarations.
73590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73591 IMPLICIT INTEGER(I-N)
73592 INTEGER PYK,PYCHGE,PYCOMP
73593C...Commonblocks.
73594 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73596 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73597 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73598
73599C...Printout. Check input parameters.
73600 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73601 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73602 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
73603 IF(MSTU(21).GE.1) RETURN
73604 ENDIF
73605 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
73606 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
73607 IF(MSTU(21).GE.1) RETURN
73608 ENDIF
73609
73610C...Initial e+e- and onium state (optional).
73611 NC=0
73612 IF(MSTJ(115).GE.2) THEN
73613 NC=NC+2
73614 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73615 K(NC-1,1)=21
73616 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73617 K(NC,1)=21
73618 ENDIF
73619 KFLC=IABS(KFL)
73620 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
73621 NC=NC+1
73622 KF=110*KFLC+3
73623 MSTU10=MSTU(10)
73624 MSTU(10)=1
73625 P(NC,5)=ECM
73626 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
73627 K(NC,1)=21
73628 K(NC,3)=1
73629 MSTU(10)=MSTU10
73630 ENDIF
73631
73632C...Choose x1 and x2 according to matrix element.
73633 NTRY=0
73634 100 X1=PYR(0)
73635 X2=PYR(0)
73636 X3=2D0-X1-X2
73637 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
73638 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
73639 NTRY=NTRY+1
73640 NJET=3
73641 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
73642 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
73643
73644C...Photon-gluon-gluon events. Small system modifications. Jet origin.
73645 MSTU(111)=MSTJ(108)
73646 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73647 &MSTU(111)=1
73648 PARU(112)=PARJ(121)
73649 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73650 QF=0D0
73651 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
73652 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
73653 MK=0
73654 ECMC=ECM
73655 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
73656 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
73657 & NJET=2
73658 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
73659 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
73660 ELSE
73661 MK=1
73662 ECMC=SQRT(1D0-X1)*ECM
73663 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
73664 K(NC+1,1)=1
73665 K(NC+1,2)=22
73666 K(NC+1,4)=0
73667 K(NC+1,5)=0
73668 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
73669 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
73670 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
73671 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
73672 NJET=2
73673 IF(ECMC.LT.4D0*PARJ(127)) THEN
73674 MSTU10=MSTU(10)
73675 MSTU(10)=1
73676 P(NC+2,5)=ECMC
73677 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
73678 MSTU(10)=MSTU10
73679 NJET=0
73680 ENDIF
73681 ENDIF
73682 DO 110 IP=NC+1,N
73683 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
73684 110 CONTINUE
73685
73686C...Differential cross-sections. Upper limit for cross-section.
73687 IF(MSTJ(106).EQ.1) THEN
73688 SQ2=SQRT(2D0)
73689 HF1=1D0-PARJ(131)*PARJ(132)
73690 HF3=PARJ(133)**2
73691 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
73692 ST13=SQRT(1D0-CT13**2)
73693 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
73694 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
73695 SIGT=0.5D0*SIGL
73696 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
73697 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
73698 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
73699
73700C...Angular orientation of event.
73701 120 CHI=PARU(2)*PYR(0)
73702 CTHE=2D0*PYR(0)-1D0
73703 PHI=PARU(2)*PYR(0)
73704 CCHI=COS(CHI)
73705 SCHI=SIN(CHI)
73706 C2CHI=COS(2D0*CHI)
73707 S2CHI=SIN(2D0*CHI)
73708 THE=ACOS(CTHE)
73709 STHE=SIN(THE)
73710 C2PHI=COS(2D0*(PHI-PARJ(134)))
73711 S2PHI=SIN(2D0*(PHI-PARJ(134)))
73712 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
73713 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
73714 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
73715 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
73716 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
73717 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
73718 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73719 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73720 ENDIF
73721
73722C...Generate parton shower. Rearrange along strings and check.
73723 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
73724 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
73725 MSTJ14=MSTJ(14)
73726 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73727 IF(MSTJ(105).GE.0) MSTU(28)=0
73728 CALL PYPREP(0)
73729 MSTJ(14)=MSTJ14
73730 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73731 ENDIF
73732
73733C...Generate fragmentation. Information for PYTABU:
73734 IF(MSTJ(105).EQ.1) CALL PYEXEC
73735 MSTU(161)=110*KFLC+3
73736 MSTU(162)=0
73737
73738 RETURN
73739 END
73740
73741C*********************************************************************
73742
73743C...PYBOOK
73744C...Books a histogram.
73745
73746 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
73747
73748C...Double precision declaration.
73749 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73750 IMPLICIT INTEGER(I-N)
73751C...Commonblock.
73752 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73753 SAVE /PYBINS/
73754C...Local character variables.
73755 CHARACTER TITLE*(*), TITFX*60
73756
73757C...Check that input is sensible. Find initial address in memory.
73758 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
73759 &'(PYBOOK:) not allowed histogram number')
73760 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
73761 &'(PYBOOK:) not allowed number of bins')
73762 IF(XL.GE.XU) CALL PYERRM(28,
73763 &'(PYBOOK:) x limits in wrong order')
73764 INDX(ID)=IHIST(4)
73765 IHIST(4)=IHIST(4)+28+NX
73766 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
73767 &'(PYBOOK:) out of histogram space')
73768 IS=INDX(ID)
73769
73770C...Store histogram size and reset contents.
73771 BIN(IS+1)=NX
73772 BIN(IS+2)=XL
73773 BIN(IS+3)=XU
73774 BIN(IS+4)=(XU-XL)/NX
73775 CALL PYNULL(ID)
73776
73777C...Store title by conversion to integer to double precision.
73778 TITFX=TITLE//' '
73779 DO 100 IT=1,20
73780 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
73781 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
73782 100 CONTINUE
73783
73784 RETURN
73785 END
73786
73787C*********************************************************************
73788
73789C...PYFILL
73790C...Fills entry in histogram.
73791
73792 SUBROUTINE PYFILL(ID,X,W)
73793
73794C...Double precision declaration.
73795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73796 IMPLICIT INTEGER(I-N)
73797C...Commonblock.
73798 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73799 SAVE /PYBINS/
73800
73801C...Find initial address in memory. Increase number of entries.
73802 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
73803 &'(PYFILL:) not allowed histogram number')
73804 IS=INDX(ID)
73805 IF(IS.EQ.0) CALL PYERRM(28,
73806 &'(PYFILL:) filling unbooked histogram')
73807 BIN(IS+5)=BIN(IS+5)+1D0
73808
73809C...Find bin in x, including under/overflow, and fill.
73810 IF(X.LT.BIN(IS+2)) THEN
73811 BIN(IS+6)=BIN(IS+6)+W
73812 ELSEIF(X.GE.BIN(IS+3)) THEN
73813 BIN(IS+8)=BIN(IS+8)+W
73814 ELSE
73815 BIN(IS+7)=BIN(IS+7)+W
73816 IX=(X-BIN(IS+2))/BIN(IS+4)
73817 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
73818 BIN(IS+9+IX)=BIN(IS+9+IX)+W
73819 ENDIF
73820
73821 RETURN
73822 END
73823
73824C*********************************************************************
73825
73826C...PYFACT
73827C...Multiplies histogram contents by factor.
73828
73829 SUBROUTINE PYFACT(ID,F)
73830
73831C...Double precision declaration.
73832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73833 IMPLICIT INTEGER(I-N)
73834C...Commonblock.
73835 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73836 SAVE /PYBINS/
73837
73838C...Find initial address in memory. Multiply all contents bins.
73839 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
73840 &'(PYFACT:) not allowed histogram number')
73841 IS=INDX(ID)
73842 IF(IS.EQ.0) CALL PYERRM(28,
73843 &'(PYFACT:) scaling unbooked histogram')
73844 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
73845 BIN(IX)=F*BIN(IX)
73846 100 CONTINUE
73847
73848 RETURN
73849 END
73850
73851C*********************************************************************
73852
73853C...PYOPER
73854C...Performs operations between histograms.
73855
73856 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
73857
73858C...Double precision declaration.
73859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73860 IMPLICIT INTEGER(I-N)
73861C...Commonblock.
73862 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73863 SAVE /PYBINS/
73864C...Character variable.
73865 CHARACTER OPER*(*)
73866
73867C...Find initial addresses in memory, and histogram size.
73868 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
73869 &'(PYFACT:) not allowed histogram number')
73870 IS1=INDX(ID1)
73871 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
73872 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
73873 NX=NINT(BIN(IS3+1))
73874 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
73875
73876C...Update info on number of histogram entries.
73877 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
73878 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
73879 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
73880 BIN(IS3+5)=BIN(IS1+5)
73881 ENDIF
73882
73883C...Operations on pair of histograms: addition, subtraction,
73884C...multiplication, division.
73885 IF(OPER.EQ.'+') THEN
73886 DO 100 IX=6,8+NX
73887 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
73888 100 CONTINUE
73889 ELSEIF(OPER.EQ.'-') THEN
73890 DO 110 IX=6,8+NX
73891 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
73892 110 CONTINUE
73893 ELSEIF(OPER.EQ.'*') THEN
73894 DO 120 IX=6,8+NX
73895 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
73896 120 CONTINUE
73897 ELSEIF(OPER.EQ.'/') THEN
73898 DO 130 IX=6,8+NX
73899 FA2=F2*BIN(IS2+IX)
73900 IF(ABS(FA2).LE.1D-20) THEN
73901 BIN(IS3+IX)=0D0
73902 ELSE
73903 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
73904 ENDIF
73905 130 CONTINUE
73906
73907C...Operations on single histogram: multiplication+addition,
73908C...square root+addition, logarithm+addition.
73909 ELSEIF(OPER.EQ.'A') THEN
73910 DO 140 IX=6,8+NX
73911 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
73912 140 CONTINUE
73913 ELSEIF(OPER.EQ.'S') THEN
73914 DO 150 IX=6,8+NX
73915 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
73916 150 CONTINUE
73917 ELSEIF(OPER.EQ.'L') THEN
73918 ZMIN=1D20
73919 DO 160 IX=9,8+NX
73920 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
73921 & ZMIN=0.8D0*BIN(IS1+IX)
73922 160 CONTINUE
73923 DO 170 IX=6,8+NX
73924 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
73925 170 CONTINUE
73926
73927C...Operation on two or three histograms: average and
73928C...standard deviation.
73929 ELSEIF(OPER.EQ.'M') THEN
73930 DO 180 IX=6,8+NX
73931 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
73932 BIN(IS2+IX)=0D0
73933 ELSE
73934 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
73935 ENDIF
73936 IF(ID3.NE.0) THEN
73937 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
73938 BIN(IS3+IX)=0D0
73939 ELSE
73940 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
73941 & BIN(IS2+IX)**2))
73942 ENDIF
73943 ENDIF
73944 BIN(IS1+IX)=F1*BIN(IS1+IX)
73945 180 CONTINUE
73946 ENDIF
73947
73948 RETURN
73949 END
73950
73951C*********************************************************************
73952
73953C...PYHIST
73954C...Prints and resets all histograms.
73955
73956 SUBROUTINE PYHIST
73957
73958C...Double precision declaration.
73959 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73960 IMPLICIT INTEGER(I-N)
73961C...Commonblock.
73962 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73963 SAVE /PYBINS/
73964
73965C...Loop over histograms, print and reset used ones.
73966 DO 100 ID=1,IHIST(1)
73967 IS=INDX(ID)
73968 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
73969 CALL PYPLOT(ID)
73970 CALL PYNULL(ID)
73971 ENDIF
73972 100 CONTINUE
73973
73974 RETURN
73975 END
73976
73977C*********************************************************************
73978
73979C...PYPLOT
73980C...Prints a histogram (but does not reset it).
73981
73982 SUBROUTINE PYPLOT(ID)
73983
73984C...Double precision declaration.
73985 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73986 IMPLICIT INTEGER(I-N)
73987C...Commonblocks.
73988 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73989 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
73990 SAVE /PYDAT1/,/PYBINS/
73991C...Local arrays and character variables.
73992 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
73993 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
73994
73995C...Steps in histogram scale. Character sequence.
73996 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
73997 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
73998
73999C...Find initial address in memory; skip if empty histogram.
74000 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
74001 IS=INDX(ID)
74002 IF(IS.EQ.0) RETURN
74003 IF(NINT(BIN(IS+5)).LE.0) THEN
74004 WRITE(MSTU(11),5000) ID
74005 RETURN
74006 ENDIF
74007
74008C...Number of histogram lines and x bins.
74009 LIN=IHIST(3)-18
74010 NX=NINT(BIN(IS+1))
74011
74012C...Extract title by conversion from double precision via integer.
74013 DO 100 IT=1,20
74014 IEQ=NINT(BIN(IS+8+NX+IT))
74015 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
74016 & //CHAR(MOD(IEQ,256))
74017 100 CONTINUE
74018
74019C...Find time; print title.
74020 CALL PYTIME(IDATI)
74021 IF(IDATI(1).GT.0) THEN
74022 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
74023 ELSE
74024 WRITE(MSTU(11),5200) ID, TITLE
74025 ENDIF
74026
74027C...Find minimum and maximum bin content.
74028 YMIN=BIN(IS+9)
74029 YMAX=BIN(IS+9)
74030 DO 110 IX=IS+10,IS+8+NX
74031 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
74032 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
74033 110 CONTINUE
74034
74035C...Determine scale and step size for y axis.
74036 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
74037 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
74038 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
74039 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
74040 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
74041 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
74042 DELY=DYAC(1)
74043 DO 120 IDEL=1,9
74044 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
74045 120 CONTINUE
74046 DY=DELY*10D0**IPOT
74047
74048C...Convert bin contents to integer form; fractional fill in top row.
74049 DO 130 IX=1,NX
74050 CTA=ABS(BIN(IS+8+IX))/DY
74051 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
74052 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
74053 130 CONTINUE
74054 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
74055 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
74056
74057C...Print histogram row by row.
74058 DO 150 IR=IRMA,IRMI,-1
74059 IF(IR.EQ.0) GOTO 150
74060 OUT=' '
74061 DO 140 IX=1,NX
74062 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
74063 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
74064 140 CONTINUE
74065 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
74066 150 CONTINUE
74067
74068C...Print sign and value of bin contents.
74069 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
74070 OUT=' '
74071 DO 160 IX=1,NX
74072 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
74073 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
74074 160 CONTINUE
74075 WRITE(MSTU(11),5400) OUT
74076 DO 180 IR=4,1,-1
74077 DO 170 IX=1,NX
74078 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
74079 170 CONTINUE
74080 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
74081 180 CONTINUE
74082
74083C...Print sign and value of lower bin edge.
74084 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
74085 & 10.0001D0)-10
74086 OUT=' '
74087 DO 190 IX=1,NX
74088 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
74089 & OUT(IX:IX)=CHA(11)
74090 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
74091 190 CONTINUE
74092 WRITE(MSTU(11),5600) OUT
74093 DO 210 IR=3,1,-1
74094 DO 200 IX=1,NX
74095 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
74096 200 CONTINUE
74097 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
74098 210 CONTINUE
74099 ENDIF
74100
74101C...Calculate and print statistics.
74102 CSUM=0D0
74103 CXSUM=0D0
74104 CXXSUM=0D0
74105 DO 220 IX=1,NX
74106 CTA=ABS(BIN(IS+8+IX))
74107 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
74108 CSUM=CSUM+CTA
74109 CXSUM=CXSUM+CTA*X
74110 CXXSUM=CXXSUM+CTA*X**2
74111 220 CONTINUE
74112 XMEAN=CXSUM/MAX(CSUM,1D-20)
74113 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
74114 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
74115 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
74116
74117C...Formats for output.
74118 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
74119 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
74120 &I2,':',I2/)
74121 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
74122 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
74123 5400 FORMAT(/8X,'Contents',3X,A100)
74124 5500 FORMAT(9X,'*10**',I2,3X,A100)
74125 5600 FORMAT(/8X,'Low edge',3X,A100)
74126 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
74127 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
74128 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
74129
74130 RETURN
74131 END
74132
74133C*********************************************************************
74134
74135C...PYNULL
74136C...Resets bin contents of a histogram.
74137
74138 SUBROUTINE PYNULL(ID)
74139
74140C...Double precision declaration.
74141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74142 IMPLICIT INTEGER(I-N)
74143C...Commonblock.
74144 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
74145 SAVE /PYBINS/
74146
74147 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
74148 IS=INDX(ID)
74149 IF(IS.EQ.0) RETURN
74150 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
74151 BIN(IX)=0D0
74152 100 CONTINUE
74153
74154 RETURN
74155 END
74156
74157C*********************************************************************
74158
74159C...PYDUMP
74160C...Dumps histogram contents on file for reading by other program.
74161C...Can also read back own dump.
74162
74163 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
74164
74165C...Double precision declaration.
74166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74167 IMPLICIT INTEGER(I-N)
74168C...Commonblock.
74169 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
74170 SAVE /PYBINS/
74171C...Local arrays and character variables.
74172 DIMENSION IHI(*),ISS(100),VAL(5)
74173 CHARACTER TITLE*60,FORMAT*13
74174
74175C...Dump all histograms that have been booked,
74176C...including titles and ranges, one after the other.
74177 IF(MDUMP.EQ.1) THEN
74178
74179C...Loop over histograms and find which are wanted and booked.
74180 IF(NHI.LE.0) THEN
74181 NW=IHIST(1)
74182 ELSE
74183 NW=NHI
74184 ENDIF
74185 DO 130 IW=1,NW
74186 IF(NHI.EQ.0) THEN
74187 ID=IW
74188 ELSE
74189 ID=IHI(IW)
74190 ENDIF
74191 IS=INDX(ID)
74192 IF(IS.NE.0) THEN
74193
74194C...Write title, histogram size, filling statistics.
74195 NX=NINT(BIN(IS+1))
74196 DO 100 IT=1,20
74197 IEQ=NINT(BIN(IS+8+NX+IT))
74198 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
74199 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
74200 100 CONTINUE
74201 WRITE(LFN,5100) ID,TITLE
74202 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
74203 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
74204 & BIN(IS+8)
74205
74206
74207C...Write histogram contents, in groups of five.
74208 DO 120 IXG=1,(NX+4)/5
74209 DO 110 IXV=1,5
74210 IX=5*IXG+IXV-5
74211 IF(IX.LE.NX) THEN
74212 VAL(IXV)=BIN(IS+8+IX)
74213 ELSE
74214 VAL(IXV)=0D0
74215 ENDIF
74216 110 CONTINUE
74217 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
74218 120 CONTINUE
74219
74220C...Go to next histogram; finish.
74221 ELSEIF(NHI.GT.0) THEN
74222 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
74223 ENDIF
74224 130 CONTINUE
74225
74226C...Read back in histograms dumped MDUMP=1.
74227 ELSEIF(MDUMP.EQ.2) THEN
74228
74229C...Read histogram number, title and range, and book.
74230 140 READ(LFN,5100,END=170) ID,TITLE
74231 READ(LFN,5200) NX,XL,XU
74232 CALL PYBOOK(ID,TITLE,NX,XL,XU)
74233 IS=INDX(ID)
74234
74235C...Read filling statistics.
74236 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
74237 BIN(IS+5)=DBLE(NENTRY)
74238
74239C...Read histogram contents, in groups of five.
74240 DO 160 IXG=1,(NX+4)/5
74241 READ(LFN,5400) (VAL(IXV),IXV=1,5)
74242 DO 150 IXV=1,5
74243 IX=5*IXG+IXV-5
74244 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
74245 150 CONTINUE
74246 160 CONTINUE
74247
74248C...Go to next histogram; finish.
74249 GOTO 140
74250 170 CONTINUE
74251
74252C...Write histogram contents in column format,
74253C...convenient e.g. for GNUPLOT input.
74254 ELSEIF(MDUMP.EQ.3) THEN
74255
74256C...Find addresses to wanted histograms.
74257 NSS=0
74258 IF(NHI.LE.0) THEN
74259 NW=IHIST(1)
74260 ELSE
74261 NW=NHI
74262 ENDIF
74263 DO 180 IW=1,NW
74264 IF(NHI.EQ.0) THEN
74265 ID=IW
74266 ELSE
74267 ID=IHI(IW)
74268 ENDIF
74269 IS=INDX(ID)
74270 IF(IS.NE.0.AND.NSS.LT.100) THEN
74271 NSS=NSS+1
74272 ISS(NSS)=IS
74273 ELSEIF(NSS.GE.100) THEN
74274 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
74275 ELSEIF(NHI.GT.0) THEN
74276 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
74277 ENDIF
74278 180 CONTINUE
74279
74280C...Check that they have common number of x bins. Fix format.
74281 NX=NINT(BIN(ISS(1)+1))
74282 DO 190 IW=2,NSS
74283 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
74284 CALL PYERRM(8,'(PYDUMP:) different number of bins')
74285 RETURN
74286 ENDIF
74287 190 CONTINUE
74288 FORMAT='(1P,000E12.4)'
74289 WRITE(FORMAT(5:7),'(I3)') NSS+1
74290
74291C...Write histogram contents; first column x values.
74292 DO 200 IX=1,NX
74293 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
74294 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
74295 200 CONTINUE
74296
74297 ENDIF
74298
74299C...Formats for output.
74300 5100 FORMAT(I5,5X,A60)
74301 5200 FORMAT(I5,1P,2D12.4)
74302 5300 FORMAT(I12,1P,3D12.4)
74303 5400 FORMAT(1P,5D12.4)
74304
74305 RETURN
74306 END
74307
74308C*********************************************************************
74309
74310C...PYKCUT
74311C...Dummy routine, which the user can replace in order to make cuts on
74312C...the kinematics on the parton level before the matrix elements are
74313C...evaluated and the event is generated. The cross-section estimates
74314C...will automatically take these cuts into account, so the given
74315C...values are for the allowed phase space region only. MCUT=0 means
74316C...that the event has passed the cuts, MCUT=1 that it has failed.
74317
74318 SUBROUTINE PYKCUT(MCUT)
74319
74320C...Double precision and integer declarations.
74321 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74322 IMPLICIT INTEGER(I-N)
74323 INTEGER PYK,PYCHGE,PYCOMP
74324C...Commonblocks.
74325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74326 COMMON/PYINT1/MINT(400),VINT(400)
74327 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
74328 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
74329
74330C...Set default value (accepting event) for MCUT.
74331 MCUT=0
74332
74333C...Read out subprocess number.
74334 ISUB=MINT(1)
74335 ISTSB=ISET(ISUB)
74336
74337C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
74338 TAU=VINT(21)
74339 YST=VINT(22)
74340 CTH=0D0
74341 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
74342 TAUP=0D0
74343 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
74344
74345C...Calculate x_1, x_2, x_F.
74346 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
74347 X1=SQRT(TAU)*EXP(YST)
74348 X2=SQRT(TAU)*EXP(-YST)
74349 ELSE
74350 X1=SQRT(TAUP)*EXP(YST)
74351 X2=SQRT(TAUP)*EXP(-YST)
74352 ENDIF
74353 XF=X1-X2
74354
74355C...Calculate shat, that, uhat, p_T^2.
74356 SHAT=TAU*VINT(2)
74357 SQM3=VINT(63)
74358 SQM4=VINT(64)
74359 RM3=SQM3/SHAT
74360 RM4=SQM4/SHAT
74361 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
74362 RPTS=4D0*VINT(71)**2/SHAT
74363 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
74364 RM34=2D0*RM3*RM4
74365 RSQM=1D0+RM34
74366 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
74367 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
74368 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
74369 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
74370
74371C...Decisions by user to be put here.
74372
74373C...Stop program if this routine is ever called.
74374C...You should not copy these lines to your own routine.
74375 WRITE(MSTU(11),5000)
74376 IF(PYR(0).LT.10D0) STOP
74377
74378C...Format for error printout.
74379 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
74380 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
74381 &1X,'Execution stopped!')
74382
74383 RETURN
74384 END
74385
74386C*********************************************************************
74387
74388C...PYEVWT
74389C...Dummy routine, which the user can replace in order to multiply the
74390C...standard PYTHIA differential cross-section by a process- and
74391C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
74392C...to generation of weighted events, with weight 1/WTXS, while for
74393C...MSTP(142)=2 it corresponds to a modification of the underlying
74394C...physics.
74395
74396 SUBROUTINE PYEVWT(WTXS)
74397
74398C...Double precision and integer declarations.
74399 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74400 IMPLICIT INTEGER(I-N)
74401 INTEGER PYK,PYCHGE,PYCOMP
74402C...Commonblocks.
74403 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74404 COMMON/PYINT1/MINT(400),VINT(400)
74405 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
74406 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
74407
74408C...Set default weight for WTXS.
74409 WTXS=1D0
74410
74411C...Read out subprocess number.
74412 ISUB=MINT(1)
74413 ISTSB=ISET(ISUB)
74414
74415C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
74416 TAU=VINT(21)
74417 YST=VINT(22)
74418 CTH=0D0
74419 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
74420 TAUP=0D0
74421 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
74422
74423C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
74424 X1=VINT(41)
74425 X2=VINT(42)
74426 XF=X1-X2
74427 SHAT=VINT(44)
74428 THAT=VINT(45)
74429 UHAT=VINT(46)
74430 PT2=VINT(48)
74431
74432C...Modifications by user to be put here.
74433
74434C...Stop program if this routine is ever called.
74435C...You should not copy these lines to your own routine.
74436 WRITE(MSTU(11),5000)
74437 IF(PYR(0).LT.10D0) STOP
74438
74439C...Format for error printout.
74440 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
74441 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
74442 &1X,'Execution stopped!')
74443
74444 RETURN
74445 END
74446
74447C*********************************************************************
74448
74449C...UPINIT
74450C...Dummy routine, to be replaced by a user implementing external
74451C...processes. Is supposed to fill the HEPRUP commonblock with info
74452C...on incoming beams and allowed processes.
74453
74454C...New example: handles a standard Les Houches Events File.
74455
74456 SUBROUTINE UPINIT
74457
74458C...Double precision and integer declarations.
74459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74460 IMPLICIT INTEGER(I-N)
74461
74462C...PYTHIA commonblock: only used to provide read unit MSTP(161).
74463 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74464 SAVE /PYPARS/
74465
74466C...User process initialization commonblock.
74467 INTEGER MAXPUP
74468 PARAMETER (MAXPUP=100)
74469 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
74470 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
74471 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
74472 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
74473 &LPRUP(MAXPUP)
74474 SAVE /HEPRUP/
74475
74476C...Lines to read in assumed never longer than 200 characters.
74477 PARAMETER (MAXLEN=200)
74478 CHARACTER*(MAXLEN) STRING
74479
74480C...Format for reading lines.
74481 CHARACTER*6 STRFMT
74482 STRFMT='(A000)'
74483 WRITE(STRFMT(3:5),'(I3)') MAXLEN
74484
74485C...Loop until finds line beginning with "<init>" or "<init ".
74486 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
74487 IBEG=0
74488 110 IBEG=IBEG+1
74489C...Allow indentation.
74490 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
74491 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
74492 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
74493
74494C...Read first line of initialization info.
74495 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
74496 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
74497
74498C...Read NPRUP subsequent lines with information on each process.
74499 DO 120 IPR=1,NPRUP
74500 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
74501 & XMAXUP(IPR),LPRUP(IPR)
74502 120 CONTINUE
74503 RETURN
74504
74505C...Error exit: give up if initalization does not work.
74506 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
74507 WRITE(*,*) ' Event generation will be stopped.'
74508 STOP
74509
74510 RETURN
74511 END
74512
74513C...Old example: handles a simple Pythia 6.4 initialization file.
74514
74515c SUBROUTINE UPINIT
74516
74517C...Double precision and integer declarations.
74518c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74519c IMPLICIT INTEGER(I-N)
74520
74521C...Commonblocks.
74522c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74523c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74524c SAVE /PYDAT1/,/PYPARS/
74525
74526C...User process initialization commonblock.
74527c INTEGER MAXPUP
74528c PARAMETER (MAXPUP=100)
74529c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
74530c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
74531c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
74532c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
74533c &LPRUP(MAXPUP)
74534c SAVE /HEPRUP/
74535
74536C...Read info from file.
74537c IF(MSTP(161).GT.0) THEN
74538c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
74539c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
74540c DO 100 IPR=1,NPRUP
74541c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
74542c & XMAXUP(IPR),LPRUP(IPR)
74543c 100 CONTINUE
74544c RETURN
74545C...Error or prematurely reached end of file.
74546c 110 WRITE(MSTU(11),5000)
74547c STOP
74548
74549C...Else not implemented.
74550c ELSE
74551c WRITE(MSTU(11),5100)
74552c STOP
74553c ENDIF
74554
74555C...Format for error printout.
74556c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
74557c &1X,'Execution stopped!')
74558c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
74559c &1X,'Dummy routine in PYTHIA file called instead.'/
74560c &1X,'Execution stopped!')
74561
74562c RETURN
74563c END
74564
74565C*********************************************************************
74566
74567C...UPEVNT
74568C...Dummy routine, to be replaced by a user implementing external
74569C...processes. Depending on cross section model chosen, it either has
74570C...to generate a process of the type IDPRUP requested, or pick a type
74571C...itself and generate this event. The event is to be stored in the
74572C...HEPEUP commonblock, including (often) an event weight.
74573
74574C...New example: handles a standard Les Houches Events File.
74575
74576 SUBROUTINE UPEVNT
74577
74578C...Double precision and integer declarations.
74579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74580 IMPLICIT INTEGER(I-N)
74581
74582C...PYTHIA commonblock: only used to provide read unit MSTP(162).
74583 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74584 SAVE /PYPARS/
74585
74586C...User process event common block.
74587 INTEGER MAXNUP
74588 PARAMETER (MAXNUP=500)
74589 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74590 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74591 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74592 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74593 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74594 SAVE /HEPEUP/
74595
74596C...Lines to read in assumed never longer than 200 characters.
74597 PARAMETER (MAXLEN=200)
74598 CHARACTER*(MAXLEN) STRING
74599
74600C...Format for reading lines.
74601 CHARACTER*6 STRFMT
74602 STRFMT='(A000)'
74603 WRITE(STRFMT(3:5),'(I3)') MAXLEN
74604
74605C...Loop until finds line beginning with "<event>" or "<event ".
74606 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
74607 IBEG=0
74608 110 IBEG=IBEG+1
74609C...Allow indentation.
74610 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
74611 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
74612 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
74613
74614C...Read first line of event info.
74615 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
74616 &AQEDUP,AQCDUP
74617
74618C...Read NUP subsequent lines with information on each particle.
74619 DO 120 I=1,NUP
74620 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
74621 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
74622 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
74623 120 CONTINUE
74624 RETURN
74625
74626C...Error exit, typically when no more events.
74627 130 WRITE(*,*) ' Failed to read LHEF event information.'
74628 WRITE(*,*) ' Will assume end of file has been reached.'
74629 NUP=0
74630 MSTI(51)=1
74631
74632 RETURN
74633 END
74634
74635C...Old example: handles a simple Pythia 6.4 event file.
74636
74637c SUBROUTINE UPEVNT
74638
74639C...Double precision and integer declarations.
74640c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74641c IMPLICIT INTEGER(I-N)
74642
74643C...Commonblocks.
74644c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74645c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74646c SAVE /PYDAT1/,/PYPARS/
74647
74648C...User process event common block.
74649c INTEGER MAXNUP
74650c PARAMETER (MAXNUP=500)
74651c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74652c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74653c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74654c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74655c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74656c SAVE /HEPEUP/
74657
74658C...Read info from file.
74659c IF(MSTP(162).GT.0) THEN
74660c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
74661c & AQEDUP,AQCDUP
74662c DO 100 I=1,NUP
74663c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
74664c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
74665c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
74666c 100 CONTINUE
74667c RETURN
74668C...Special when reached end of file or other error.
74669c 110 NUP=0
74670
74671C...Else not implemented.
74672c ELSE
74673c WRITE(MSTU(11),5000)
74674c STOP
74675c ENDIF
74676
74677C...Format for error printout.
74678c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
74679c &1X,'Dummy routine in PYTHIA file called instead.'/
74680c &1X,'Execution stopped!')
74681
74682c RETURN
74683c END
74684
74685C*********************************************************************
74686
74687C...UPVETO
74688C...Dummy routine, to be replaced by user, to veto event generation
74689C...on the parton level, after parton showers but before multiple
74690C...interactions, beam remnants and hadronization is added.
74691C...If resonances like W, Z, top, Higgs and SUSY particles are handed
74692C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
74693C...be undecayed at this stage; if decayed their decay products will
74694C...have been allowed to shower.
74695
74696C...All partons at the end of the shower phase are stored in the
74697C...HEPEVT commonblock. The interesting information is
74698C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
74699C...IDHEP(I) = the particle ID code according to PDG conventions,
74700C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
74701C...All ISTHEP entries are 1, while the rest is zeroed.
74702
74703C...The user decision is to be conveyed by the IVETO value.
74704C...IVETO = 0 : retain current event and generate in full;
74705C... = 1 : abort generation of current event and move to next.
74706
74707 SUBROUTINE UPVETO(IVETO)
74708
74709C...HEPEVT commonblock.
74710 PARAMETER (NMXHEP=4000)
74711 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
74712 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
74713 DOUBLE PRECISION PHEP,VHEP
74714 SAVE /HEPEVT/
74715
74716C...Next few lines allow you to see what info PYVETO extracted from
74717C...the full event record for the first two events.
74718C...Delete if you don't want it.
74719 DATA NLIST/0/
74720 SAVE NLIST
74721 IF(NLIST.LE.2) THEN
74722 WRITE(*,*) ' Full event record at time of UPVETO call:'
74723 CALL PYLIST(1)
74724 WRITE(*,*) ' Part of event record made available to UPVETO:'
74725 CALL PYLIST(5)
74726 NLIST=NLIST+1
74727 ENDIF
74728
74729C...Make decision here.
74730 IVETO = 0
74731
74732 RETURN
74733 END
74734
74735C*********************************************************************
74736
74737C...PDFSET
74738C...Dummy routine, to be removed when PDFLIB is to be linked.
74739
74740 SUBROUTINE PDFSET(PARM,VALUE)
74741
74742C...Double precision and integer declarations.
74743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74744 IMPLICIT INTEGER(I-N)
74745 INTEGER PYK,PYCHGE,PYCOMP
74746C...Commonblocks.
74747 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74748 SAVE /PYDAT1/
74749C...Local arrays and character variables.
74750 CHARACTER*20 PARM(20)
74751 DOUBLE PRECISION VALUE(20)
74752
74753C...Stop program if this routine is ever called.
74754 WRITE(MSTU(11),5000)
74755 IF(PYR(0).LT.10D0) STOP
74756 PARM(20)=PARM(1)
74757 VALUE(20)=VALUE(1)
74758
74759C...Format for error printout.
74760 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
74761 &1X,'Dummy routine PDFSET in PYTHIA file called instead.'/
74762 &1X,'Execution stopped!')
74763
74764 RETURN
74765 END
74766
74767C*********************************************************************
74768
74769C...STRUCTM
74770C...Dummy routine, to be removed when PDFLIB is to be linked.
74771
74772 SUBROUTINE STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
74773
74774C...Double precision and integer declarations.
74775 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74776 IMPLICIT INTEGER(I-N)
74777 INTEGER PYK,PYCHGE,PYCOMP
74778C...Commonblocks.
74779 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74780 SAVE /PYDAT1/
74781C...Local variables
74782 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
74783
74784C...Stop program if this routine is ever called.
74785 WRITE(MSTU(11),5000)
74786 IF(PYR(0).LT.10D0) STOP
74787 UPV=XX+QQ
74788 DNV=XX+2D0*QQ
74789 USEA=XX+3D0*QQ
74790 DSEA=XX+4D0*QQ
74791 STR=XX+5D0*QQ
74792 CHM=XX+6D0*QQ
74793 BOT=XX+7D0*QQ
74794 TOP=XX+8D0*QQ
74795 GLU=XX+9D0*QQ
74796
74797C...Format for error printout.
74798 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
74799 &1X,'Dummy routine STRUCTM in PYTHIA file called instead.'/
74800 &1X,'Execution stopped!')
74801
74802 RETURN
74803 END
74804
74805C*********************************************************************
74806
74807C...STRUCTP
74808C...Dummy routine, to be removed when PDFLIB is to be linked.
74809
74810 SUBROUTINE STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
74811 &BOT,TOP,GLU)
74812
74813C...Double precision and integer declarations.
74814 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74815 IMPLICIT INTEGER(I-N)
74816 INTEGER PYK,PYCHGE,PYCOMP
74817C...Commonblocks.
74818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74819 SAVE /PYDAT1/
74820C...Local variables
74821 DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
74822 &TOP,GLU
74823
74824C...Stop program if this routine is ever called.
74825 WRITE(MSTU(11),5000)
74826 IF(PYR(0).LT.10D0) STOP
74827 UPV=XX+QQ2
74828 DNV=XX+2D0*QQ2
74829 USEA=XX+3D0*QQ2
74830 DSEA=XX+4D0*QQ2
74831 STR=XX+5D0*QQ2
74832 CHM=XX+6D0*QQ2
74833 BOT=XX+7D0*QQ2
74834 TOP=XX+8D0*QQ2
74835 GLU=XX+9D0*QQ2
74836
74837C...Format for error printout.
74838 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
74839 &1X,'Dummy routine STRUCTP in PYTHIA file called instead.'/
74840 &1X,'Execution stopped!')
74841
74842 RETURN
74843 END
74844
74845C*********************************************************************
74846
74847C...SUGRA
74848C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
74849
74850 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
74851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74852 IMPLICIT INTEGER(I-N)
74853 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
74854 INTEGER IMODL
74855C...Commonblocks.
74856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74857 SAVE /PYDAT1/
74858
74859C...Stop program if this routine is ever called.
74860 WRITE(MSTU(11),5000)
74861 IF(PYR(0).LT.10D0) STOP
74862
74863C...Format for error printout.
74864 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
74865 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
74866 &1X,'Execution stopped!')
74867
74868 RETURN
74869 END
74870
74871C*********************************************************************
74872
74873C...VISAJE
74874C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
74875
74876 FUNCTION VISAJE()
74877 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74878 IMPLICIT INTEGER(I-N)
74879 CHARACTER*40 VISAJE
74880
74881C...Commonblocks.
74882 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74883 SAVE /PYDAT1/
74884
74885C...Assign default value.
74886 VISAJE='Undefined'
74887
74888C...Stop program if this routine is ever called.
74889 WRITE(MSTU(11),5000)
74890 IF(PYR(0).LT.10D0) STOP
74891
74892C...Format for error printout.
74893 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
74894 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
74895 &1X,'Execution stopped!')
74896
74897 RETURN
74898 END
74899
74900C*********************************************************************
74901
74902C...SSMSSM
74903C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
74904
74905 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
74906 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
74907 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
74908 &IDUM1,IDUM2)
74909 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74910 IMPLICIT INTEGER(I-N)
74911 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
74912 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
74913 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
74914C...Commonblocks.
74915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74916 SAVE /PYDAT1/
74917
74918C...Stop program if this routine is ever called.
74919 WRITE(MSTU(11),5000)
74920 IF(PYR(0).LT.10D0) STOP
74921
74922C...Format for error printout.
74923 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
74924 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
74925 &1X,'Execution stopped!')
74926 RETURN
74927 END
74928
74929C*********************************************************************
74930
74931C...FHSETFLAGS
74932C...Dummy function, to be removed when FEYNHIGGS is to be linked.
74933
74934 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
74935 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74936 IMPLICIT INTEGER(I-N)
74937Cmssmpart = 4 # full MSSM [recommended]
74938Cfieldren = 0 # MSbar field ren. [strongly recommended]
74939Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
74940Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
74941Cp2approx = 0 # no approximation [recommended]
74942Clooplevel= 2 # include 2-loop corrections
74943Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
74944Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
74945
74946C...Commonblocks.
74947 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74948 SAVE /PYDAT1/
74949
74950C...Stop program if this routine is ever called.
74951 WRITE(MSTU(11),5000)
74952 IF(PYR(0).LT.10D0) STOP
74953
74954C...Format for error printout.
74955 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
74956 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
74957 &1X,'Execution stopped!')
74958 RETURN
74959 END
74960
74961C*********************************************************************
74962
74963C...FHSETPARA
74964C...Dummy function, to be removed when FEYNHIGGS is to be linked.
74965
74966 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
74967 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
74968 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
74969 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
74970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74971 IMPLICIT INTEGER(I-N)
74972
74973 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
74974 DOUBLE COMPLEX DMU,
74975 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
74976 & DM1, DM2, DM3
74977
74978C...Commonblocks.
74979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74980 SAVE /PYDAT1/
74981
74982C...Stop program if this routine is ever called.
74983 WRITE(MSTU(11),5000)
74984 IF(PYR(0).LT.10D0) STOP
74985
74986C...Format for error printout.
74987 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
74988 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
74989 &1X,'Execution stopped!')
74990 RETURN
74991 END
74992
74993C*********************************************************************
74994
74995C...FHHIGGSCORR
74996C...Dummy function, to be removed when FEYNHIGGS is to be linked.
74997
74998 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
74999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75000 IMPLICIT INTEGER(I-N)
75001
75002C...FeynHiggs variables
75003 DOUBLE PRECISION RMHIGG(4)
75004 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
75005 DOUBLE COMPLEX DMU,
75006 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
75007 & DM1, DM2, DM3
75008
75009C...Commonblocks.
75010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75011 SAVE /PYDAT1/
75012
75013C...Stop program if this routine is ever called.
75014 WRITE(MSTU(11),5000)
75015 IF(PYR(0).LT.10D0) STOP
75016
75017C...Format for error printout.
75018 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
75019 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
75020 &1X,'Execution stopped!')
75021 RETURN
75022 END
75023
75024C*********************************************************************
75025
75026C...PYTAUD
75027C...Dummy routine, to be replaced by user, to handle the decay of a
75028C...polarized tau lepton.
75029C...Input:
75030C...ITAU is the position where the decaying tau is stored in /PYJETS/.
75031C...IORIG is the position where the mother of the tau is stored;
75032C... is 0 when the mother is not stored.
75033C...KFORIG is the flavour of the mother of the tau;
75034C... is 0 when the mother is not known.
75035C...Note that IORIG=0 does not necessarily imply KFORIG=0;
75036C... e.g. in B hadron semileptonic decays the W propagator
75037C... is not explicitly stored but the W code is still unambiguous.
75038C...Output:
75039C...NDECAY is the number of decay products in the current tau decay.
75040C...These decay products should be added to the /PYJETS/ common block,
75041C...in positions N+1 through N+NDECAY. For each product I you must
75042C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
75043C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
75044
75045 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
75046
75047C...Double precision and integer declarations.
75048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75049 IMPLICIT INTEGER(I-N)
75050 INTEGER PYK,PYCHGE,PYCOMP
75051C...Commonblocks.
75052 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75054 SAVE /PYJETS/,/PYDAT1/
75055
75056C...Stop program if this routine is ever called.
75057C...You should not copy these lines to your own routine.
75058 NDECAY=ITAU+IORIG+KFORIG
75059 WRITE(MSTU(11),5000)
75060 IF(PYR(0).LT.10D0) STOP
75061
75062C...Format for error printout.
75063 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
75064 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75065 &1X,'Execution stopped!')
75066
75067 RETURN
75068 END
75069
75070C*********************************************************************
75071
75072C...PYTIME
75073C...Finds current date and time.
75074C...Since this task is not standardized in Fortran 77, the routine
75075C...is dummy, to be replaced by the user. Examples are given for
75076C...the Fortran 90 routine and DEC Fortran 77, and what to do if
75077C...you do not have access to suitable routines.
75078
75079 SUBROUTINE PYTIME(IDATI)
75080
75081C...Double precision and integer declarations.
75082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75083 IMPLICIT INTEGER(I-N)
75084 INTEGER PYK,PYCHGE,PYCOMP
75085 CHARACTER*8 ATIME
75086C...Local array.
75087 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
75088
75089C...Example 0: if you do not have suitable routines.
75090 DO 100 J=1,6
75091 IDATI(J)=0
75092 100 CONTINUE
75093
75094C...Example 1: Fortran 90 routine.
75095C CALL DATE_AND_TIME(VALUES=IVAL)
75096C IDATI(1)=IVAL(1)
75097C IDATI(2)=IVAL(2)
75098C IDATI(3)=IVAL(3)
75099C IDATI(4)=IVAL(5)
75100C IDATI(5)=IVAL(6)
75101C IDATI(6)=IVAL(7)
75102
75103C...Example 2: DEC Fortran 77. AIX.
75104C CALL IDATE(IMON,IDAY,IYEAR)
75105C IDATI(1)=IYEAR
75106C IDATI(2)=IMON
75107C IDATI(3)=IDAY
75108C CALL ITIME(IHOUR,IMIN,ISEC)
75109C IDATI(4)=IHOUR
75110C IDATI(5)=IMIN
75111C IDATI(6)=ISEC
75112
75113C...Example 3: DEC Fortran, IRIX, IRIX64.
75114C CALL IDATE(IMON,IDAY,IYEAR)
75115C IDATI(1)=IYEAR
75116C IDATI(2)=IMON
75117C IDATI(3)=IDAY
75118C CALL TIME(ATIME)
75119C IHOUR=0
75120C IMIN=0
75121C ISEC=0
75122C READ(ATIME(1:2),'(I2)') IHOUR
75123C READ(ATIME(4:5),'(I2)') IMIN
75124C READ(ATIME(7:8),'(I2)') ISEC
75125C IDATI(4)=IHOUR
75126C IDATI(5)=IMIN
75127C IDATI(6)=ISEC
75128
75129C...Example 4: GNU LINUX libU77, SunOS.
75130C CALL IDATE(IDTEMP)
75131C IDATI(1)=IDTEMP(3)
75132C IDATI(2)=IDTEMP(2)
75133C IDATI(3)=IDTEMP(1)
75134C CALL ITIME(IDTEMP)
75135C IDATI(4)=IDTEMP(1)
75136C IDATI(5)=IDTEMP(2)
75137C IDATI(6)=IDTEMP(3)
75138
75139C...Common code to ensure right century.
75140 IDATI(1)=2000+MOD(IDATI(1),100)
75141
75142 RETURN
75143 END