]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/pythia-6.4.14.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Alifatal removed in GetWord. Put AliWarning (+AddMajorErrorLog)
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia-6.4.14.f
CommitLineData
a59803b8 1C*********************************************************************
2C*********************************************************************
3C* **
4C* November 2007 **
5C* **
6C* The Lund Monte Carlo **
7C* **
8C* PYTHIA version 6.4 **
9C* **
10C* Torbjorn Sjostrand **
11C* CERN/PH, CH-1211 Geneva, Switzerland **
12C* phone +41 - 22 - 767 82 27 **
13C* and **
14C* Department of Theoretical Physics **
15C* Lund University **
16C* Solvegatan 14A, S-223 62 Lund, Sweden **
17C* E-mail torbjorn@thep.lu.se **
18C* **
19C* SUSY and Technicolor parts by **
20C* Stephen Mrenna **
21C* Computing Division **
22C* Generators and Detector Simulation Group **
23C* Fermi National Accelerator Laboratory **
24C* MS 234, Batavia, IL 60510, USA **
25C* phone + 1 - 630 - 840 - 2556 **
26C* E-mail mrenna@fnal.gov **
27C* **
28C* New multiple interactions and more SUSY parts by **
29C* Peter Skands **
30C* Theoretical Physics Department **
31C* Fermi National Accelerator Laboratory **
32C* MS 106, Batavia, IL 60510, USA **
33C* and **
34C* CERN/PH, CH-1211 Geneva, Switzerland **
35C* phone +41 - 22 - 767 24 59 **
36C* E-mail skands@fnal.gov **
37C* **
38C* Several parts are written by Hans-Uno Bengtsson **
39C* PYSHOW is written together with Mats Bengtsson **
40C* PYMAEL is written by Emanuel Norrbin **
41C* advanced popcorn baryon production written by Patrik Eden **
42C* code for virtual photons mainly written by Christer Friberg **
43C* code for low-mass strings mainly written by Emanuel Norrbin **
44C* Bose-Einstein code mainly written by Leif Lonnblad **
45C* CTEQ parton distributions are by the CTEQ collaboration **
46C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
47C* SaS photon parton distributions together with Gerhard Schuler **
48C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
49C* MSSM Higgs mass calculation code by M. Carena, **
50C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
51C* PYGAUS adapted from CERN library (K.S. Kolbig) **
52C* NRQCD/colour octet production of onium by S. Wolf **
53C* **
54C* The latest program version and documentation is found on WWW **
55C* http://www.thep.lu.se/~torbjorn/Pythia.html **
56C* **
57C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2007 **
58C* **
59C*********************************************************************
60C*********************************************************************
61C *
62C List of subprograms in order of appearance, with main purpose *
63C (S = subroutine, F = function, B = block data) *
64C *
65C B PYDATA to contain all default values *
66C S PYCKBD to check that BLOCK DATA has been correctly loaded *
67C S PYTEST to test the proper functioning of the package *
68C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
69C *
70C S PYINIT to administer the initialization procedure *
71C S PYEVNT to administer the generation of an event *
72C S PYEVNW ditto, for new multiple interactions scenario *
73C S PYSTAT to print cross-section and other information *
74C S PYUPEV to administer the generation of an LHA hard process *
75C S PYUPIN to provide initialization needed for LHA input *
76C S PYLHEF to produce a Les Houches Event File from run *
77C S PYINRE to initialize treatment of resonances *
78C S PYINBM to read in beam, target and frame choices *
79C S PYINKI to initialize kinematics of incoming particles *
80C S PYINPR to set up the selection of included processes *
81C S PYXTOT to give total, elastic and diffractive cross-sect. *
82C S PYMAXI to find differential cross-section maxima *
83C S PYPILE to select multiplicity of pileup events *
84C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
85C S PYGAGA to handle lepton -> lepton + gamma branchings *
86C S PYRAND to select subprocess and kinematics for event *
87C S PYSCAT to set up kinematics and colour flow of event *
88C S PYEVOL handler for pT-ordered ISR and multiple interactions *
89C S PYSSPA to simulate initial state spacelike showers *
90C S PYPTIS to do pT-ordered initial state spacelike showers *
91C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
92C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
93C S PYPTMI to do pT-ordered multiple interactions *
94C F PYFCMP to give companion quark x*f distribution *
95C F PYPCMP to calculate momentum integral for companion quarks *
96C S PYUPRE to rearranges contents of the HEPEUP commonblock *
97C S PYADSH to administrate sequential final-state showers *
98C S PYVETO to allow the generation of an event to be aborted *
99C S PYRESD to perform resonance decays *
100C S PYMULT to generate multiple interactions - old scheme *
101C S PYREMN to add on target remnants - old scheme *
102C S PYMIGN to generate multiple interactions - new scheme *
103C S PYMIHK to connect colours in mult. int. - new scheme *
104C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
105C S PYMIHG to collapse two pairs of LHA1 colour tags. *
106C S PYMIRM to add on target remnants in mult. int.- new scheme *
107C S PYFSCR to perform final state colour reconnections - -"- *
108C S PYDIFF to set up kinematics for diffractive events *
109C S PYDISG to set up kinematics, remnant and showers for DIS *
110C S PYDOCU to compute cross-sections and handle documentation *
111C S PYFRAM to perform boosts between different frames *
112C S PYWIDT to calculate full and partial widths of resonances *
113C S PYOFSH to calculate partial width into off-shell channels *
114C S PYRECO to handle colour reconnection in W+W- events *
115C S PYKLIM to calculate borders of allowed kinematical region *
116C S PYKMAP to construct value of kinematical variable *
117C S PYSIGH to calculate differential cross-sections *
118C S PYSGQC auxiliary to PYSIGH for QCD processes *
119C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
120C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
121C S PYSGHG auxiliary to PYSIGH for Higgs processes *
122C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
123C S PYSGTC auxiliary to PYSIGH for technicolor processes *
124C S PYSGEX auxiliary to PYSIGH for various exotic processes *
125C S PYPDFU to evaluate parton distributions *
126C S PYPDFL to evaluate parton distributions at low x and Q^2 *
127C S PYPDEL to evaluate electron parton distributions *
128C S PYPDGA to evaluate photon parton distributions (generic) *
129C S PYGGAM to evaluate photon parton distributions (SaS sets) *
130C S PYGVMD to evaluate VMD part of photon parton distributions *
131C S PYGANO to evaluate anomalous part of photon PDFs *
132C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
133C S PYGDIR to evaluate direct contribution to photon PDFs *
134C S PYPDPI to evaluate pion parton distributions *
135C S PYPDPR to evaluate proton parton distributions *
136C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
137C S PYGRVL to evaluate the GRV 94L proton parton distributions *
138C S PYGRVM to evaluate the GRV 94M proton parton distributions *
139C S PYGRVD to evaluate the GRV 94D proton parton distributions *
140C F PYGRVV auxiliary to the PYGRV* routines *
141C F PYGRVW auxiliary to the PYGRV* routines *
142C F PYGRVS auxiliary to the PYGRV* routines *
143C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
144C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
145C S PYPDPO to evaluate old proton parton distributions *
146C F PYHFTH to evaluate threshold factor for heavy flavour *
147C S PYSPLI to find flavours left in hadron when one removed *
148C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
149C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
150C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
151C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
152C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
153C S PYSTBH to evaluate matrix element for t + b + H processes *
154C S PYTBHB auxiliary to PYSTBH *
155C S PYTBHG auxiliary to PYSTBH *
156C S PYTBHQ auxiliary to PYSTBH *
157C F PYTBHS auxiliary to PYSTBH *
158C *
159C S PYMSIN to initialize the supersymmetry simulation *
160C S PYSLHA to interface to SUSY spectrum and decay calculators *
161C S PYAPPS to determine MSSM parameters from SUGRA input *
162C S PYSUGI to determine MSSM parameters using ISASUSY *
163C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
164C F PYRNMQ to determine running squark masses *
165C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
166C S PYINOM to calculate neutralino/chargino mass eigenstates *
167C F PYRNM3 to determine running M3, gluino mass *
168C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
169C S PYHGGM to determine Higgs mass spectrum *
170C S PYSUBH to determine Higgs masses in the MSSM *
171C S PYPOLE to determine Higgs masses in the MSSM *
172C S PYRGHM auxiliary to PYPOLE *
173C S PYGFXX auxiliary to PYRGHM *
174C F PYFINT auxiliary to PYPOLE *
175C F PYFISB auxiliary to PYFINT *
176C S PYSFDC to calculate sfermion decay partial widths *
177C S PYGLUI to calculate gluino decay partial widths *
178C S PYTBBN to calculate 3-body decay of gluino to neutralino *
179C S PYTBBC to calculate 3-body decay of gluino to chargino *
180C S PYNJDC to calculate neutralino decay partial widths *
181C S PYCJDC to calculate chargino decay partial widths *
182C F PYXXZ6 auxiliary for ino 3-body decays *
183C F PYXXGA auxiliary for ino -> ino + gamma decay *
184C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
185C F PYX2XH auxiliary for ino -> ino + Higgs decay *
186C S PYHEXT to calculate non-SM Higgs decay partial widths *
187C F PYH2XX auxiliary for H -> ino + ino decay *
188C F PYGAUS to perform Gaussian integration *
189C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
190C F PYSIMP to perform Simpson integration *
191C F PYLAMF to evaluate the lambda kinematics function *
192C S PYTBDY to perform 3-body decay of gauginos *
193C S PYTECM to calculate techni_rho/omega masses *
194C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
195C S PYCMQR auxiliary to PYEICG *
196C S PYCMQ2 auxiliary to PYEICG *
197C S PYCDIV auxiliary to PYCMQR *
198C S PYCSRT auxiliary to PYCMQR *
199C S PYTHAG auxiliary to PYCMQR *
200C S PYCBAL auxiliary to PYEICG *
201C S PYCBA2 auxiliary to PYEICG *
202C S PYCRTH auxiliary to PYEICG *
203C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
204C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
205C S PYWIDX to calculate decay widths from within PYWIDT *
206C S PYRVSF to calculate R-violating sfermion decay widths *
207C S PYRVNE to calculate R-violating neutralino decay widths *
208C S PYRVCH to calculate R-violating chargino decay widths *
209C S PYRVGL to calculate R-violating gluino decay widths *
210C F PYRVSB auxiliary to PYRVSF *
211C S PYRVGW to calculate R-Violating 3-body widths *
212C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
213C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
214C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
215C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
216C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
217C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
218C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
219C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
220C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
221C *
222C S PY1ENT to fill one entry (= parton or particle) *
223C S PY2ENT to fill two entries *
224C S PY3ENT to fill three entries *
225C S PY4ENT to fill four entries *
226C S PY2FRM to interface to generic two-fermion generator *
227C S PY4FRM to interface to generic four-fermion generator *
228C S PY6FRM to interface to generic six-fermion generator *
229C S PY4JET to generate a shower from a given 4-parton config *
230C S PY4JTW to evaluate the weight od a shower history for above *
231C S PY4JTS to set up the parton configuration for above *
232C S PYJOIN to connect entries with colour flow information *
233C S PYGIVE to fill (or query) commonblock variables *
234C S PYONOF to allow easy control of particle decay modes *
235C S PYTUNE to select a predefined 'tune' for min-bias and UE *
236C S PYEXEC to administrate fragmentation and decay chain *
237C S PYPREP to rearrange showered partons along strings *
238C S PYSTRF to do string fragmentation of jet system *
239C S PYJURF to find boost to string junction rest frame *
240C S PYINDF to do independent fragmentation of one or many jets *
241C S PYDECY to do the decay of a particle *
242C S PYDCYK to select parton and hadron flavours in decays *
243C S PYKFDI to select parton and hadron flavours in fragm *
244C S PYNMES to select number of popcorn mesons *
245C S PYKFIN to calculate falvour prod. ratios from input params. *
246C S PYPTDI to select transverse momenta in fragm *
247C S PYZDIS to select longitudinal scaling variable in fragm *
248C S PYSHOW to do m-ordered timelike parton shower evolution *
249C S PYPTFS to do pT-ordered timelike parton shower evolution *
250C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
251C S PYBOEI to include Bose-Einstein effects (crudely) *
252C S PYBESQ auxiliary to PYBOEI *
253C F PYMASS to give the mass of a particle or parton *
254C F PYMRUN to give the running MSbar mass of a quark *
255C S PYNAME to give the name of a particle or parton *
256C F PYCHGE to give three times the electric charge *
257C F PYCOMP to compress standard KF flavour code to internal KC *
258C S PYERRM to write error messages and abort faulty run *
259C F PYALEM to give the alpha_electromagnetic value *
260C F PYALPS to give the alpha_strong value *
261C F PYANGL to give the angle from known x and y components *
262C F PYR to provide a random number generator *
263C S PYRGET to save the state of the random number generator *
264C S PYRSET to set the state of the random number generator *
265C S PYROBO to rotate and/or boost an event *
266C S PYEDIT to remove unwanted entries from record *
267C S PYLIST to list event record or particle data *
268C S PYLOGO to write a logo *
269C S PYUPDA to update particle data *
270C F PYK to provide integer-valued event information *
271C F PYP to provide real-valued event information *
272C S PYSPHE to perform sphericity analysis *
273C S PYTHRU to perform thrust analysis *
274C S PYCLUS to perform three-dimensional cluster analysis *
275C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
276C S PYJMAS to give high and low jet mass of event *
277C S PYFOWO to give Fox-Wolfram moments *
278C S PYTABU to analyze events, with tabular output *
279C *
280C S PYEEVT to administrate the generation of an e+e- event *
281C S PYXTEE to give the total cross-section at given CM energy *
282C S PYRADK to generate initial state photon radiation *
283C S PYXKFL to select flavour of primary qqbar pair *
284C S PYXJET to select (matrix element) jet multiplicity *
285C S PYX3JT to select kinematics of three-jet event *
286C S PYX4JT to select kinematics of four-jet event *
287C S PYXDIF to select angular orientation of event *
288C S PYONIA to perform generation of onium decay to gluons *
289C *
290C S PYBOOK to book a histogram *
291C S PYFILL to fill an entry in a histogram *
292C S PYFACT to multiply histogram contents by a factor *
293C S PYOPER to perform operations between histograms *
294C S PYHIST to print and reset all histograms *
295C S PYPLOT to print a single histogram *
296C S PYNULL to reset contents of a single histogram *
297C S PYDUMP to dump histogram contents onto a file *
298C *
299C S PYSTOP routine to handle Fortran STOP condition *
300C *
301C S PYKCUT dummy routine for user kinematical cuts *
302C S PYEVWT dummy routine for weighting events *
303C S UPINIT dummy routine to initialize user processes *
304C S UPEVNT dummy routine to generate a user process event *
305C S UPVETO dummy routine to abort event at parton level *
306C S PDFSET dummy routine to be removed when using PDFLIB *
307C S STRUCTM dummy routine to be removed when using PDFLIB *
308C S STRUCTP dummy routine to be removed when using PDFLIB *
309C S SUGRA dummy routine to be removed when linking with ISAJET *
310C F VISAJE dummy functn. to be removed when linking with ISAJET *
311C S SSMSSM dummy routine to be removed when linking with ISAJET *
312C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
313C S FHSETPARA dummy routine -"- FEYNHIGGS *
314C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
315C S PYTAUD dummy routine for interface to tau decay libraries *
316C S PYTIME dummy routine for giving date and time *
317C *
318C*********************************************************************
319
320C...PYDATA
321C...Default values for switches and parameters,
322C...and particle, decay and process data.
323
324 BLOCK DATA PYDATA
325
326C...Double precision and integer declarations.
327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
328 IMPLICIT INTEGER(I-N)
329 INTEGER PYK,PYCHGE,PYCOMP
330C...Commonblocks.
331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
333 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
334 COMMON/PYDAT4/CHAF(500,2)
335 CHARACTER CHAF*16
336 COMMON/PYDATR/MRPY(6),RRPY(100)
337 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
338 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
339 COMMON/PYINT1/MINT(400),VINT(400)
340 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
341 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
342 COMMON/PYINT4/MWID(500),WIDS(500,5)
343 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
344 COMMON/PYINT6/PROC(0:500)
345 CHARACTER PROC*28
346 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
347 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
348 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
349 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
350 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
351 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
352 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
353 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
354 & AU(3,3),AD(3,3),AE(3,3)
355 COMMON/PYLH3C/CPRO(2),CVER(2)
356 CHARACTER CPRO*12,CVER*12
357 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
358 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
359 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,
360 &/PYBINS/,/PYLH3P/,/PYLH3C/
361
362C...PYDAT1, containing status codes and most parameters.
363 DATA MSTU/
364 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
365 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
366 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
367 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
368 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
369 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
370 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
371 7 30*0,
372 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
374 & 80*0/
375 DATA (PARU(I),I=1,100)/
376 & 3.141592653589793D0, 6.283185307179586D0,
377 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
378 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
379 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
380 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
381 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
382 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
383 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
384 6 40*0D0/
385 DATA (PARU(I),I=101,200)/
386 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
387 & 0D0, 0D0, 0D0, 0D0, 0D0,
388 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
389 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
390 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
391 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
392 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
393 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
394 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
395 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
396 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
397 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
398 DATA MSTJ/
399 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
400 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
401 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
402 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
403 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
404 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
405 6 40*0,
406 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
407 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
408 2 80*0/
409 DATA PARJ/
410 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
411 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
412 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
413 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
414 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
415 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
416 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
417 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
418 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
419 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
420 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
421 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
422 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
423 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
424 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
425 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
426 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
427 4 10*0D0,
428 5 10*0D0,
429 6 10*0D0,
430 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
431 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
432 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
433 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
434 9 5*0D0/
435
436C...PYDAT2, with particle data and flavour treatment parameters.
437 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
438 &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
439 &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
440 &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
441 &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
442 &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
443 &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
444 &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
445 &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
446 &7*0,3,131*0/
447 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
448 &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
449 &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
450 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,133*0/
451 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
452 &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
453 &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
454 &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1,131*0/
455 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
456 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
457 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
458 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
459 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
460 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
461 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
462 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
463 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
464 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
465 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
466 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
467 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
468 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
469 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
470 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
471 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
472 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
473 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
474 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
475 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
476 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
477 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
478 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
479 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
480 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
481 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
482 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
483 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
484 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
485 &3000115,3000215,131*0/
486 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
487 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
488 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
489 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
490 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
491 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
492 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
493 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
494 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
495 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
496 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
497 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
498 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
499 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
500 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
501 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
502 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
503 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
504 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
505 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
506 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
507 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
508 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
509 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
510 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
511 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
512 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
513 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
514 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
515 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
516 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
517 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
518 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
519 &3*9.5D0,2*250D0,131*0D0/
520 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
521 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
522 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
523 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
524 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
525 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
526 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
527 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
528 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
529 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
530 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
531 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
532 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
533 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
534 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
535 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
536 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
537 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
538 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
539 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
540 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
541 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
542 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
543 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
544 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
545 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
546 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
547 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
548 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
549 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
550 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
551 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
552 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
553 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
554 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
555 &8.80013D0,13*0D0,2.54987D0,2.84456D0,131*0D0/
556 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
557 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
558 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
559 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
560 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
561 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
562 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
563 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
564
565 DATA PARF/
566 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
567 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
568 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
569 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
570 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
571 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
572 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
573 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
574 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
575 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
576 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
577 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
578 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
579 3 60*0D0,
580 4 0.2D0, 0.5D0, 8*0D0,
581 5 1800*0D0/
582 DATA ((VCKM(I,J),J=1,4),I=1,4)/
583 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
584 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
585 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
586 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
587
588C...PYDAT3, with particle decay parameters and data.
589 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
590 &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
591 &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
592 &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1,131*0/
593 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
594 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
595 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
596 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
597 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
598 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
599 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
600 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
601 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
602 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
603 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
604 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
605 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
606 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
607 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
608 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
609 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
610 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
611 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
612 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
613 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
614 &4214,4215,4216,4296,4322,131*0/
615 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
616 &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
617 &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
618 &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
619 &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
620 &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
621 &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
622 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
623 &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
624 &3*22,15,12,2*7,7*0,6*1,26,30,131*0/
625 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
626 &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
627 &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
628 &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
629 &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
630 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
631 &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
632 &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
633 &5*-1,3*1,-1,3649*0/
634 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
635 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
636 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
637 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
638 &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
639 &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
640 &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
641 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
642 &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
643 &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
644 &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
645 &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
646 &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
647 &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
648 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
649 &16*32,3653*0/
650 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
651 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
652 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
653 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
654 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
655 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
656 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
657 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
658 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
659 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
660 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
661 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
662 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
663 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
664 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
665 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
666 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
667 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
668 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
669 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
670 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
671 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
672 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
673 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
674 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
675 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
676 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
677 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
678 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
679 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
680 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
681 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
682 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
683 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
684 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
685 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
686 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
687 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
688 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
689 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
690 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
691 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
692 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
693 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
694 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
695 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
696 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
697 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
698 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
699 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
700 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
701 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
702 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
703 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
704 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
705 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
706 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
707 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
708 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
709 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
710 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
711 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
712 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
713 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
714 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
715 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
716 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
717 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
718 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
719 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
720 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
721 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
722 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
723 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
724 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
725 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
726 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
727 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
728 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
729 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
730 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
731 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
732 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
733 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
734 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
735 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
736 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
737 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
738 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
739 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
740 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
741 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
742 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
743 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
744 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
745 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
746 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
747 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
748 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
749 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
750 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
751 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
752 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
753 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
754 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
755 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
756 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
757 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
758 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
759 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
760 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
761 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
762 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
763 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
764 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
765 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
766 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
767 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
768 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
769 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
770 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
771 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
772 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
773 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
774 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
775 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
776 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
777 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
778 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
779 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
780 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
781 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
782 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
783 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
784 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
785 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
786 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
787 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
788 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
789 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
790 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
791 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
792 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
793 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
794 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
795 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
796 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
797 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
798 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
799 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
800 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
801 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
802 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
803 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
804 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
805 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
806 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
807 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
808 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
809 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
810 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
811 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
812 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
813 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
814 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
815 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
816 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
817 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
818 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
819 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
820 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
821 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
822 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
823 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
824 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
825 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
826 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
827 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
828 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
829 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
830 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
831 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
832 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
833 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
834 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
835 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
836 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
837 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
838 &2*0.011947D0,0.011946D0,0D0,3649*0D0/
839 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
840 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
841 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
842 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
843 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
844 &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
845 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
846 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
847 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
848 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
849 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
850 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
851 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
852 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
853 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
854 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
855 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
856 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
857 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
858 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
859 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
860 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
861 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
862 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
863 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
864 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
865 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
866 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
867 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
868 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
869 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
870 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
871 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
872 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
873 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
874 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
875 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
876 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
877 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
878 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
879 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
880 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
881 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
882 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
883 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
884 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
885 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
886 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
887 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
888 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
889 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
890 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
891 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
892 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
893 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
894 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
895 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
896 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
897 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
898 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
899 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
900 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
901 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
902 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
903 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
904 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
905 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
906 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
907 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
908 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
909 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
910 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
911 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
912 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
913 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
914 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
915 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
916 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
917 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
918 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
919 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
920 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
921 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
922 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
923 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
924 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
925 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
926 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
927 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
928 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
929 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
930 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
931 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
932 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
933 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
934 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
935 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
936 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
937 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
938 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
939 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
940 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
941 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
942 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
943 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
944 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
945 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
946 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
947 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
948 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
949 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
950 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
951 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
952 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
953 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
954 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
955 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
956 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
957 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
958 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
959 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
960 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
961 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
962 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
963 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
964 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
965 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
966 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
967 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
968 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
969 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
970 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
971 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
972 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
973 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
974 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
975 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
976 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
977 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
978 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
979 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
980 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
981 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
982 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
983 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
984 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
985 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
986 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
987 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
988 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
989 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
990 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
991 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
992 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
993 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
994 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
995 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
996 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
997 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
998 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
999 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1000 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1001 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1002 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1003 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1004 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1005 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1006 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1007 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1008 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1009 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1010 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1011 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1012 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1013 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1014 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1015 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1016 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1017 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1018 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1019 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1020 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1021 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1022 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1023 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1024 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1025 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1026 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1027 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1028 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1029 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1030 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1031 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1032 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1033 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1034 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1035 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1036 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1037 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1038 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1039 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1040 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1041 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1042 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1043 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1044 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1045 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1046 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1047 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1048 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1049 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1050 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1051 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1052 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1053 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1054 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1055 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1056 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1057 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1058 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1059 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1060 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1061 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1062 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1063 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1064 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1065 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1066 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1067 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1068 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1069 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1070 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1071 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1072 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1073 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1074 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1075 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1076 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1077 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1078 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1079 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1080 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1081 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1082 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1083 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1084 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1085 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1086 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1087 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1088 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1089 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1090 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1091 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1092 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1093 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1094 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1095 &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,
1096 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1097 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1098 &21,22,23,24,9*11,9*-11,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/
1099 DATA (KFDP(I,1),I=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,
1100 &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1101 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1102 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1103 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1104 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1105 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1106 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1107 &-11,-13,-15,-17,3649*0/
1108 DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
1109 &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
1110 &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
1111 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1112 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1113 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1114 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1115 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1116 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1117 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1118 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1119 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1120 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1121 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1122 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1123 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1124 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1125 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1126 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1127 &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
1128 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1129 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1130 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1131 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1132 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1133 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1134 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1135 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1136 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1137 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1138 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1139 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1140 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1141 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1142 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1143 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1144 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1145 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1146 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1147 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1148 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1149 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1150 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1151 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1152 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1153 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1154 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1155 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1156 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1157 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1158 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1159 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1160 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1161 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1162 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1163 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1164 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1165 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1166 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1167 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1168 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1169 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1170 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1171 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1172 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1173 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1174 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1175 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1176 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1177 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1178 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1179 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1180 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1181 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1182 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1183 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1184 &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
1185 &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
1186 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1187 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
1188 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1189 &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
1190 &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
1191 &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
1192 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1193 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1194 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1195 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1196 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1197 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1198 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1199 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1200 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1201 &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
1202 &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
1203 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1204 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
1205 &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
1206 &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
1207 &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
1208 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1209 &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
1210 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1211 &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
1212 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1213 &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
1214 &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
1215 &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,
1216 &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
1217 &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
1218 &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
1219 &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
1220 &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
1221 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1222 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1223 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1224 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1225 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1226 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1227 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
1228 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1229 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1230 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1231 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1232 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1233 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1234 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1235 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1236 &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
1237 &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
1238 &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
1239 &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
1240 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1241 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1242 &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
1243 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1244 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1245 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1246 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1247 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1248 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1249 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1250 &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
1251 &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
1252 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1253 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1254 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1255 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1256 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1257 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1258 &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
1259 &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
1260 &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
1261 &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
1262 &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
1263 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1264 &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
1265 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1266 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1267 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1268 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1269 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1270 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1271 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1272 &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
1273 &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
1274 &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
1275 &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
1276 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1277 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1278 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1279 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1280 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1281 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1282 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1283 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1284 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1285 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1286 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1287 &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
1288 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1289 &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
1290 &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
1291 &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
1292 &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
1293 &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
1294 &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
1295 &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
1296 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1297 &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
1298 &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
1299 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1300 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1301 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1302 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1303 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1304 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1305 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
1306 &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
1307 &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1308 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1309 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1310 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1311 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1312 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1313 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1314 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1315 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1316 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1317 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1318 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1319 &3649*0/
1320 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1321 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1322 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1323 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1324 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1325 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1326 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1327 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1328 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1329 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1330 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1331 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1332 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1333 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1334 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1335 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1336 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1337 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1338 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1339 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1340 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1341 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1342 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1343 &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
1344 &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
1345 &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1346 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1347 &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
1348 &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
1349 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1350 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1351 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1352 &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
1353 &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1354 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1355 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1356 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
1357 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1358 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1359 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1360 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1361 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1362 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1363 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
1364 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1365 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1366 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1367 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1368 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1369 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1370 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1371 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1372 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1373 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
1374 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1375 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1376 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1377 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1378 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1379 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/
1380 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1381 &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
1382 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1383 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1384 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1385 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1386 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1387 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
1388 &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
1389 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1390 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
1391 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1392 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1393 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1394 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1395 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1396 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1397 &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
1398 &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
1399 &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1400 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1401 &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
1402 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1403 &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
1404 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1405 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1406 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1407 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
1408 &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1409 &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
1410 &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
1411 &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
1412 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1413 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1414 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1415 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1416 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1417 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1418 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1419 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1420 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1421 &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
1422 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1423 &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
1424 &162*81,31*0,-211,111,6516*0/
1425 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1426 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1427 &3*111,-211,111,7193*0/
1428
1429C...PYDAT4, with particle names (character strings).
1430 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1431 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1432 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1433 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1434 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1435 &'junction',' ','system','cluster','string','indep.','CMshower',
1436 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1437 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1438 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1439 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1440 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1441 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1442 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1443 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1444 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1445 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1446 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1447 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1448 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1449 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1450 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1451 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1452 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1453 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1454 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1455 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1456 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1457 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1458 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1459 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1460 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1461 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1462 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1463 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1464 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1465 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1466 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1467 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1468 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1469 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1470 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1471 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1472 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1473 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1474 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1475 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1476 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',131*' '/
1477 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1478 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1479 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1480 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1481 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1482 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1483 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1484 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1485 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1486 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1487 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1488 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1489 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1490 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1491 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1492 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1493 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1494 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1495 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1496 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1497 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1498 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1499 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1500 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1501 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1502 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1503 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1504 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1505 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1506 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1507 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1508 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1509 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1510 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1511 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1512 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1513 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1514 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1515 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1516 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1517 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1518 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1519 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1520 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1521 &131*' '/
1522
1523C...PYDATR, with initial values for the random number generator.
1524 DATA MRPY/19780503,0,0,97,33,0/
1525
1526C...Default values for allowed processes and kinematics constraints.
1527 DATA MSEL/1/
1528 DATA MSUB/500*0/
1529 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1530 &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
1531 &6*1,4*0,4*1,16*0/
1532 DATA CKIN/
1533 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1534 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1535 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1536 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1537 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1538 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1539 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1540 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1541 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1542 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1543 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1544 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1545 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1546 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1547 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1548 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1549 8 120*0D0/
1550
1551C...Default values for main switches and parameters. Reset information.
1552 DATA (MSTP(I),I=1,100)/
1553 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1554 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1555 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1556 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1557 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1558 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1559 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1560 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1561 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1562 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1563 DATA (MSTP(I),I=101,200)/
1564 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1565 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1566 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1567 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1568 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1569 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1570 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1571 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1572 8 6, 414, 2007, 11, 19, 0, 0, 0, 0, 0,
1573 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1574 DATA (PARP(I),I=1,100)/
1575 & 0.25D0, 10D0, 8*0D0,
1576 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1577 2 10*0D0,
1578 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1579 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1580 5 10*0D0,
1581 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1582 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1583 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1584 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
1585 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1586 DATA (PARP(I),I=101,200)/
1587 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1588 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1589 2 1.0D0, 0.4D0, 8*0D0,
1590 3 0.01D0, 9*0D0,
1591 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1592 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1593 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1594 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1595 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1596 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1597 8 0.3D0, 0.64D0,
1598 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1599 DATA MSTI/200*0/
1600 DATA PARI/200*0D0/
1601 DATA MINT/400*0/
1602 DATA VINT/400*0D0/
1603
1604C...Constants for the generation of the various processes.
1605 DATA (ISET(I),I=1,100)/
1606 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1607 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1608 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1609 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1610 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1611 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1612 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1613 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1614 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1615 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1616 DATA (ISET(I),I=101,200)/
1617 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1618 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1619 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1620 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1621 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1622 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1623 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1624 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1625 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1626 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1627 DATA (ISET(I),I=201,300)/
1628 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1629 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1630 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1631 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1632 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1633 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1634 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1635 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1636 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1637 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1638 DATA (ISET(I),I=301,500)/
1639 & 2, 39*-2,
1640 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1641 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1642 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1643 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1644 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1645 9 1, 1, 2, 2, 2, 5*-2,
1646 & 5, 5, 18*-2,
1647 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1648 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1649 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1650 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1651 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1652 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1653 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1654 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1655 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1656 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1657 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1658 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1659 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1660 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1661 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1662 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1663 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1664 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1665 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1666 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1667 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1668 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1669 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1670 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1671 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1672 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1673 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1674 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1675 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1676 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1677 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1678 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1679 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1680 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1681 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1682 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1683 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1684 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1685 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1686 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1687 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1688 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1689 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1690 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1691 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1692 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1693 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1694 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1695 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1696 & 1000011, 1000011, 2000011, 2000011, 1000011,
1697 & 2000011, 1000013, 1000013, 2000013, 2000013,
1698 & 1000013, 2000013, 1000015, 1000015, 2000015,
1699 & 2000015, 1000015, 2000015, 1000011, 1000012,
1700 1 1000015, 1000016, 2000015, 1000016, 1000012,
1701 1 1000012, 1000016, 1000016, 0, 0,
1702 1 1000022, 1000022, 1000023, 1000023, 1000025,
1703 1 1000025, 1000035, 1000035, 1000022, 1000023,
1704 2 1000022, 1000025, 1000022, 1000035, 1000023,
1705 2 1000025, 1000023, 1000035, 1000025, 1000035,
1706 2 1000024, 1000024, 1000037, 1000037, 1000024,
1707 2 1000037, 1000022, 1000024, 1000023, 1000024,
1708 3 1000025, 1000024, 1000035, 1000024, 1000022,
1709 3 1000037, 1000023, 1000037, 1000025, 1000037,
1710 3 1000035, 1000037, 1000021, 1000022, 1000021,
1711 3 1000023, 1000021, 1000025, 1000021, 1000035/
1712 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1713 4 1000021, 1000024, 1000021, 1000037, 1000021,
1714 4 1000021, 1000021, 1000021, 0, 0,
1715 4 1000002, 1000022, 2000002, 1000022, 1000002,
1716 4 1000023, 2000002, 1000023, 1000002, 1000025,
1717 5 2000002, 1000025, 1000002, 1000035, 2000002,
1718 5 1000035, 1000001, 1000024, 2000005, 1000024,
1719 5 1000001, 1000037, 2000005, 1000037, 1000002,
1720 5 1000021, 2000002, 1000021, 0, 0,
1721 6 1000006, 1000006, 2000006, 2000006, 1000006,
1722 6 2000006, 1000006, 1000006, 2000006, 2000006,
1723 6 0, 0, 0, 0, 0,
1724 6 0, 0, 0, 0, 0,
1725 7 1000002, 1000002, 2000002, 2000002, 1000002,
1726 7 2000002, 1000002, 1000002, 2000002, 2000002,
1727 7 1000002, 2000002, 1000002, 1000002, 2000002,
1728 7 2000002, 1000002, 1000002, 2000002, 2000002/
1729 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1730 8 1000005, 1000002, 2000005, 2000002, 1000005,
1731 8 2000002, 1000005, 1000002, 2000005, 2000002,
1732 8 1000005, 2000002, 1000005, 1000005, 2000005,
1733 8 2000005, 1000005, 1000005, 2000005, 2000005,
1734 9 1000005, 1000005, 2000005, 2000005, 1000005,
1735 9 2000005, 1000005, 1000021, 2000005, 1000021,
1736 9 1000005, 2000005, 37, 25, 37,
1737 9 35, 36, 25, 36, 35,
1738 & 37, 37, 78*0,
1739 4 9900041, 0, 9900042, 0, 9900041,
1740 4 11, 9900042, 11, 9900041, 13,
1741 4 9900042, 13, 9900041, 15, 9900042,
1742 4 15, 9900041, 9900041, 9900042, 9900042/
1743 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1744 5 9900041, 0, 9900042, 0, 9900023,
1745 5 0, 9900024, 0, 0, 0,
1746 5 0, 0, 0, 0, 0,
1747 5 0, 0, 0, 0, 0,
1748 6 24, 24, 24, 3000211, 3000211,
1749 6 3000211, 22, 3000111, 22, 3000221,
1750 6 23, 3000111, 23, 3000221, 24,
1751 6 3000211, 0, 0, 24, 23,
1752 7 24, 3000111, 3000211, 23, 3000211,
1753 7 3000111, 22, 3000211, 23, 3000211,
1754 7 24, 3000111, 24, 3000221, 22,
1755 7 24, 22, 23, 23, 23,
1756 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1757 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1758 9 5000039, 0, 5000039, 0, 21,
1759 9 5000039, 0, 5000039, 21, 5000039,
1760 9 10*0/
1761 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1762 & 37, 6, 37, 6, 36*0,
1763 2 443, 21, 9900443, 21, 9900441,
1764 2 21, 9910441, 21, 0, 9900443,
1765 2 0, 9900441, 0, 9910441, 21,
1766 2 9900443, 21, 9900441, 21, 9910441,
1767 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1768 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1769 6 553, 21, 9900553, 21, 9900551,
1770 6 21, 9910551, 21, 0, 9900553,
1771 6 0, 9900551, 0, 9910551, 21,
1772 6 9900553, 21, 9900551, 21, 9910551,
1773 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1774 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1775 DATA COEF/10000*0D0/
1776 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1777 &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
1778 &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
1779 &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
1780 &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
1781 &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
1782 &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
1783 &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
1784 &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
1785 &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1786 &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
1787
1788C...Treatment of resonances.
1789 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1790 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,131*0/
1791
1792C...Character constants: name of processes.
1793 DATA PROC(0)/ 'All included subprocesses '/
1794 DATA (PROC(I),I=1,20)/
1795 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1796 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1797 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1798 &' ', 'W+ + W- -> h0 ',
1799 &' ', 'f + f'' -> f + f'' (QFD) ',
1800 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1801 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1802 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1803 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1804 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1805 DATA (PROC(I),I=21,40)/
1806 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1807 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1808 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1809 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1810 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1811 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1812 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1813 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1814 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1815 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1816 DATA (PROC(I),I=41,60)/
1817 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1818 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1819 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1820 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1821 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1822 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1823 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1824 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1825 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1826 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1827 DATA (PROC(I),I=61,80)/
1828 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1829 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1830 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1831 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1832 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1833 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1834 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1835 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1836 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1837 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1838 DATA (PROC(I),I=81,100)/
1839 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1840 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1841 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1842 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1843 8'g + g -> chi_2c + g ', ' ',
1844 9'Elastic scattering ', 'Single diffractive (XB) ',
1845 9'Single diffractive (AX) ', 'Double diffractive ',
1846 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1847 9' ', ' ',
1848 9'q + gamma* -> q ', ' '/
1849 DATA (PROC(I),I=101,120)/
1850 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1851 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1852 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1853 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1854 &' ', 'f + fbar -> gamma + h0 ',
1855 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1856 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1857 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1858 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1859 1' ', ' '/
1860 DATA (PROC(I),I=121,140)/
1861 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1862 2'f + f'' -> f + f'' + h0 ',
1863 2'f + f'' -> f" + f"'' + h0 ',
1864 2' ', ' ',
1865 2' ', ' ',
1866 2' ', ' ',
1867 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1868 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1869 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1870 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1871 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1872 DATA (PROC(I),I=141,160)/
1873 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1874 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1875 4'q + l -> LQ ', 'e + gamma -> e* ',
1876 4'd + g -> d* ', 'u + g -> u* ',
1877 4'g + g -> eta_tc ', ' ',
1878 5'f + fbar -> H0 ', 'g + g -> H0 ',
1879 5'gamma + gamma -> H0 ', ' ',
1880 5' ', 'f + fbar -> A0 ',
1881 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1882 5' ', ' '/
1883 DATA (PROC(I),I=161,180)/
1884 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
1885 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
1886 6'f + fbar -> f'' + fbar'' (g/Z)',
1887 6'f +fbar'' -> f" + fbar"'' (W) ',
1888 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
1889 6'q + qbar -> e + e* ', ' ',
1890 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
1891 7'f + f'' -> f + f'' + H0 ',
1892 7'f + f'' -> f" + f"'' + H0 ',
1893 7' ', 'f + fbar -> Z0 + A0 ',
1894 7'f + fbar'' -> W+/- + A0 ',
1895 7'f + f'' -> f + f'' + A0 ',
1896 7'f + f'' -> f" + f"'' + A0 ',
1897 7' '/
1898 DATA (PROC(I),I=181,200)/
1899 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
1900 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
1901 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
1902 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
1903 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
1904 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
1905 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
1906 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
1907 9' ', ' ',
1908 9' ', ' '/
1909 DATA (PROC(I),I=201,220)/
1910 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
1911 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
1912 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
1913 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
1914 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
1915 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
1916 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
1917 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
1918 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
1919 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
1920 DATA (PROC(I),I=221,240)/
1921 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
1922 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
1923 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
1924 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
1925 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
1926 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
1927 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
1928 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
1929 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
1930 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
1931 DATA (PROC(I),I=241,260)/
1932 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
1933 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
1934 4' ', 'qj + g -> ~qj_L + ~chi1 ',
1935 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
1936 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
1937 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
1938 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
1939 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
1940 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
1941 5'qj + g -> ~qj_R + ~g ', ' '/
1942 DATA (PROC(I),I=261,300)/
1943 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
1944 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
1945 6'g + g -> ~t_2 + ~t_2bar ', ' ',
1946 6' ', ' ',
1947 6' ', ' ',
1948 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
1949 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
1950 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
1951 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
1952 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
1953 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
1954 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
1955 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
1956 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
1957 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
1958 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
1959 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
1960 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
1961 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
1962 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
1963 DATA (PROC(I),I=301,340)/
1964 &'f + fbar -> H+ + H- ', 39*' '/
1965 DATA (PROC(I),I=341,380)/
1966 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
1967 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
1968 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
1969 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
1970 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
1971 5'f + f -> f'' + f'' + H_L++/-- ',
1972 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
1973 5'f + fbar'' -> W_R+/- ',5*' ',
1974 6' ', 'f + fbar -> W_L+ W_L- ',
1975 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
1976 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
1977 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
1978 6'f + fbar -> W+/- pi_T-/+ ', ' ',
1979 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
1980 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
1981 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
1982 7'f + fbar'' -> W+/- pi_T0 ',
1983 7'f + fbar'' -> W+/- pi_T0'' ',
1984 7'f + fbar'' -> gamma W+/- (ETC)','f + fbar -> gamma Z0 (ETC)',
1985 7'f + fbar -> Z0 Z0 (ETC)'/
1986 DATA (PROC(I),I=381,420)/
1987 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
1988 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
1989 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
1990 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
1991 8' ', ' ',
1992 9'f + fbar -> G* ', 'g + g -> G* ',
1993 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
1994 9'g + g -> g + G* ', ' ',
1995 9 4*' ',
1996 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
1997 & 18*' '/
1998 DATA (PROC(I),I=421,460)/
1999 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2000 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2001 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2002 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2003 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2004 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2005 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2006 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2007 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2008 3'q + q~ -> g + cc~[3P2(1)] ',
2009 3 21 *' '/
2010 DATA (PROC(I),I=461,500)/
2011 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2012 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2013 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2014 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2015 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2016 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2017 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2018 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2019 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2020 7'q + q~ -> g + bb~[3P2(1)] ',
2021 7 21 *' '/
2022
2023C...Cross sections and slope offsets.
2024 DATA SIGT/294*0D0/
2025
2026C...Supersymmetry switches and parameters.
2027 DATA IMSS/0,
2028 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2029 1 89*0/
2030 DATA RMSS/0D0,
2031 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2032 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2033 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2034 3 10*0D0,
2035 4 0D0,1D0,8*0D0,
2036 5 49*0D0/
2037C...Initial values for R-violating SUSY couplings.
2038C...Should not be changed here. See PYMSIN.
2039 DATA RVLAM/27*0D0/
2040 DATA RVLAMP/27*0D0/
2041 DATA RVLAMB/27*0D0/
2042
2043C...Technicolor switches and parameters
2044 DATA ITCM/0,
2045 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2046 1 89*0/
2047 DATA RTCM/0D0,
2048 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2049 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2050 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2051 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2052 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2053 4 200D0, 48*0D0/
2054
2055C...Data for histogramming routines.
2056 DATA IHIST/1000,20000,55,1/
2057 DATA INDX/1000*0/
2058
2059C...Data for SUSY Les Houches Accord.
2060 DATA CPRO/'PYTHIA ','PYTHIA '/
2061 DATA CVER/'6.4 ','6.4 '/
2062 DATA MODSEL/200*0/
2063 DATA PARMIN/100*0D0/
2064 DATA RMSOFT/101*0D0/
2065 DATA AU/9*0D0/
2066 DATA AD/9*0D0/
2067 DATA AE/9*0D0/
2068
2069 END
2070
2071C*********************************************************************
2072
2073C...PYCKBD
2074C...Check that BLOCK DATA PYDATA has been loaded.
2075C...Should not be required, except that some compilers/linkers
2076C...are pretty buggy in this respect.
2077
2078 SUBROUTINE PYCKBD
2079
2080C...Double precision and integer declarations.
2081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2082 IMPLICIT INTEGER(I-N)
2083 INTEGER PYK,PYCHGE,PYCOMP
2084C...Commonblocks.
2085 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2088 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2089 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2090 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2091 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2092
2093C...Check a few variables to see they have been sensibly initialized.
2094 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2095 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2096 &MSTP(1).GT.5) THEN
2097C...If not, abort the run right away.
2098 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2099 WRITE(*,*) 'The program execution is stopped now!'
2100 CALL PYSTOP(8)
2101 ENDIF
2102
2103 RETURN
2104 END
2105
2106C*********************************************************************
2107
2108C...PYTEST
2109C...A simple program (disguised as subroutine) to run at installation
2110C...as a check that the program works as intended.
2111
2112 SUBROUTINE PYTEST(MTEST)
2113
2114C...Double precision and integer declarations.
2115 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2116 IMPLICIT INTEGER(I-N)
2117 INTEGER PYK,PYCHGE,PYCOMP
2118C...Commonblocks.
2119 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2120 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2121 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2122 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2123 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2124 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2125 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2126C...Local arrays.
2127 DIMENSION PSUM(5),PINI(6),PFIN(6)
2128
2129C...Save defaults for values that are changed.
2130 MSTJ1=MSTJ(1)
2131 MSTJ3=MSTJ(3)
2132 MSTJ11=MSTJ(11)
2133 MSTJ42=MSTJ(42)
2134 MSTJ43=MSTJ(43)
2135 MSTJ44=MSTJ(44)
2136 PARJ17=PARJ(17)
2137 PARJ22=PARJ(22)
2138 PARJ43=PARJ(43)
2139 PARJ54=PARJ(54)
2140 MST101=MSTJ(101)
2141 MST104=MSTJ(104)
2142 MST105=MSTJ(105)
2143 MST107=MSTJ(107)
2144 MST116=MSTJ(116)
2145
2146C...First part: loop over simple events to be generated.
2147 IF(MTEST.GE.1) CALL PYTABU(20)
2148 NERR=0
2149 DO 180 IEV=1,500
2150
2151C...Reset parameter values. Switch on some nonstandard features.
2152 MSTJ(1)=1
2153 MSTJ(3)=0
2154 MSTJ(11)=1
2155 MSTJ(42)=2
2156 MSTJ(43)=4
2157 MSTJ(44)=2
2158 PARJ(17)=0.1D0
2159 PARJ(22)=1.5D0
2160 PARJ(43)=1D0
2161 PARJ(54)=-0.05D0
2162 MSTJ(101)=5
2163 MSTJ(104)=5
2164 MSTJ(105)=0
2165 MSTJ(107)=1
2166 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2167
2168C...Ten events each for some single jets configurations.
2169 IF(IEV.LE.50) THEN
2170 ITY=(IEV+9)/10
2171 MSTJ(3)=-1
2172 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2173 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2174 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2175 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2176 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2177 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2178
2179C...Ten events each for some simple jet systems; string fragmentation.
2180 ELSEIF(IEV.LE.130) THEN
2181 ITY=(IEV-41)/10
2182 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2183 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2184 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2185 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2186 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2187 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2188 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2189 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2190 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2191
2192C...Seventy events with independent fragmentation and momentum cons.
2193 ELSEIF(IEV.LE.200) THEN
2194 ITY=1+(IEV-131)/16
2195 MSTJ(2)=1+MOD(IEV-131,4)
2196 MSTJ(3)=1+MOD((IEV-131)/4,4)
2197 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2198 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2199 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2200 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2201 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2202 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2203
2204C...A hundred events with random jets (check invariant mass).
2205 ELSEIF(IEV.LE.300) THEN
2206 100 DO 110 J=1,5
2207 PSUM(J)=0D0
2208 110 CONTINUE
2209 NJET=2D0+6D0*PYR(0)
2210 DO 130 I=1,NJET
2211 KFL=21
2212 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2213 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2214 EJET=5D0+20D0*PYR(0)
2215 THETA=ACOS(2D0*PYR(0)-1D0)
2216 PHI=6.2832D0*PYR(0)
2217 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2218 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2219 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2220 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2221 DO 120 J=1,4
2222 PSUM(J)=PSUM(J)+P(I,J)
2223 120 CONTINUE
2224 130 CONTINUE
2225 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2226 & (PSUM(5)+PARJ(32))**2) GOTO 100
2227
2228C...Fifty e+e- continuum events with matrix elements.
2229 ELSEIF(IEV.LE.350) THEN
2230 MSTJ(101)=2
2231 CALL PYEEVT(0,40D0)
2232
2233C...Fifty e+e- continuum event with varying shower options.
2234 ELSEIF(IEV.LE.400) THEN
2235 MSTJ(42)=1+MOD(IEV,2)
2236 MSTJ(43)=1+MOD(IEV/2,4)
2237 MSTJ(44)=MOD(IEV/8,3)
2238 CALL PYEEVT(0,90D0)
2239
2240C...Fifty e+e- continuum events with coherent shower.
2241 ELSEIF(IEV.LE.450) THEN
2242 CALL PYEEVT(0,500D0)
2243
2244C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2245 ELSE
2246 CALL PYONIA(5,9.46D0)
2247 ENDIF
2248
2249C...Generate event. Find total momentum, energy and charge.
2250 DO 140 J=1,4
2251 PINI(J)=PYP(0,J)
2252 140 CONTINUE
2253 PINI(6)=PYP(0,6)
2254 CALL PYEXEC
2255 DO 150 J=1,4
2256 PFIN(J)=PYP(0,J)
2257 150 CONTINUE
2258 PFIN(6)=PYP(0,6)
2259
2260C...Check conservation of energy, momentum and charge;
2261C...usually exact, but only approximate for single jets.
2262 MERR=0
2263 IF(IEV.LE.50) THEN
2264 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2265 & MERR=MERR+1
2266 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2267 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2268 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2269 ELSE
2270 DO 160 J=1,4
2271 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2272 160 CONTINUE
2273 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2274 ENDIF
2275 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2276 & (PFIN(J),J=1,4),PFIN(6)
2277
2278C...Check that all KF codes are known ones, and that partons/particles
2279C...satisfy energy-momentum-mass relation. Store particle statistics.
2280 DO 170 I=1,N
2281 IF(K(I,1).GT.20) GOTO 170
2282 IF(PYCOMP(K(I,2)).EQ.0) THEN
2283 WRITE(MSTU(11),5100) I
2284 MERR=MERR+1
2285 ENDIF
2286 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2287 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2288 & THEN
2289 WRITE(MSTU(11),5200) I
2290 MERR=MERR+1
2291 ENDIF
2292 170 CONTINUE
2293 IF(MTEST.GE.1) CALL PYTABU(21)
2294
2295C...List all erroneous events and some normal ones.
2296 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2297 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2298 CALL PYLIST(2)
2299 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2300 CALL PYLIST(1)
2301 ENDIF
2302
2303C...Stop execution if too many errors.
2304 IF(MERR.NE.0) NERR=NERR+1
2305 IF(NERR.GE.10) THEN
2306 WRITE(MSTU(11),6300)
2307 CALL PYLIST(1)
2308 CALL PYSTOP(9)
2309 ENDIF
2310 180 CONTINUE
2311
2312C...Summarize result of run.
2313 IF(MTEST.GE.1) CALL PYTABU(22)
2314
2315C...Reset commonblock variables changed during run.
2316 MSTJ(1)=MSTJ1
2317 MSTJ(3)=MSTJ3
2318 MSTJ(11)=MSTJ11
2319 MSTJ(42)=MSTJ42
2320 MSTJ(43)=MSTJ43
2321 MSTJ(44)=MSTJ44
2322 PARJ(17)=PARJ17
2323 PARJ(22)=PARJ22
2324 PARJ(43)=PARJ43
2325 PARJ(54)=PARJ54
2326 MSTJ(101)=MST101
2327 MSTJ(104)=MST104
2328 MSTJ(105)=MST105
2329 MSTJ(107)=MST107
2330 MSTJ(116)=MST116
2331
2332C...Second part: complete events of various kinds.
2333C...Common initial values. Loop over initiating conditions.
2334 MSTP(122)=MAX(0,MIN(2,MTEST))
2335 MDCY(PYCOMP(111),1)=0
2336 DO 230 IPROC=1,8
2337
2338C...Reset process type, kinematics cuts, and the flags used.
2339 MSEL=0
2340 DO 190 ISUB=1,500
2341 MSUB(ISUB)=0
2342 190 CONTINUE
2343 CKIN(1)=2D0
2344 CKIN(3)=0D0
2345 MSTP(2)=1
2346 MSTP(11)=0
2347 MSTP(33)=0
2348 MSTP(81)=1
2349 MSTP(82)=1
2350 MSTP(111)=1
2351 MSTP(131)=0
2352 MSTP(133)=0
2353 PARP(131)=0.01D0
2354
2355C...Prompt photon production at fixed target.
2356 IF(IPROC.EQ.1) THEN
2357 PZSUM=300D0
2358 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2359 PQSUM=2D0
2360 MSEL=10
2361 CKIN(3)=5D0
2362 CALL PYINIT('FIXT','pi+','p',PZSUM)
2363
2364C...QCD processes at ISR energies.
2365 ELSEIF(IPROC.EQ.2) THEN
2366 PESUM=63D0
2367 PZSUM=0D0
2368 PQSUM=2D0
2369 MSEL=1
2370 CKIN(3)=5D0
2371 CALL PYINIT('CMS','p','p',PESUM)
2372
2373C...W production + multiple interactions at CERN Collider.
2374 ELSEIF(IPROC.EQ.3) THEN
2375 PESUM=630D0
2376 PZSUM=0D0
2377 PQSUM=0D0
2378 MSEL=12
2379 CKIN(1)=20D0
2380 MSTP(82)=4
2381 MSTP(2)=2
2382 MSTP(33)=3
2383 CALL PYINIT('CMS','p','pbar',PESUM)
2384
2385C...W/Z gauge boson pairs + pileup events at the Tevatron.
2386 ELSEIF(IPROC.EQ.4) THEN
2387 PESUM=1800D0
2388 PZSUM=0D0
2389 PQSUM=0D0
2390 MSUB(22)=1
2391 MSUB(23)=1
2392 MSUB(25)=1
2393 CKIN(1)=200D0
2394 MSTP(111)=0
2395 MSTP(131)=1
2396 MSTP(133)=2
2397 PARP(131)=0.04D0
2398 CALL PYINIT('CMS','p','pbar',PESUM)
2399
2400C...Higgs production at LHC.
2401 ELSEIF(IPROC.EQ.5) THEN
2402 PESUM=15400D0
2403 PZSUM=0D0
2404 PQSUM=2D0
2405 MSUB(3)=1
2406 MSUB(102)=1
2407 MSUB(123)=1
2408 MSUB(124)=1
2409 PMAS(25,1)=300D0
2410 CKIN(1)=200D0
2411 MSTP(81)=0
2412 MSTP(111)=0
2413 CALL PYINIT('CMS','p','p',PESUM)
2414
2415C...Z' production at SSC.
2416 ELSEIF(IPROC.EQ.6) THEN
2417 PESUM=40000D0
2418 PZSUM=0D0
2419 PQSUM=2D0
2420 MSEL=21
2421 PMAS(32,1)=600D0
2422 CKIN(1)=400D0
2423 MSTP(81)=0
2424 MSTP(111)=0
2425 CALL PYINIT('CMS','p','p',PESUM)
2426
2427C...W pair production at 1 TeV e+e- collider.
2428 ELSEIF(IPROC.EQ.7) THEN
2429 PESUM=1000D0
2430 PZSUM=0D0
2431 PQSUM=0D0
2432 MSUB(25)=1
2433 MSUB(69)=1
2434 MSTP(11)=1
2435 CALL PYINIT('CMS','e+','e-',PESUM)
2436
2437C...Deep inelastic scattering at a LEP+LHC ep collider.
2438 ELSEIF(IPROC.EQ.8) THEN
2439 P(1,1)=0D0
2440 P(1,2)=0D0
2441 P(1,3)=8000D0
2442 P(2,1)=0D0
2443 P(2,2)=0D0
2444 P(2,3)=-80D0
2445 PESUM=8080D0
2446 PZSUM=7920D0
2447 PQSUM=0D0
2448 MSUB(10)=1
2449 CKIN(3)=50D0
2450 MSTP(111)=0
2451 CALL PYINIT('3MOM','p','e-',PESUM)
2452 ENDIF
2453
2454C...Generate 20 events of each required type.
2455 DO 220 IEV=1,20
2456 CALL PYEVNT
2457 PESUMM=PESUM
2458 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2459
2460C...Check conservation of energy/momentum/flavour.
2461 PINI(1)=0D0
2462 PINI(2)=0D0
2463 PINI(3)=PZSUM
2464 PINI(4)=PESUMM
2465 PINI(6)=PQSUM
2466 DO 200 J=1,4
2467 PFIN(J)=PYP(0,J)
2468 200 CONTINUE
2469 PFIN(6)=PYP(0,6)
2470 MERR=0
2471 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2472 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2473 DEVQ=ABS(PFIN(6)-PINI(6))
2474 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2475 & DEVQ.GT.0.1D0) MERR=1
2476 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2477 & (PFIN(J),J=1,4),PFIN(6)
2478
2479C...Check that all KF codes are known ones, and that partons/particles
2480C...satisfy energy-momentum-mass relation.
2481 DO 210 I=1,N
2482 IF(K(I,1).GT.20) GOTO 210
2483 IF(PYCOMP(K(I,2)).EQ.0) THEN
2484 WRITE(MSTU(11),5100) I
2485 MERR=MERR+1
2486 ENDIF
2487 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2488 & SIGN(1D0,P(I,5))
2489 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2490 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2491 WRITE(MSTU(11),5200) I
2492 MERR=MERR+1
2493 ENDIF
2494 210 CONTINUE
2495
2496C...Listing of erroneous events, and first event of each type.
2497 IF(MERR.GE.1) NERR=NERR+1
2498 IF(NERR.GE.10) THEN
2499 WRITE(MSTU(11),6300)
2500 CALL PYLIST(1)
2501 CALL PYSTOP(9)
2502 ENDIF
2503 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2504 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2505 CALL PYLIST(1)
2506 ENDIF
2507 220 CONTINUE
2508
2509C...List statistics for each process type.
2510 IF(MTEST.GE.1) CALL PYSTAT(1)
2511 230 CONTINUE
2512
2513C...Summarize result of run.
2514 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2515 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2516
2517C...Format statements for output.
2518 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2519 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2520 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2521 &4(1X,F12.5),1X,F8.2)
2522 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2523 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2524 &'kinematics')
2525 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2526 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2527 6400 FORMAT(5X,'Faulty event follows:')
2528 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2529 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2530 &5X,'This should not have happened!')
2531
2532 RETURN
2533 END
2534
2535C*********************************************************************
2536
2537C...PYHEPC
2538C...Converts PYTHIA event record contents to or from
2539C...the standard event record commonblock.
2540
2541 SUBROUTINE PYHEPC(MCONV)
2542
2543C...Double precision and integer declarations.
2544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2545 IMPLICIT INTEGER(I-N)
2546 INTEGER PYK,PYCHGE,PYCOMP
2547C...Commonblocks.
2548 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2549 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2550 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2551 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2552C...HEPEVT commonblock.
2553 PARAMETER (NMXHEP=4000)
2554 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2555 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2556 DOUBLE PRECISION PHEP,VHEP
2557 SAVE /HEPEVT/
2558
2559C...Store HEPEVT commonblock size (for interfacing issues).
2560 MSTU(8)=NMXHEP
2561
2562C...Conversion from PYTHIA to standard, the easy part.
2563 IF(MCONV.EQ.1) THEN
2564 NEVHEP=0
2565 IF(N.GT.NMXHEP) CALL PYERRM(8,
2566 & '(PYHEPC:) no more space in /HEPEVT/')
2567 NHEP=MIN(N,NMXHEP)
2568 DO 150 I=1,NHEP
2569 ISTHEP(I)=0
2570 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2571 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2572 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2573 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2574 IDHEP(I)=K(I,2)
2575 JMOHEP(1,I)=K(I,3)
2576 JMOHEP(2,I)=0
2577 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2578 JDAHEP(1,I)=K(I,4)
2579 JDAHEP(2,I)=K(I,5)
2580 ELSE
2581 JDAHEP(1,I)=0
2582 JDAHEP(2,I)=0
2583 ENDIF
2584 DO 100 J=1,5
2585 PHEP(J,I)=P(I,J)
2586 100 CONTINUE
2587 DO 110 J=1,4
2588 VHEP(J,I)=V(I,J)
2589 110 CONTINUE
2590
2591C...Check if new event (from pileup).
2592 IF(I.EQ.1) THEN
2593 INEW=1
2594 ELSE
2595 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2596 ENDIF
2597
2598C...Fill in missing mother information.
2599 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2600 IMO1=I-2
2601 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2602 & THEN
2603 IMO1=IMO1-1
2604 GOTO 120
2605 ENDIF
2606 JMOHEP(1,I)=IMO1
2607 JMOHEP(2,I)=IMO1+1
2608 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2609 I1=K(I,3)-1
2610 130 I1=I1+1
2611 IF(I1.GE.I) CALL PYERRM(8,
2612 & '(PYHEPC:) translation of inconsistent event history')
2613 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2614 KC=PYCOMP(K(I1,2))
2615 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2616 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2617 JMOHEP(2,I)=I1
2618 ELSEIF(K(I,2).EQ.94) THEN
2619 NJET=2
2620 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2621 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2622 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2623 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2624 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2625 ENDIF
2626
2627C...Fill in missing daughter information.
2628 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2629 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2630 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2631 JDAHEP(1,I2)=I
2632 140 CONTINUE
2633 ENDIF
2634 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2635 I1=JMOHEP(1,I)
2636 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2637 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2638 IF(JDAHEP(1,I1).EQ.0) THEN
2639 JDAHEP(1,I1)=I
2640 ELSE
2641 JDAHEP(2,I1)=I
2642 ENDIF
2643 150 CONTINUE
2644 DO 160 I=1,NHEP
2645 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2646 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2647 160 CONTINUE
2648
2649C...Conversion from standard to PYTHIA, the easy part.
2650 ELSE
2651 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2652 & '(PYHEPC:) no more space in /PYJETS/')
2653 N=MIN(NHEP,MSTU(4))
2654 NKQ=0
2655 KQSUM=0
2656 DO 190 I=1,N
2657 K(I,1)=0
2658 IF(ISTHEP(I).EQ.1) K(I,1)=1
2659 IF(ISTHEP(I).EQ.2) K(I,1)=11
2660 IF(ISTHEP(I).EQ.3) K(I,1)=21
2661 K(I,2)=IDHEP(I)
2662 K(I,3)=JMOHEP(1,I)
2663 K(I,4)=JDAHEP(1,I)
2664 K(I,5)=JDAHEP(2,I)
2665 DO 170 J=1,5
2666 P(I,J)=PHEP(J,I)
2667 170 CONTINUE
2668 DO 180 J=1,4
2669 V(I,J)=VHEP(J,I)
2670 180 CONTINUE
2671 V(I,5)=0D0
2672 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2673 I1=JDAHEP(1,I)
2674 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2675 & PHEP(5,I)/PHEP(4,I)
2676 ENDIF
2677
2678C...Fill in missing information on colour connection in jet systems.
2679 IF(ISTHEP(I).EQ.1) THEN
2680 KC=PYCOMP(K(I,2))
2681 KQ=0
2682 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2683 IF(KQ.NE.0) NKQ=NKQ+1
2684 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2685 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2686 K(I,1)=2
2687 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2688 IF(K(I+1,2).EQ.21) K(I,1)=2
2689 ENDIF
2690 ENDIF
2691 190 CONTINUE
2692 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2693 & '(PYHEPC:) input parton configuration not colour singlet')
2694 ENDIF
2695
2696 END
2697
2698C*********************************************************************
2699
2700C...PYINIT
2701C...Initializes the generation procedure; finds maxima of the
2702C...differential cross-sections to be used for weighting.
2703
2704 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2705
2706C...Double precision and integer declarations.
2707 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2708 IMPLICIT INTEGER(I-N)
2709 INTEGER PYK,PYCHGE,PYCOMP
2710C...Commonblocks.
2711 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2712 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2713 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2714 COMMON/PYDAT4/CHAF(500,2)
2715 CHARACTER CHAF*16
2716 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2717 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2718 COMMON/PYINT1/MINT(400),VINT(400)
2719 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2720 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2721 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2722 &/PYINT1/,/PYINT2/,/PYINT5/
2723C...Local arrays and character variables.
2724 DIMENSION ALAMIN(20),NFIN(20)
2725 CHARACTER*(*) FRAME,BEAM,TARGET
2726 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2727
2728C...Interface to PDFLIB.
2729 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
11e297eb 2730 COMMON/LW50512/QCDL4,QCDL5
2731 SAVE /W50511/
2732 SAVE /LW50512/
a59803b8 2733 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2734 CHARACTER*20 PARM(20)
2735 DATA VALUE/20*0D0/,PARM/20*' '/
2736
2737C...Data:Lambda and n_f values for parton distributions..
2738 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2739 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2740 &NFIN/20*4/
2741 DATA CHLH/'lepton','hadron'/
2742
2743C...Check that BLOCK DATA PYDATA has been loaded.
2744 CALL PYCKBD
2745
2746C...Reset MINT and VINT arrays. Write headers.
2747 MSTI(53)=0
2748 DO 100 J=1,400
2749 MINT(J)=0
2750 VINT(J)=0D0
2751 100 CONTINUE
2752 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2753 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2754
2755C...Reset error counters.
2756 MSTU(23)=0
2757 MSTU(27)=0
2758 MSTU(30)=0
2759
2760C...Reset processes that should not be on.
2761 MSUB(96)=0
2762 MSUB(97)=0
2763
2764C...Select global FSR/ISR/UE parameter set = 'tune'
2765C...See routine PYTUNE for details
2766 IF (MSTP(5).NE.0) THEN
2767 MSTP5=MSTP(5)
2768 CALL PYTUNE(MSTP5)
2769 ENDIF
2770
2771C...Call user process initialization routine.
2772 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2773 MSEL=0
2774 CALL UPINIT
2775 MSEL=0
2776 ENDIF
2777
2778C...Maximum 4 generations; set maximum number of allowed flavours.
2779 MSTP(1)=MIN(4,MSTP(1))
2780 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2781 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2782
2783C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2784 DO 120 I=-20,20
2785 VINT(180+I)=0D0
2786 IA=IABS(I)
2787 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2788 DO 110 J=1,MSTP(1)
2789 IB=2*J-1+MOD(IA,2)
2790 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2791 IPM=(5-ISIGN(1,I))/2
2792 IDC=J+MDCY(IA,2)+2
2793 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2794 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2795 110 CONTINUE
2796 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2797 VINT(180+I)=1D0
2798 ENDIF
2799 120 CONTINUE
2800
2801C...Initialize parton distributions: PDFLIB.
2802 IF(MSTP(52).EQ.2) THEN
2803 PARM(1)='NPTYPE'
2804 VALUE(1)=1
2805 PARM(2)='NGROUP'
2806 VALUE(2)=MSTP(51)/1000
2807 PARM(3)='NSET'
2808 VALUE(3)=MOD(MSTP(51),1000)
2809 PARM(4)='TMAS'
2810 VALUE(4)=PMAS(6,1)
2811 CALL PDFSET_ALICE(PARM,VALUE)
2812 MINT(93)=1000000+MSTP(51)
2813 ENDIF
2814
2815C...Choose Lambda value to use in alpha-strong.
2816 MSTU(111)=MSTP(2)
2817 IF(MSTP(3).GE.2) THEN
2818 ALAM=0.2D0
2819 NF=4
2820 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2821 ALAM=ALAMIN(MSTP(51))
2822 NF=NFIN(MSTP(51))
2823 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2824 ALAM=QCDL5
2825 NF=5
2826 ELSEIF(MSTP(52).EQ.2) THEN
2827 ALAM=QCDL4
2828 NF=4
2829 ENDIF
2830 PARP(1)=ALAM
2831 PARP(61)=ALAM
2832 PARP(72)=ALAM
2833 PARU(112)=ALAM
2834 MSTU(112)=NF
2835 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2836 ENDIF
2837
2838C...Initialize the SUSY generation: couplings, masses,
2839C...decay modes, branching ratios, and so on.
2840 CALL PYMSIN
2841C...Initialize widths and partial widths for resonances.
2842 CALL PYINRE
2843C...Set Z0 mass and width for e+e- routines.
2844 PARJ(123)=PMAS(23,1)
2845 PARJ(124)=PMAS(23,2)
2846
2847C...Identify beam and target particles and frame of process.
2848 CHFRAM=FRAME//' '
2849 CHBEAM=BEAM//' '
2850 CHTARG=TARGET//' '
2851 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2852 IF(MINT(65).EQ.1) GOTO 170
2853
2854C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2855C...For e-gamma allow 2 alternatives.
2856 MINT(121)=1
2857 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2858 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2859 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2860 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2861 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2862 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2863 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2864 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2865 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2866 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2867 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2868 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2869 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2870 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2871 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2872 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2873 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2874 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2875 ENDIF
2876 MINT(123)=MSTP(14)
2877 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2878 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2879 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2880 IF(MSTP(14).EQ.11) MINT(123)=0
2881 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2882 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2883 IF(MSTP(14).EQ.15) MINT(123)=2
2884 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2885 IF(MSTP(14).EQ.19) MINT(123)=3
2886 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2887 IF(MSTP(14).EQ.21) MINT(123)=0
2888 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2889 IF(MSTP(14).EQ.24) MINT(123)=1
2890 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2891 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2892 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2893 ENDIF
2894
2895C...Set up kinematics of process.
2896 CALL PYINKI(0)
2897
2898C...Set up kinematics for photons inside leptons.
2899 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2900
2901C...Precalculate flavour selection weights.
2902 CALL PYKFIN
2903
2904C...Loop over gamma-p or gamma-gamma alternatives.
2905 CKIN3=CKIN(3)
2906 MSAV48=0
2907 DO 160 IGA=1,MINT(121)
2908 CKIN(3)=CKIN3
2909 MINT(122)=IGA
2910
2911C...Select partonic subprocesses to be included in the simulation.
2912 CALL PYINPR
2913 MINT(101)=1
2914 MINT(102)=1
2915 MINT(103)=MINT(11)
2916 MINT(104)=MINT(12)
2917
2918C...Count number of subprocesses on.
2919 MINT(48)=0
2920 DO 130 ISUB=1,500
2921 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2922 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2923 MSUB(ISUB)=0
2924 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2925 & MSUB(ISUB).EQ.1) THEN
2926 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2927 CALL PYSTOP(1)
2928 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2929 WRITE(MSTU(11),5300) ISUB
2930 CALL PYSTOP(1)
2931 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2932 WRITE(MSTU(11),5400) ISUB
2933 CALL PYSTOP(1)
2934 ELSEIF(MSUB(ISUB).EQ.1) THEN
2935 MINT(48)=MINT(48)+1
2936 ENDIF
2937 130 CONTINUE
2938
2939C...Stop or raise warning flag if no subprocesses on.
2940 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2941 IF(MSTP(127).NE.1) THEN
2942 WRITE(MSTU(11),5500)
2943 CALL PYSTOP(1)
2944 ELSE
2945 WRITE(MSTU(11),5700)
2946 MSTI(53)=1
2947 ENDIF
2948 ENDIF
2949 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2950 MSAV48=MSAV48+MINT(48)
2951
2952C...Reset variables for cross-section calculation.
2953 DO 150 I=0,500
2954 DO 140 J=1,3
2955 NGEN(I,J)=0
2956 XSEC(I,J)=0D0
2957 140 CONTINUE
2958 150 CONTINUE
2959
2960C...Find parametrized total cross-sections.
2961 CALL PYXTOT
2962 VINT(318)=VINT(317)
2963
2964C...Maxima of differential cross-sections.
2965 IF(MSTP(121).LE.1) CALL PYMAXI
2966
2967C...Initialize possibility of pileup events.
2968 IF(MINT(121).GT.1) MSTP(131)=0
2969 IF(MSTP(131).NE.0) CALL PYPILE(1)
2970
2971C...Initialize multiple interactions with variable impact parameter.
2972 IF(MINT(50).EQ.1) THEN
2973 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2974 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
2975 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
2976 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
2977 MINT(35)=1
2978 CALL PYMULT(1)
2979 MINT(35)=3
2980 CALL PYMIGN(1)
2981 ENDIF
2982 ENDIF
2983
2984C...Save results for gamma-p and gamma-gamma alternatives.
2985 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2986 160 CONTINUE
2987
2988C...Initialization finished.
2989 IF(MSAV48.EQ.0) THEN
2990 IF(MSTP(127).NE.1) THEN
2991 WRITE(MSTU(11),5500)
2992 CALL PYSTOP(1)
2993 ELSE
2994 WRITE(MSTU(11),5700)
2995 MSTI(53)=1
2996 ENDIF
2997 ENDIF
2998 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2999
3000C...Formats for initialization information.
3001 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3002 &'routines',1X,17('*'))
3003 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3004 &'-',A6,' interactions.'/1X,'Execution stopped!')
3005 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3006 &1X,'Execution stopped!')
3007 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3008 &1X,'Execution stopped!')
3009 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3010 &1X,'Execution stopped.')
3011 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3012 &22('*'))
3013 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3014 &1X,'Execution will stop if you try to generate events.')
3015
3016 RETURN
3017 END
3018
3019C*********************************************************************
3020
3021C...PYEVNT
3022C...Administers the generation of a high-pT event via calls to
3023C...a number of subroutines.
3024
3025 SUBROUTINE PYEVNT
3026
3027C...Double precision and integer declarations.
3028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3029 IMPLICIT INTEGER(I-N)
3030 INTEGER PYK,PYCHGE,PYCOMP
3031C...Commonblocks.
3032 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3033 COMMON/PYCTAG/NCT,MCT(4000,2)
3034 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3035 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3036 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3037 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3038 COMMON/PYINT1/MINT(400),VINT(400)
3039 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3040 COMMON/PYINT4/MWID(500),WIDS(500,5)
3041 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3042 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3043 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3044C...Local array.
3045 DIMENSION VTX(4)
3046
3047C...Optionally let PYEVNW do the whole job.
3048 IF(MSTP(81).GE.20) THEN
3049 CALL PYEVNW
3050 RETURN
3051 ENDIF
3052
3053C...Stop if no subprocesses on.
3054 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3055 WRITE(MSTU(11),5100)
3056 CALL PYSTOP(1)
3057 ENDIF
3058
3059C...Initial values for some counters.
3060 MSTU(1)=0
3061 MSTU(2)=0
3062 N=0
3063 MINT(5)=MINT(5)+1
3064 MINT(7)=0
3065 MINT(8)=0
3066 MINT(30)=0
3067 MINT(83)=0
3068 MINT(84)=MSTP(126)
3069 MSTU(24)=0
3070 MSTU70=0
3071 MSTJ14=MSTJ(14)
3072C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3073 NCT=0
3074 MINT(33)=0
3075
3076C...Let called routines know call is from PYEVNT (not PYEVNW).
3077 MINT(35)=1
3078 IF (MSTP(81).GE.10) MINT(35)=2
3079
3080C...If variable energies: redo incoming kinematics and cross-section.
3081 MSTI(61)=0
3082 IF(MSTP(171).EQ.1) THEN
3083 CALL PYINKI(1)
3084 IF(MSTI(61).EQ.1) THEN
3085 MINT(5)=MINT(5)-1
3086 RETURN
3087 ENDIF
3088 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3089 CALL PYXTOT
3090 ENDIF
3091
3092C...Loop over number of pileup events; check space left.
3093 IF(MSTP(131).LE.0) THEN
3094 NPILE=1
3095 ELSE
3096 CALL PYPILE(2)
3097 NPILE=MINT(81)
3098 ENDIF
3099 DO 270 IPILE=1,NPILE
3100 IF(MINT(84)+100.GE.MSTU(4)) THEN
3101 CALL PYERRM(11,
3102 & '(PYEVNT:) no more space in PYJETS for pileup events')
3103 IF(MSTU(21).GE.1) GOTO 280
3104 ENDIF
3105 MINT(82)=IPILE
3106
3107C...Generate variables of hard scattering.
3108 MINT(51)=0
3109 MSTI(52)=0
3110 100 CONTINUE
3111 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3112 MINT(31)=0
3113 MINT(39)=0
3114 MINT(51)=0
3115 MINT(57)=0
3116 CALL PYRAND
3117 IF(MSTI(61).EQ.1) THEN
3118 MINT(5)=MINT(5)-1
3119 RETURN
3120 ENDIF
3121 IF(MINT(51).EQ.2) RETURN
3122 ISUB=MINT(1)
3123 IF(MSTP(111).EQ.-1) GOTO 260
3124
3125C...Loopback point if PYPREP fails, especially for junction topologies.
3126 NPREP=0
3127 MNT31S=MINT(31)
3128 110 NPREP=NPREP+1
3129 MINT(31)=MNT31S
3130
3131 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3132C...Hard scattering (including low-pT):
3133C...reconstruct kinematics and colour flow of hard scattering.
3134 MINT31=MINT(31)
3135 120 MINT(31)=MINT31
3136 MINT(51)=0
3137 CALL PYSCAT
3138 IF(MINT(51).EQ.1) GOTO 100
3139 IPU1=MINT(84)+1
3140 IPU2=MINT(84)+2
3141 IF(ISUB.EQ.95) GOTO 140
3142
3143C...Reset statistics on activity in event.
3144 DO 130 J=351,359
3145 MINT(J)=0
3146 VINT(J)=0D0
3147 130 CONTINUE
3148
3149C...Showering of initial state partons (optional).
3150 NFIN=N
3151 ALAMSV=PARJ(81)
3152 PARJ(81)=PARP(72)
3153 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3154 & CALL PYSSPA(IPU1,IPU2)
3155 PARJ(81)=ALAMSV
3156 IF(MINT(51).EQ.1) GOTO 100
3157
3158C...Showering of final state partons (optional).
3159 ALAMSV=PARJ(81)
3160 PARJ(81)=PARP(72)
3161 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3162 & THEN
3163 IPU3=MINT(84)+3
3164 IPU4=MINT(84)+4
3165 IF(ISET(ISUB).EQ.5) IPU4=-3
3166 QMAX=VINT(55)
3167 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3168 CALL PYSHOW(IPU3,IPU4,QMAX)
3169 ELSEIF(ISET(ISUB).EQ.11) THEN
3170 CALL PYADSH(NFIN)
3171 ENDIF
3172 PARJ(81)=ALAMSV
3173
3174C...Allow possibility for user to abort event generation.
3175 IVETO=0
3176 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3177 IF(IVETO.EQ.1) GOTO 100
3178
3179C...Decay of final state resonances.
3180 MINT(32)=0
3181 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3182 IF(MINT(51).EQ.1) GOTO 100
3183 MINT(52)=N
3184
3185
3186C...Multiple interactions - PYTHIA 6.3 intermediate style.
3187 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3188 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3189 CALL PYMIGN(6)
3190 IF(MINT(51).EQ.1) GOTO 100
3191 MINT(53)=N
3192
3193C...Beam remnant flavour and colour assignments - new scheme.
3194 CALL PYMIHK
3195 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3196 & GOTO 120
3197 IF(MINT(51).EQ.1) GOTO 100
3198
3199C...Primordial kT and beam remnant momentum sharing - new scheme.
3200 CALL PYMIRM
3201 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3202 & GOTO 120
3203 IF(MINT(51).EQ.1) GOTO 100
3204 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3205
3206C...Multiple interactions - PYTHIA 6.2 style.
3207 ELSEIF(MINT(111).NE.12) THEN
3208 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3209 CALL PYMULT(6)
3210 MINT(53)=N
3211 ENDIF
3212
3213C...Hadron remnants and primordial kT.
3214 CALL PYREMN(IPU1,IPU2)
3215 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3216 & 110
3217 IF(MINT(51).EQ.1) GOTO 100
3218 ENDIF
3219
3220 ELSEIF(ISUB.NE.99) THEN
3221C...Diffractive and elastic scattering.
3222 CALL PYDIFF
3223
3224 ELSE
3225C...DIS scattering (photon flux external).
3226 CALL PYDISG
3227 IF(MINT(51).EQ.1) GOTO 100
3228 ENDIF
3229
3230C...Check that no odd resonance left undecayed.
3231 MINT(54)=N
3232 IF(MSTP(111).GE.1) THEN
3233 NFIX=N
3234 DO 150 I=MINT(84)+1,NFIX
3235 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3236 & K(I,2).NE.22) THEN
3237 KCA=PYCOMP(K(I,2))
3238 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3239 CALL PYRESD(I)
3240 IF(MINT(51).EQ.1) GOTO 100
3241 ENDIF
3242 ENDIF
3243 150 CONTINUE
3244 ENDIF
3245
3246C...Boost hadronic subsystem to overall rest frame.
3247C..(Only relevant when photon inside lepton beam.)
3248 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3249
3250C...Recalculate energies from momenta and masses (if desired).
3251 IF(MSTP(113).GE.1) THEN
3252 DO 160 I=MINT(83)+1,N
3253 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3254 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3255 160 CONTINUE
3256 NRECAL=N
3257 ENDIF
3258
3259C...Colour reconnection before string formation
3260 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3261
3262C...Rearrange partons along strings, check invariant mass cuts.
3263 MSTU(28)=0
3264 IF(MSTP(111).LE.0) MSTJ(14)=-1
3265 CALL PYPREP(MINT(84)+1)
3266 MSTJ(14)=MSTJ14
3267 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3268 MSTU(24)=0
3269 GOTO 100
3270 ENDIF
3271 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3272 IF (MINT(51).EQ.1) GOTO 100
3273 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3274 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3275 DO 190 I=MINT(84)+1,N
3276 IF(K(I,2).EQ.94) THEN
3277 DO 180 I1=I+1,MIN(N,I+10)
3278 IF(K(I1,3).EQ.I) THEN
3279 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3280 IF(K(I1,3).EQ.0) THEN
3281 DO 170 II=MINT(84)+1,I-1
3282 IF(K(II,2).EQ.K(I1,2)) THEN
3283 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3284 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3285 ENDIF
3286 170 CONTINUE
3287 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3288 ENDIF
3289 ENDIF
3290 180 CONTINUE
3291 ENDIF
3292 190 CONTINUE
3293 CALL PYEDIT(12)
3294 CALL PYEDIT(14)
3295 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3296 IF(MSTP(125).EQ.0) MINT(4)=0
3297 DO 210 I=MINT(83)+1,N
3298 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3299 DO 200 I1=I+1,N
3300 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3301 IF(K(I1,3).EQ.I) K(I,5)=I1
3302 200 CONTINUE
3303 ENDIF
3304 210 CONTINUE
3305 ENDIF
3306
3307C...Introduce separators between sections in PYLIST event listing.
3308 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3309 MSTU70=1
3310 MSTU(71)=N
3311 ELSEIF(IPILE.EQ.1) THEN
3312 MSTU70=3
3313 MSTU(71)=2
3314 MSTU(72)=MINT(4)
3315 MSTU(73)=N
3316 ENDIF
3317
3318C...Go back to lab frame (needed for vertices, also in fragmentation).
3319 CALL PYFRAM(1)
3320
3321C...Set nonvanishing production vertex (optional).
3322 IF(MSTP(151).EQ.1) THEN
3323 DO 220 J=1,4
3324 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3325 & SIN(PARU(2)*PYR(0))
3326 220 CONTINUE
3327 DO 240 I=MINT(83)+1,N
3328 DO 230 J=1,4
3329 V(I,J)=V(I,J)+VTX(J)
3330 230 CONTINUE
3331 240 CONTINUE
3332 ENDIF
3333
3334C...Perform hadronization (if desired).
3335 IF(MSTP(111).GE.1) THEN
3336 CALL PYEXEC
3337 IF(MSTU(24).NE.0) GOTO 100
3338 ENDIF
3339 IF(MSTP(113).GE.1) THEN
3340 DO 250 I=NRECAL,N
3341 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3342 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3343 250 CONTINUE
3344 ENDIF
3345 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3346
3347C...Store event information and calculate Monte Carlo estimates of
3348C...subprocess cross-sections.
3349 260 IF(IPILE.EQ.1) CALL PYDOCU
3350
3351C...Set counters for current pileup event and loop to next one.
3352 MSTI(41)=IPILE
3353 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3354 IF(MSTU70.LT.10) THEN
3355 MSTU70=MSTU70+1
3356 MSTU(70+MSTU70)=N
3357 ENDIF
3358 MINT(83)=N
3359 MINT(84)=N+MSTP(126)
3360 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3361 270 CONTINUE
3362
3363C...Generic information on pileup events. Reconstruct missing history.
3364 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3365 PARI(91)=VINT(132)
3366 PARI(92)=VINT(133)
3367 PARI(93)=VINT(134)
3368 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3369 ENDIF
3370 CALL PYEDIT(16)
3371
3372C...Transform to the desired coordinate frame.
3373 280 CALL PYFRAM(MSTP(124))
3374 MSTU(70)=MSTU70
3375 PARU(21)=VINT(1)
3376
3377C...Error messages
3378 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3379 &1X,'Execution stopped.')
3380
3381 RETURN
3382 END
3383
3384C*********************************************************************
3385
3386C...PYEVNW
3387C...Administers the generation of a high-pT event via calls to
3388C...a number of subroutines for the new multiple interactions and
3389C...showering framework.
3390
3391 SUBROUTINE PYEVNW
3392
3393C...Double precision and integer declarations.
3394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3395 IMPLICIT INTEGER(I-N)
3396 INTEGER PYK,PYCHGE,PYCOMP
3397C...Commonblocks.
3398 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3399 COMMON/PYCTAG/NCT,MCT(4000,2)
3400 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3401 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3402 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3403 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3404 COMMON/PYINT1/MINT(400),VINT(400)
3405 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3406 COMMON/PYINT4/MWID(500),WIDS(500,5)
3407 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3408 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3409 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3410 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3411 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3412 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3413C...Local arrays.
3414 DIMENSION VTX(4)
3415
3416C...Stop if no subprocesses on.
3417 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3418 WRITE(MSTU(11),5100)
3419 CALL PYSTOP(1)
3420 ENDIF
3421
3422C...Initial values for some counters.
3423 MSTU(1)=0
3424 MSTU(2)=0
3425 N=0
3426 MINT(5)=MINT(5)+1
3427 MINT(7)=0
3428 MINT(8)=0
3429 MINT(30)=0
3430 MINT(83)=0
3431 MINT(84)=MSTP(126)
3432 MSTU(24)=0
3433 MSTU70=0
3434 MSTJ14=MSTJ(14)
3435C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3436 NCT=0
3437 MINT(33)=0
3438
3439C...Let called routines know call is from PYEVNW (not PYEVNT).
3440 MINT(35)=3
3441
3442C...If variable energies: redo incoming kinematics and cross-section.
3443 MSTI(61)=0
3444 IF(MSTP(171).EQ.1) THEN
3445 CALL PYINKI(1)
3446 IF(MSTI(61).EQ.1) THEN
3447 MINT(5)=MINT(5)-1
3448 RETURN
3449 ENDIF
3450 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3451 CALL PYXTOT
3452 ENDIF
3453
3454C...Loop over number of pileup events; check space left.
3455 IF(MSTP(131).LE.0) THEN
3456 NPILE=1
3457 ELSE
3458 CALL PYPILE(2)
3459 NPILE=MINT(81)
3460 ENDIF
3461 DO 300 IPILE=1,NPILE
3462 IF(MINT(84)+100.GE.MSTU(4)) THEN
3463 CALL PYERRM(11,
3464 & '(PYEVNW:) no more space in PYJETS for pileup events')
3465 IF(MSTU(21).GE.1) GOTO 310
3466 ENDIF
3467 MINT(82)=IPILE
3468
3469C...Generate variables of hard scattering.
3470 MINT(51)=0
3471 MSTI(52)=0
3472 100 CONTINUE
3473 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3474 MINT(31)=0
3475 MINT(39)=0
3476 MINT(36)=0
3477 MINT(51)=0
3478 MINT(57)=0
3479 CALL PYRAND
3480 IF(MSTI(61).EQ.1) THEN
3481 MINT(5)=MINT(5)-1
3482 RETURN
3483 ENDIF
3484 IF(MINT(51).EQ.2) RETURN
3485 ISUB=MINT(1)
3486 IF(MSTP(111).EQ.-1) GOTO 290
3487
3488C...Loopback point if PYPREP fails, especially for junction topologies.
3489 NPREP=0
3490 MNT31S=MINT(31)
3491 110 NPREP=NPREP+1
3492 MINT(31)=MNT31S
3493
3494 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3495C...Hard scattering (including low-pT):
3496C...reconstruct kinematics and colour flow of hard scattering.
3497 MINT31=MINT(31)
3498 120 MINT(31)=MINT31
3499 MINT(51)=0
3500 CALL PYSCAT
3501 IF(MINT(51).EQ.1) GOTO 100
3502 NPARTD=N
3503 NFIN=N
3504
3505C...Intertwined initial state showers and multiple interactions.
3506C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3507C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3508 MSTP61=MSTP(61)
3509 IF (MINT(47).LT.2) MSTP(61)=0
3510 MSTP81=MSTP(81)
3511 IF (MINT(50).EQ.0) MSTP(81)=0
3512 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3513 & MINT(111).NE.12) THEN
3514C...Absolute max pT2 scale for evolution: phase space limit.
3515 PT2MXS=0.25D0*VINT(2)
3516C...Check if more constrained by ISR and MI max scales:
3517 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3518C...Loopback point in case of failure in evolution.
3519 LOOP=0
3520 130 LOOP=LOOP+1
3521 MINT(51)=0
3522 IF(LOOP.GT.100) THEN
3523 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3524 & //'multiple interactions.')
3525 MINT(51)=1
3526 RETURN
3527 ENDIF
3528
3529C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3530C...once per event. (E.g. compute constants and save variables to be
3531C...restored later in case of failure.)
3532 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3533
3534C...Initialize interleaved MI/ISR/JI evolution.
3535C...PT2MAX: absolute upper limit for evolution - Initialization may
3536C... return a PT2MAX which is lower than this.
3537C...PT2MIN: absolute lower limit for evolution - Initialization may
3538C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3539 PT2MAX=PT2MXS
3540 PT2MIN=0D0
3541 CALL PYEVOL(0,PT2MAX,PT2MIN)
3542 IF (MINT(51).EQ.1) GOTO 130
3543
3544C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3545C...In principle factorized, so can be stopped and restarted.
3546C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3547C PT2MED=MAX(10D0**2,PT2MIN)
3548C CALL PYEVOL(1,PT2MAX,PT2MED)
3549C IF (MINT(51).EQ.1) GOTO 160
3550C PT2MAX=PT2MED
3551 CALL PYEVOL(1,PT2MAX,PT2MIN)
3552 IF (MINT(51).EQ.1) GOTO 130
3553
3554C...Finalize interleaved MI/ISR/JI evolution.
3555 CALL PYEVOL(2,PT2MAX,PT2MIN)
3556 IF (MINT(51).EQ.1) GOTO 130
3557
3558 ENDIF
3559 MSTP(61)=MSTP61
3560 MSTP(81)=MSTP81
3561 IF(MINT(51).EQ.1) GOTO 100
3562C...(MINT(52) is actually obsolete in this routine. Set anyway
3563C...to ensure PYDOCU stable.)
3564 MINT(52)=N
3565 MINT(53)=N
3566
3567C...Beam remnants - new scheme.
3568 140 IF(MINT(50).EQ.1) THEN
3569 IF (ISUB.EQ.95) MINT(31)=1
3570
3571C...Beam remnant flavour and colour assignments - new scheme.
3572 CALL PYMIHK
3573 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3574 & GOTO 120
3575 IF(MINT(51).EQ.1) GOTO 100
3576
3577C...Primordial kT and beam remnant momentum sharing - new scheme.
3578 CALL PYMIRM
3579 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3580 & GOTO 120
3581 IF(MINT(51).EQ.1) GOTO 100
3582 IF (ISUB.EQ.95) MINT(31)=0
3583 ELSEIF(MINT(111).NE.12) THEN
3584C...Hadron remnants and primordial kT - old model.
3585C...Happens e.g. for direct photon on one side.
3586 IPU1=IMI(1,1,1)
3587 IPU2=IMI(2,1,1)
3588 CALL PYREMN(IPU1,IPU2)
3589 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3590 & 110
3591 IF(MINT(51).EQ.1) GOTO 100
3592C...PYREMN does not set colour tags for BRs, so needs to be done now.
3593 DO 160 I=MINT(53)+1,N
3594 DO 150 KCS=4,5
3595 IDA=MOD(K(I,KCS),MSTU(5))
3596 IF (IDA.NE.0) THEN
3597 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3598 ELSE
3599 MCT(I,KCS-3)=0
3600 ENDIF
3601 150 CONTINUE
3602 160 CONTINUE
3603C...Instruct PYPREP to use colour tags
3604 MINT(33)=1
3605
3606 DO 360 MQGST=1,2
3607 DO 350 I=MINT(84)+1,N
3608
3609C...Look for coloured string endpoint, or (later) leftover gluon.
3610 IF (K(I,1).NE.3) GOTO 350
3611 KC=PYCOMP(K(I,2))
3612 IF(KC.EQ.0) GOTO 350
3613 KQ=KCHG(KC,2)
3614 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3615
3616C... Pick up loose string end with no previous tag.
3617 KCS=4
3618 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3619 IF(MCT(I,KCS-3).NE.0) GOTO 350
3620
3621 CALL PYCTTR(I,KCS,I)
3622 IF(MINT(51).NE.0) RETURN
3623
3624 350 CONTINUE
3625 360 CONTINUE
3626C...Now delete any colour processing information if set (since partons
3627C...otherwise not FS showered!)
3628 DO 170 I=MINT(84)+1,N
3629 IF (I.LE.N) THEN
3630 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3631 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3632 ENDIF
3633 170 CONTINUE
3634 ENDIF
3635
3636C...Showering of final state partons (optional).
3637 ALAMSV=PARJ(81)
3638 PARJ(81)=PARP(72)
3639 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3640 & THEN
3641 QMAX=VINT(55)
3642 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3643 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3644C...External processes: handle successive showers.
3645 ELSEIF(ISET(ISUB).EQ.11) THEN
3646 CALL PYADSH(NFIN)
3647 ENDIF
3648 PARJ(81)=ALAMSV
3649
3650C...Allow possibility for user to abort event generation.
3651 IVETO=0
3652 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3653 IF(IVETO.EQ.1) GOTO 100
3654
3655
3656C...Decay of final state resonances.
3657 MINT(32)=0
3658 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3659 CALL PYRESD(0)
3660 IF(MINT(51).NE.0) GOTO 100
3661 ENDIF
3662
3663 IF(MINT(51).EQ.1) GOTO 100
3664
3665 ELSEIF(ISUB.NE.99) THEN
3666C...Diffractive and elastic scattering.
3667 CALL PYDIFF
3668
3669 ELSE
3670C...DIS scattering (photon flux external).
3671 CALL PYDISG
3672 IF(MINT(51).EQ.1) GOTO 100
3673 ENDIF
3674
3675C...Check that no odd resonance left undecayed.
3676 MINT(54)=N
3677 IF(MSTP(111).GE.1) THEN
3678 NFIX=N
3679 DO 180 I=MINT(84)+1,NFIX
3680 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3681 & K(I,2).NE.22) THEN
3682 KCA=PYCOMP(K(I,2))
3683 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3684 CALL PYRESD(I)
3685 IF(MINT(51).EQ.1) GOTO 100
3686 ENDIF
3687 ENDIF
3688 180 CONTINUE
3689 ENDIF
3690
3691C...Boost hadronic subsystem to overall rest frame.
3692C..(Only relevant when photon inside lepton beam.)
3693 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3694
3695C...Recalculate energies from momenta and masses (if desired).
3696 IF(MSTP(113).GE.1) THEN
3697 DO 190 I=MINT(83)+1,N
3698 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3699 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3700 190 CONTINUE
3701 NRECAL=N
3702 ENDIF
3703
3704C...Colour reconnection before string formation
3705 CALL PYFSCR(MINT(84)+1)
3706
3707C...Rearrange partons along strings, check invariant mass cuts.
3708 MSTU(28)=0
3709 IF(MSTP(111).LE.0) MSTJ(14)=-1
3710 CALL PYPREP(MINT(84)+1)
3711 MSTJ(14)=MSTJ14
3712 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3713 MSTU(24)=0
3714 GOTO 100
3715 ENDIF
3716 IF(MINT(51).EQ.1) GOTO 110
3717 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3718 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3719 DO 220 I=MINT(84)+1,N
3720 IF(K(I,2).EQ.94) THEN
3721 DO 210 I1=I+1,MIN(N,I+10)
3722 IF(K(I1,3).EQ.I) THEN
3723 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3724 IF(K(I1,3).EQ.0) THEN
3725 DO 200 II=MINT(84)+1,I-1
3726 IF(K(II,2).EQ.K(I1,2)) THEN
3727 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3728 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3729 ENDIF
3730 200 CONTINUE
3731 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3732 ENDIF
3733 ENDIF
3734 210 CONTINUE
3735 ENDIF
3736 220 CONTINUE
3737 CALL PYEDIT(12)
3738 CALL PYEDIT(14)
3739 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3740 IF(MSTP(125).EQ.0) MINT(4)=0
3741 DO 240 I=MINT(83)+1,N
3742 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3743 DO 230 I1=I+1,N
3744 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3745 IF(K(I1,3).EQ.I) K(I,5)=I1
3746 230 CONTINUE
3747 ENDIF
3748 240 CONTINUE
3749 ENDIF
3750
3751C...Introduce separators between sections in PYLIST event listing.
3752 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3753 MSTU70=1
3754 MSTU(71)=N
3755 ELSEIF(IPILE.EQ.1) THEN
3756 MSTU70=3
3757 MSTU(71)=2
3758 MSTU(72)=MINT(4)
3759 MSTU(73)=N
3760 ENDIF
3761
3762C...Go back to lab frame (needed for vertices, also in fragmentation).
3763 CALL PYFRAM(1)
3764
3765C...Set nonvanishing production vertex (optional).
3766 IF(MSTP(151).EQ.1) THEN
3767 DO 250 J=1,4
3768 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3769 & SIN(PARU(2)*PYR(0))
3770 250 CONTINUE
3771 DO 270 I=MINT(83)+1,N
3772 DO 260 J=1,4
3773 V(I,J)=V(I,J)+VTX(J)
3774 260 CONTINUE
3775 270 CONTINUE
3776 ENDIF
3777
3778C...Perform hadronization (if desired).
3779 IF(MSTP(111).GE.1) THEN
3780 CALL PYEXEC
3781 IF(MSTU(24).NE.0) GOTO 100
3782 ENDIF
3783 IF(MSTP(113).GE.1) THEN
3784 DO 280 I=NRECAL,N
3785 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3786 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3787 280 CONTINUE
3788 ENDIF
3789 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3790
3791C...Store event information and calculate Monte Carlo estimates of
3792C...subprocess cross-sections.
3793 290 IF(IPILE.EQ.1) CALL PYDOCU
3794
3795C...Set counters for current pileup event and loop to next one.
3796 MSTI(41)=IPILE
3797 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3798 IF(MSTU70.LT.10) THEN
3799 MSTU70=MSTU70+1
3800 MSTU(70+MSTU70)=N
3801 ENDIF
3802 MINT(83)=N
3803 MINT(84)=N+MSTP(126)
3804 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3805 300 CONTINUE
3806
3807C...Generic information on pileup events. Reconstruct missing history.
3808 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3809 PARI(91)=VINT(132)
3810 PARI(92)=VINT(133)
3811 PARI(93)=VINT(134)
3812 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3813 ENDIF
3814 CALL PYEDIT(16)
3815
3816C...Transform to the desired coordinate frame.
3817 310 CALL PYFRAM(MSTP(124))
3818 MSTU(70)=MSTU70
3819 PARU(21)=VINT(1)
3820
3821C...Error messages
3822 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3823 &1X,'Execution stopped.')
3824
3825 RETURN
3826 END
3827
3828
3829C***********************************************************************
3830
3831C...PYSTAT
3832C...Prints out information about cross-sections, decay widths, branching
3833C...ratios, kinematical limits, status codes and parameter values.
3834
3835 SUBROUTINE PYSTAT(MSTAT)
3836
3837C...Double precision and integer declarations.
3838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3839 IMPLICIT INTEGER(I-N)
3840 INTEGER PYK,PYCHGE,PYCOMP
3841C...Parameter statement to help give large particle numbers.
3842 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3843 &KEXCIT=4000000,KDIMEN=5000000)
3844 PARAMETER (EPS=1D-3)
3845C...Commonblocks.
3846 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3847 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3848 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3849 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3851 COMMON/PYINT1/MINT(400),VINT(400)
3852 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3853 COMMON/PYINT4/MWID(500),WIDS(500,5)
3854 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3855 COMMON/PYINT6/PROC(0:500)
3856 CHARACTER PROC*28, CHTMP*16
3857 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3858 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3859 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3860 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3861C...Local arrays, character variables and data.
3862 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3863 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3864 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3865 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3866 CHARACTER*24 CHD0, CHDC(10)
3867 CHARACTER*6 DNAME(3)
3868 DATA PROGA/
3869 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3870 &'VMD/hadron * anomalous ','direct * direct ',
3871 &'direct * anomalous ','anomalous * anomalous '/
3872 DATA DISGA/'e * VMD','e * anomalous'/
3873 DATA PROGG9/
3874 &'direct * direct ','direct * VMD ',
3875 &'direct * anomalous ','VMD * direct ',
3876 &'VMD * VMD ','VMD * anomalous ',
3877 &'anomalous * direct ','anomalous * VMD ',
3878 &'anomalous * anomalous ','DIS * VMD ',
3879 &'DIS * anomalous ','VMD * DIS ',
3880 &'anomalous * DIS '/
3881 DATA PROGG4/
3882 &'direct * direct ','direct * resolved ',
3883 &'resolved * direct ','resolved * resolved '/
3884 DATA PROGG2/
3885 &'direct * hadron ','resolved * hadron '/
3886 DATA PROGP4/
3887 &'VMD * hadron ','direct * hadron ',
3888 &'anomalous * hadron ','DIS * hadron '/
3889 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3890 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3891 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3892 &' y*_small ',' eta*_large ',' eta*_small ',
3893 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3894 &' x_2 ',' x_F ',' cos(theta_hard) ',
3895 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3896 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3897 &' tau'' '/
3898 DATA DNAME /'q ','lepton','nu '/
3899
3900C...Cross-sections.
3901 IF(MSTAT.LE.1) THEN
3902 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3903 WRITE(MSTU(11),5000)
3904 WRITE(MSTU(11),5100)
3905 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3906 DO 100 I=1,500
3907 IF(MSUB(I).NE.1) GOTO 100
3908 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3909 100 CONTINUE
3910 IF(MINT(121).GT.1) THEN
3911 WRITE(MSTU(11),5300)
3912 DO 110 IGA=1,MINT(121)
3913 CALL PYSAVE(3,IGA)
3914 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3915 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3916 & XSEC(0,3)
3917 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3918 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3919 & XSEC(0,3)
3920 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3921 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3922 & XSEC(0,3)
3923 ELSEIF(MINT(121).EQ.4) THEN
3924 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3925 & XSEC(0,3)
3926 ELSEIF(MINT(121).EQ.2) THEN
3927 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3928 & XSEC(0,3)
3929 ELSE
3930 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3931 & XSEC(0,3)
3932 ENDIF
3933 110 CONTINUE
3934 CALL PYSAVE(5,0)
3935 ENDIF
3936 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3937 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3938
3939C...Decay widths and branching ratios.
3940 ELSEIF(MSTAT.EQ.2) THEN
3941 WRITE(MSTU(11),5500)
3942 WRITE(MSTU(11),5600)
3943 DO 140 KC=1,500
3944 KF=KCHG(KC,4)
3945 CALL PYNAME(KF,CHKF)
3946 IOFF=0
3947 IF(KC.LE.22) THEN
3948 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3949 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3950 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3951 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3952 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3953 ELSE
3954 IF(MWID(KC).LE.0) GOTO 140
3955 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3956 & KF/KSUSY1.EQ.2)) GOTO 140
3957 ENDIF
3958C...Off-shell branchings.
3959 IF(IOFF.EQ.1) THEN
3960 NGP=0
3961 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3962 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3963 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3964 DO 120 J=1,MDCY(KC,3)
3965 IDC=J+MDCY(KC,2)-1
3966 NGP1=0
3967 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3968 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3969 NGP2=0
3970 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3971 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3972 CALL PYNAME(KFDP(IDC,1),CHD1)
3973 CALL PYNAME(KFDP(IDC,2),CHD2)
3974 IF(KFDP(IDC,3).EQ.0) THEN
3975 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3976 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3977 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3978 ELSE
3979 CALL PYNAME(KFDP(IDC,3),CHD3)
3980 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3981 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3982 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3983 ENDIF
3984 120 CONTINUE
3985C...On-shell decays.
3986 ELSE
3987 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3988 BRFIN=1D0
3989 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3990 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3991 & STATE(MDCY(KC,1)),BRFIN
3992 DO 130 J=1,MDCY(KC,3)
3993 IDC=J+MDCY(KC,2)-1
3994 NGP1=0
3995 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3996 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3997 NGP2=0
3998 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3999 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4000 BRPRI=0D0
4001 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4002 BRFIN=0D0
4003 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4004 CALL PYNAME(KFDP(IDC,1),CHD1)
4005 CALL PYNAME(KFDP(IDC,2),CHD2)
4006 IF(KFDP(IDC,3).EQ.0) THEN
4007 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4008 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4009 & CHD2(1:10),WDTP(J),BRPRI,
4010 & STATE(MDME(IDC,1)),BRFIN
4011 ELSE
4012 CALL PYNAME(KFDP(IDC,3),CHD3)
4013 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4014 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4015 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4016 & STATE(MDME(IDC,1)),BRFIN
4017 ENDIF
4018 130 CONTINUE
4019 ENDIF
4020 140 CONTINUE
4021 WRITE(MSTU(11),6000)
4022
4023C...Allowed incoming partons/particles at hard interaction.
4024 ELSEIF(MSTAT.EQ.3) THEN
4025 WRITE(MSTU(11),6100)
4026 CALL PYNAME(MINT(11),CHAU)
4027 CHIN(1)=CHAU(1:12)
4028 CALL PYNAME(MINT(12),CHAU)
4029 CHIN(2)=CHAU(1:12)
4030 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4031 DO 150 I=-20,22
4032 IF(I.EQ.0) GOTO 150
4033 IA=IABS(I)
4034 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4035 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4036 CALL PYNAME(I,CHAU)
4037 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4038 & STATE(KFIN(2,I))
4039 150 CONTINUE
4040 WRITE(MSTU(11),6400)
4041
4042C...User-defined limits on kinematical variables.
4043 ELSEIF(MSTAT.EQ.4) THEN
4044 WRITE(MSTU(11),6500)
4045 WRITE(MSTU(11),6600)
4046 SHRMAX=CKIN(2)
4047 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4048 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4049 PTHMIN=MAX(CKIN(3),CKIN(5))
4050 PTHMAX=CKIN(4)
4051 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4052 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4053 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4054 DO 160 I=4,14
4055 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4056 160 CONTINUE
4057 SPRMAX=CKIN(32)
4058 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4059 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4060 WRITE(MSTU(11),7000)
4061
4062C...Status codes and parameter values.
4063 ELSEIF(MSTAT.EQ.5) THEN
4064 WRITE(MSTU(11),7100)
4065 WRITE(MSTU(11),7200)
4066 DO 170 I=1,100
4067 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4068 & PARP(100+I)
4069 170 CONTINUE
4070
4071C...List of all processes implemented in the program.
4072 ELSEIF(MSTAT.EQ.6) THEN
4073 WRITE(MSTU(11),7400)
4074 WRITE(MSTU(11),7500)
4075 DO 180 I=1,500
4076 IF(ISET(I).LT.0) GOTO 180
4077 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4078 180 CONTINUE
4079 WRITE(MSTU(11),7700)
4080
4081 ELSEIF(MSTAT.EQ.7) THEN
4082 WRITE (MSTU(11),8000)
4083 NMODES(0)=0
4084 NMODES(10)=0
4085 NMODES(9)=0
4086 DO 290 ILR=1,2
4087 DO 280 KFSM=1,16
4088 KFSUSY=ILR*KSUSY1+KFSM
4089 NRVDC=0
4090C...SDOWN DECAYS
4091 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4092 NRVDC=3
4093 DO 190 I=1,NRVDC
4094 PBRAT(I)=0D0
4095 NMODES(I)=0
4096 190 CONTINUE
4097 CALL PYNAME(KFSUSY,CHTMP)
4098 CHD0=CHTMP//' '
4099 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4100 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4101 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4102 KC=PYCOMP(KFSUSY)
4103 DO 200 J=1,MDCY(KC,3)
4104 IDC=J+MDCY(KC,2)-1
4105 ID1=IABS(KFDP(IDC,1))
4106 ID2=IABS(KFDP(IDC,2))
4107 IF (KFDP(IDC,3).EQ.0) THEN
4108 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4109 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4110 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4111 NMODES(1)=NMODES(1)+1
4112 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4113 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4114 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4115 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4116 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4117 NMODES(2)=NMODES(2)+1
4118 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4119 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4120 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4121 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4122 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4123 NMODES(3)=NMODES(3)+1
4124 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4125 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4126 ENDIF
4127 ENDIF
4128 200 CONTINUE
4129 ENDIF
4130C...SUP DECAYS
4131 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4132 NRVDC=2
4133 DO 210 I=1,NRVDC
4134 NMODES(I)=0
4135 PBRAT(I)=0D0
4136 210 CONTINUE
4137 CALL PYNAME(KFSUSY,CHTMP)
4138 CHD0=CHTMP//' '
4139 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4140 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4141 KC=PYCOMP(KFSUSY)
4142 DO 220 J=1,MDCY(KC,3)
4143 IDC=J+MDCY(KC,2)-1
4144 ID1=IABS(KFDP(IDC,1))
4145 ID2=IABS(KFDP(IDC,2))
4146 IF (KFDP(IDC,3).EQ.0) THEN
4147 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4148 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4149 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4150 NMODES(1)=NMODES(1)+1
4151 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4152 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4153 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4154 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4155 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4156 NMODES(2)=NMODES(2)+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 ENDIF
4161 220 CONTINUE
4162 ENDIF
4163C...SLEPTON DECAYS
4164 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4165 NRVDC=2
4166 DO 230 I=1,NRVDC
4167 PBRAT(I)=0D0
4168 NMODES(I)=0
4169 230 CONTINUE
4170 CALL PYNAME(KFSUSY,CHTMP)
4171 CHD0=CHTMP//' '
4172 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4173 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4174 KC=PYCOMP(KFSUSY)
4175 DO 240 J=1,MDCY(KC,3)
4176 IDC=J+MDCY(KC,2)-1
4177 ID1=IABS(KFDP(IDC,1))
4178 ID2=IABS(KFDP(IDC,2))
4179 IF (KFDP(IDC,3).EQ.0) THEN
4180 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4181 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4182 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4183 NMODES(1)=NMODES(1)+1
4184 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4185 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4186 ENDIF
4187 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4188 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4189 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4190 NMODES(2)=NMODES(2)+1
4191 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4192 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4193 ENDIF
4194 ENDIF
4195 240 CONTINUE
4196 ENDIF
4197C...SNEUTRINO DECAYS
4198 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4199 & THEN
4200 NRVDC=2
4201 DO 250 I=1,NRVDC
4202 PBRAT(I)=0D0
4203 NMODES(I)=0
4204 250 CONTINUE
4205 CALL PYNAME(KFSUSY,CHTMP)
4206 CHD0=CHTMP//' '
4207 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4208 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4209 KC=PYCOMP(KFSUSY)
4210 DO 260 J=1,MDCY(KC,3)
4211 IDC=J+MDCY(KC,2)-1
4212 ID1=IABS(KFDP(IDC,1))
4213 ID2=IABS(KFDP(IDC,2))
4214 IF (KFDP(IDC,3).EQ.0) THEN
4215 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4216 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4217 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4218 NMODES(1)=NMODES(1)+1
4219 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4220 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4221 ENDIF
4222 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4223 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4224 NMODES(2)=NMODES(2)+1
4225 PBRAT(2)=PBRAT(2)+BRAT(IDC)
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 ENDIF
4230 260 CONTINUE
4231 ENDIF
4232 IF (NRVDC.NE.0) THEN
4233 DO 270 I=1,NRVDC
4234 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4235 NMODES(0)=NMODES(0)+NMODES(I)
4236 270 CONTINUE
4237 ENDIF
4238 280 CONTINUE
4239 290 CONTINUE
4240 DO 370 KFSM=21,37
4241 KFSUSY=KSUSY1+KFSM
4242 NRVDC=0
4243C...NEUTRALINO DECAYS
4244 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4245 NRVDC=4
4246 DO 300 I=1,NRVDC
4247 PBRAT(I)=0D0
4248 NMODES(I)=0
4249 300 CONTINUE
4250 CALL PYNAME(KFSUSY,CHTMP)
4251 CHD0=CHTMP//' '
4252 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4253 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4254 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4255 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4256 KC=PYCOMP(KFSUSY)
4257 DO 310 J=1,MDCY(KC,3)
4258 IDC=J+MDCY(KC,2)-1
4259 ID1=IABS(KFDP(IDC,1))
4260 ID2=IABS(KFDP(IDC,2))
4261 ID3=IABS(KFDP(IDC,3))
4262 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4263 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4264 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4265 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4266 NMODES(1)=NMODES(1)+1
4267 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4268 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4269 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4270 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4271 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4272 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4273 NMODES(2)=NMODES(2)+1
4274 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4275 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4276 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4277 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4278 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4279 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4280 NMODES(3)=NMODES(3)+1
4281 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4282 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4283 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4284 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4285 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4286 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4287 NMODES(4)=NMODES(4)+1
4288 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4289 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4290 ENDIF
4291 310 CONTINUE
4292 ENDIF
4293C...CHARGINO DECAYS
4294 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4295 NRVDC=5
4296 DO 320 I=1,NRVDC
4297 PBRAT(I)=0D0
4298 NMODES(I)=0
4299 320 CONTINUE
4300 CALL PYNAME(KFSUSY,CHTMP)
4301 CHD0=CHTMP//' '
4302 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4303 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4304 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4305 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4306 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4307 KC=PYCOMP(KFSUSY)
4308 DO 330 J=1,MDCY(KC,3)
4309 IDC=J+MDCY(KC,2)-1
4310 ID1=IABS(KFDP(IDC,1))
4311 ID2=IABS(KFDP(IDC,2))
4312 ID3=IABS(KFDP(IDC,3))
4313 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4314 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4315 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4316 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4317 NMODES(1)=NMODES(1)+1
4318 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4319 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4320 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4321 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4322 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4323 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4324 NMODES(1)=NMODES(1)+1
4325 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4326 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4327 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4328 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4329 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4330 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4331 NMODES(2)=NMODES(2)+1
4332 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4333 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4334 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4335 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4336 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4337 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4338 NMODES(3)=NMODES(3)+1
4339 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4340 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4341 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4342 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4343 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4344 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4345 NMODES(3)=NMODES(3)+1
4346 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4347 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4348 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4349 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4350 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4351 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4352 NMODES(4)=NMODES(4)+1
4353 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4354 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4355 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4356 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4357 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4358 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4359 NMODES(4)=NMODES(4)+1
4360 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4361 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4362 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4363 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4364 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4365 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4366 NMODES(5)=NMODES(5)+1
4367 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4368 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4369 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4370 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4371 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4372 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4373 NMODES(5)=NMODES(5)+1
4374 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4375 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4376 ENDIF
4377 330 CONTINUE
4378 ENDIF
4379C...GLUINO DECAYS
4380 IF (KFSM.EQ.21) THEN
4381 NRVDC=3
4382 DO 340 I=1,NRVDC
4383 PBRAT(I)=0D0
4384 NMODES(I)=0
4385 340 CONTINUE
4386 CALL PYNAME(KFSUSY,CHTMP)
4387 CHD0=CHTMP//' '
4388 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4389 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4390 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4391 KC=PYCOMP(KFSUSY)
4392 DO 350 J=1,MDCY(KC,3)
4393 IDC=J+MDCY(KC,2)-1
4394 ID1=IABS(KFDP(IDC,1))
4395 ID2=IABS(KFDP(IDC,2))
4396 ID3=IABS(KFDP(IDC,3))
4397 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4398 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4399 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4400 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4401 NMODES(1)=NMODES(1)+1
4402 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4403 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4404 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4405 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4406 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4407 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4408 NMODES(2)=NMODES(2)+1
4409 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4410 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4411 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4412 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4413 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4414 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4415 NMODES(3)=NMODES(3)+1
4416 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4417 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4418 ENDIF
4419 350 CONTINUE
4420 ENDIF
4421
4422 IF (NRVDC.NE.0) THEN
4423 DO 360 I=1,NRVDC
4424 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4425 NMODES(0)=NMODES(0)+NMODES(I)
4426 360 CONTINUE
4427 ENDIF
4428 370 CONTINUE
4429 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4430
4431 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4432 WRITE (MSTU(11),8500)
4433 DO 400 IRV=1,3
4434 DO 390 JRV=1,3
4435 DO 380 KRV=1,3
4436 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4437 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4438 380 CONTINUE
4439 390 CONTINUE
4440 400 CONTINUE
4441 WRITE (MSTU(11),8600)
4442 ENDIF
4443 ENDIF
4444
4445C...Formats for printouts.
4446 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4447 &'Events and Cross-sections',1X,9('*'))
4448 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4449 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4450 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4451 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4452 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4453 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4454 &'I',12X,'I')
4455 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4456 &D10.3,1X,'I')
4457 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4458 &1X,'I',34X,'I',28X,'I',12X,'I')
4459 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4460 &1X,'********* Total number of errors, excluding junctions =',
4461 &1X,I8,' *************'/
4462 &1X,'********* Total number of errors, including junctions =',
4463 &1X,I8,' *************'/
4464 &1X,'********* Total number of warnings = ',
4465 &1X,I8,' *************'/
4466 &1X,'********* Fraction of events that fail fragmentation ',
4467 &'cuts =',1X,F8.5,' *********'/)
4468 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4469 &'Ratios',1X,27('*'))
4470 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4471 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4472 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4473 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4474 &1X,98('='))
4475 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4476 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4477 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4478 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4479 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4480 &1P,D10.3,0P,1X,'I')
4481 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4482 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4483 &1P,D10.3,0P,1X,'I')
4484 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4485 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4486 &'Particles at Hard Interaction',1X,7('*'))
4487 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4488 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4489 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4490 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4491 &78('=')/1X,'I',38X,'I',37X,'I')
4492 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4493 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4494 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4495 &'Kinematical Variables',1X,12('*'))
4496 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4497 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4498 &16X,'I')
4499 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4500 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4501 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4502 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4503 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4504 &'Parameter Values',1X,12('*'))
4505 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4506 &'PARP(I)'/)
4507 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4508 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4509 &1X,13('*'))
4510 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4511 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4512 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4513 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4514 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4515 8000 FORMAT(1X/ 1X/
4516 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4517 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4518 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4519 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4520 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4521 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4522 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4523 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4524 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4525 & /1X,70('='))
4526 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4527 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4528 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4529 8500 FORMAT(1X/ 1X/
4530 & 1X,'R-Violating couplings',1X/ 1X /
4531 & 1X,55('=')/
4532 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4533 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4534 & ,'I',15X,'I',15X,'I',15X,'I')
4535 8600 FORMAT(1X,55('='))
4536 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4537 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4538
4539 RETURN
4540 END
4541
4542C*********************************************************************
4543
4544C...PYUPEV
4545C...Administers the hard-process generation required for output to the
4546C...Les Houches event record.
4547
4548 SUBROUTINE PYUPEV
4549
4550C...Double precision and integer declarations.
4551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4552 IMPLICIT INTEGER(I-N)
4553 INTEGER PYK,PYCHGE,PYCOMP
4554
4555C...Commonblocks.
4556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4557 COMMON/PYCTAG/NCT,MCT(4000,2)
4558 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4559 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4560 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4562 COMMON/PYINT1/MINT(400),VINT(400)
4563 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4564 COMMON/PYINT4/MWID(500),WIDS(500,5)
4565 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4566 &/PYINT1/,/PYINT2/,/PYINT4/
4567
4568C...HEPEUP for output.
4569 INTEGER MAXNUP
4570 PARAMETER (MAXNUP=500)
4571 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4572 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4573 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4574 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4575 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4576 SAVE /HEPEUP/
4577
4578C...Stop if no subprocesses on.
4579 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4580 WRITE(MSTU(11),5100)
4581 STOP
4582 ENDIF
4583
4584C...Special flags for hard-process generation only.
4585 MSTP71=MSTP(71)
4586 MSTP(71)=0
4587 MST128=MSTP(128)
4588 MSTP(128)=1
4589
4590C...Initial values for some counters.
4591 N=0
4592 MINT(5)=MINT(5)+1
4593 MINT(7)=0
4594 MINT(8)=0
4595 MINT(30)=0
4596 MINT(83)=0
4597 MINT(84)=MSTP(126)
4598 MSTU(24)=0
4599 MSTU70=0
4600 MSTJ14=MSTJ(14)
4601C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4602 MINT(33)=0
4603
4604C...If variable energies: redo incoming kinematics and cross-section.
4605 MSTI(61)=0
4606 IF(MSTP(171).EQ.1) THEN
4607 CALL PYINKI(1)
4608 IF(MSTI(61).EQ.1) THEN
4609 MINT(5)=MINT(5)-1
4610 RETURN
4611 ENDIF
4612 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4613 CALL PYXTOT
4614 ENDIF
4615
4616C...Do not allow pileup events.
4617 MINT(82)=1
4618
4619C...Generate variables of hard scattering.
4620 MINT(51)=0
4621 MSTI(52)=0
4622 100 CONTINUE
4623 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4624 MINT(31)=0
4625 MINT(51)=0
4626 MINT(57)=0
4627 CALL PYRAND
4628 IF(MSTI(61).EQ.1) THEN
4629 MINT(5)=MINT(5)-1
4630 RETURN
4631 ENDIF
4632 IF(MINT(51).EQ.2) RETURN
4633 ISUB=MINT(1)
4634
4635 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4636C...Hard scattering (including low-pT):
4637C...reconstruct kinematics and colour flow of hard scattering.
4638 MINT31=MINT(31)
4639 110 MINT(31)=MINT31
4640 MINT(51)=0
4641 CALL PYSCAT
4642 IF(MINT(51).EQ.1) GOTO 100
4643 IPU1=MINT(84)+1
4644 IPU2=MINT(84)+2
4645
4646C...Decay of final state resonances.
4647 MINT(32)=0
4648 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4649 & CALL PYRESD(0)
4650 IF(MINT(51).EQ.1) GOTO 100
4651 MINT(52)=N
4652
4653C...Longitudinal boost of hard scattering.
4654 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4655 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4656
4657 ELSEIF(ISUB.NE.99) THEN
4658C...Diffractive and elastic scattering.
4659 CALL PYDIFF
4660
4661 ELSE
4662C...DIS scattering (photon flux external).
4663 CALL PYDISG
4664 IF(MINT(51).EQ.1) GOTO 100
4665 ENDIF
4666
4667C...Check that no odd resonance left undecayed.
4668 MINT(54)=N
4669 NFIX=N
4670 DO 120 I=MINT(84)+1,NFIX
4671 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4672 & K(I,2).NE.22) THEN
4673 KCA=PYCOMP(K(I,2))
4674 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4675 CALL PYRESD(I)
4676 IF(MINT(51).EQ.1) GOTO 100
4677 ENDIF
4678 ENDIF
4679 120 CONTINUE
4680
4681C...Boost hadronic subsystem to overall rest frame.
4682C..(Only relevant when photon inside lepton beam.)
4683 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4684
4685C...Store event information and calculate Monte Carlo estimates of
4686C...subprocess cross-sections.
4687 130 CALL PYDOCU
4688
4689C...Transform to the desired coordinate frame.
4690 140 CALL PYFRAM(MSTP(124))
4691 MSTU(70)=MSTU70
4692 PARU(21)=VINT(1)
4693
4694C...Restore special flags for hard-process generation only.
4695 MSTP(71)=MSTP71
4696 MSTP(128)=MST128
4697
4698C...Trace colour tags; convert to LHA style labels.
4699 NCT=100
4700 DO 150 I=MINT(84)+1,N
4701 MCT(I,1)=0
4702 MCT(I,2)=0
4703 150 CONTINUE
4704 DO 160 I=MINT(84)+1,N
4705 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4706 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4707 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4708 & THEN
4709 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4710 IDA=MOD(K(I,4),MSTU(5))
4711 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4712 & MCT(IMO,2).NE.0) THEN
4713 MCT(I,1)=MCT(IMO,2)
4714 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4715 & MCT(IMO,1).NE.0) THEN
4716 MCT(I,1)=MCT(IMO,1)
4717 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4718 & MCT(IDA,2).NE.0) THEN
4719 MCT(I,1)=MCT(IDA,2)
4720 ELSE
4721 NCT=NCT+1
4722 MCT(I,1)=NCT
4723 ENDIF
4724 ENDIF
4725 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4726 & THEN
4727 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4728 IDA=MOD(K(I,5),MSTU(5))
4729 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4730 & MCT(IMO,1).NE.0) THEN
4731 MCT(I,2)=MCT(IMO,1)
4732 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4733 & MCT(IMO,2).NE.0) THEN
4734 MCT(I,2)=MCT(IMO,2)
4735 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4736 & MCT(IDA,1).NE.0) THEN
4737 MCT(I,2)=MCT(IDA,1)
4738 ELSE
4739 NCT=NCT+1
4740 MCT(I,2)=NCT
4741 ENDIF
4742 ENDIF
4743 ENDIF
4744 160 CONTINUE
4745
4746C...Put event in HEPEUP commonblock.
4747 NUP=N-MINT(84)
4748 IDPRUP=MINT(1)
4749 XWGTUP=1D0
4750 SCALUP=VINT(53)
4751 AQEDUP=VINT(57)
4752 AQCDUP=VINT(58)
4753 DO 180 I=1,NUP
4754 IDUP(I)=K(I+MINT(84),2)
4755 IF(I.LE.2) THEN
4756 ISTUP(I)=-1
4757 MOTHUP(1,I)=0
4758 MOTHUP(2,I)=0
4759 ELSEIF(K(I+4,3).EQ.0) THEN
4760 ISTUP(I)=1
4761 MOTHUP(1,I)=1
4762 MOTHUP(2,I)=2
4763 ELSE
4764 ISTUP(I)=1
4765 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4766 MOTHUP(2,I)=0
4767 ENDIF
4768 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4769 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4770 ICOLUP(1,I)=MCT(I+MINT(84),1)
4771 ICOLUP(2,I)=MCT(I+MINT(84),2)
4772 DO 170 J=1,5
4773 PUP(J,I)=P(I+MINT(84),J)
4774 170 CONTINUE
4775 VTIMUP(I)=V(I,5)
4776 SPINUP(I)=9D0
4777 180 CONTINUE
4778
4779C...Optionally write out event to disk. Minimal size for time/spin fields.
4780 IF(MSTP(162).GT.0) THEN
4781 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4782 DO 190 I=1,NUP
4783 IF(VTIMUP(I).EQ.0D0) THEN
4784 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4785 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4786 & ' 0. 9.'
4787 ELSE
4788 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4789 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4790 & VTIMUP(I),' 9.'
4791 ENDIF
4792 190 CONTINUE
4793
4794C...Optional extra line with parton-density information.
4795 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4796 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4797 ENDIF
4798
4799C...Error messages and other print formats.
4800 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4801 &1X,'Execution stopped.')
4802 5200 FORMAT(1P,2I6,4E14.6)
4803 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4804 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4805 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4806
4807 RETURN
4808 END
4809
4810C*********************************************************************
4811
4812C...PYUPIN
4813C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4814C...processes, and optionally stores that information on file.
4815
4816 SUBROUTINE PYUPIN
4817
4818C...Double precision and integer declarations.
4819 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4820 IMPLICIT INTEGER(I-N)
4821
4822C...Commonblocks.
4823 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4824 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4825 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4826 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4827 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4828
4829C...User process initialization commonblock.
4830 INTEGER MAXPUP
4831 PARAMETER (MAXPUP=100)
4832 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4833 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4834 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4835 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4836 &LPRUP(MAXPUP)
4837 SAVE /HEPRUP/
4838
4839C...Store info on incoming beams.
4840 IDBMUP(1)=K(1,2)
4841 IDBMUP(2)=K(2,2)
4842 EBMUP(1)=P(1,4)
4843 EBMUP(2)=P(2,4)
4844 PDFGUP(1)=0
4845 PDFGUP(2)=0
4846 PDFSUP(1)=MSTP(51)
4847 PDFSUP(2)=MSTP(51)
4848
4849C...Event weighting strategy.
4850 IDWTUP=3
4851
4852C...Info on individual processes.
4853 NPRUP=0
4854 DO 100 ISUB=1,500
4855 IF(MSUB(ISUB).EQ.1) THEN
4856 NPRUP=NPRUP+1
4857 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4858 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4859 XMAXUP(NPRUP)=1D0
4860 LPRUP(NPRUP)=ISUB
4861 ENDIF
4862 100 CONTINUE
4863
4864C...Write info to file.
4865 IF(MSTP(161).GT.0) THEN
4866 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4867 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4868 DO 110 IPR=1,NPRUP
4869 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4870 & LPRUP(IPR)
4871 110 CONTINUE
4872 ENDIF
4873
4874C...Formats for printout.
4875 5100 FORMAT(1P,2I8,2E14.6,6I6)
4876 5200 FORMAT(1P,3E14.6,I6)
4877
4878 RETURN
4879 END
4880
4881
4882C*********************************************************************
4883
4884C...Combine the two old-style Pythia initialization and event files
4885C...into a single Les Houches Event File.
4886
4887 SUBROUTINE PYLHEF
4888
4889C...Double precision and integer declarations.
4890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4891 IMPLICIT INTEGER(I-N)
4892
4893C...PYTHIA commonblock: only used to provide read/write units and version.
4894 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4895 SAVE /PYPARS/
4896
4897C...User process initialization commonblock.
4898 INTEGER MAXPUP
4899 PARAMETER (MAXPUP=100)
4900 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4901 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4902 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4903 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4904 &LPRUP(MAXPUP)
4905 SAVE /HEPRUP/
4906
4907C...User process event common block.
4908 INTEGER MAXNUP
4909 PARAMETER (MAXNUP=500)
4910 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4911 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4912 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4913 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4914 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4915 SAVE /HEPEUP/
4916
4917C...Lines to read in assumed never longer than 200 characters.
4918 PARAMETER (MAXLEN=200)
4919 CHARACTER*(MAXLEN) STRING
4920
4921C...Format for reading lines.
4922 CHARACTER*6 STRFMT
4923 STRFMT='(A000)'
4924 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4925
4926C...Rewind initialization and event files.
4927 REWIND MSTP(161)
4928 REWIND MSTP(162)
4929
4930C...Write header info.
4931 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4932 WRITE(MSTP(163),'(A)') '<!--'
4933 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4934 &MSTP(181),'.',MSTP(182)
4935 WRITE(MSTP(163),'(A)') '-->'
4936
4937C...Read first line of initialization info and get number of processes.
4938 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4939 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4940 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4941
4942C...Copy initialization lines, omitting trailing blanks.
4943C...Embed in <init> ... </init> block.
4944 WRITE(MSTP(163),'(A)') '<init>'
4945 DO 140 IPR=0,NPRUP
4946 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4947 LEN=MAXLEN+1
4948 120 LEN=LEN-1
4949 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4950 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4951 140 CONTINUE
4952 WRITE(MSTP(163),'(A)') '</init>'
4953
4954C...Begin event loop. Read first line of event info or already done.
4955 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4956 200 CONTINUE
4957
4958C...Look at first line to know number of particles in event.
4959 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4960
4961C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4962 WRITE(MSTP(163),'(A)') '<event>'
4963 DO 240 I=0,NUP
4964 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4965 LEN=MAXLEN+1
4966 220 LEN=LEN-1
4967 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4968 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4969 240 CONTINUE
4970
4971C...Copy trailing comment lines - with a # in the first column - as is.
4972 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4973 IF(STRING(1:1).EQ.'#') THEN
4974 LEN=MAXLEN+1
4975 280 LEN=LEN-1
4976 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4977 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4978 GOTO 260
4979 ENDIF
4980
4981C..End the <event> block. Loop back to look for next event.
4982 WRITE(MSTP(163),'(A)') '</event>'
4983 GOTO 200
4984
4985C...Successfully reached end of event loop: write closing tag
4986C...and remove temporary intermediate files (unless asked not to).
4987 300 WRITE(MSTP(163),'(A)') '</event>'
4988 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4989 IF(MSTP(164).EQ.1) RETURN
4990 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4991 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
4992 RETURN
4993
4994C...Error exit.
4995 400 WRITE(*,*) ' PYLHEF file joining failed!'
4996
4997 RETURN
4998 END
4999
5000C*********************************************************************
5001
5002C...PYINRE
5003C...Calculates full and effective widths of gauge bosons, stores
5004C...masses and widths, rescales coefficients to be used for
5005C...resonance production generation.
5006
5007 SUBROUTINE PYINRE
5008
5009C...Double precision and integer declarations.
5010 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5011 IMPLICIT INTEGER(I-N)
5012 INTEGER PYK,PYCHGE,PYCOMP
5013C...Parameter statement to help give large particle numbers.
5014 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5015 &KEXCIT=4000000,KDIMEN=5000000)
5016C...Commonblocks.
5017 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5018 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5019 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5020 COMMON/PYDAT4/CHAF(500,2)
5021 CHARACTER CHAF*16
5022 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5023 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5024 COMMON/PYINT1/MINT(400),VINT(400)
5025 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5026 COMMON/PYINT4/MWID(500),WIDS(500,5)
5027 COMMON/PYINT6/PROC(0:500)
5028 CHARACTER PROC*28
5029 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5030 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5031 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5032C...Local arrays and data.
5033 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5034 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5035
5036C...Born level couplings in MSSM Higgs doublet sector.
5037 XW=PARU(102)
5038 XWV=XW
5039 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5040 XW1=1D0-XW
5041 IF(MSTP(4).EQ.2) THEN
5042 TANBE=PARU(141)
5043 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5044 SQMZ=PMAS(23,1)**2
5045 SQMW=PMAS(24,1)**2
5046 SQMH=PMAS(25,1)**2
5047 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5048 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5049 SQMHC=SQMA+SQMW
5050 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5051 WRITE(MSTU(11),5000)
5052 CALL PYSTOP(101)
5053 ENDIF
5054 PMAS(35,1)=SQRT(SQMHP)
5055 PMAS(36,1)=SQRT(SQMA)
5056 PMAS(37,1)=SQRT(SQMHC)
5057 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5058 & (SQMA-SQMZ)))
5059 BESU=ATAN(TANBE)
5060 PARU(142)=1D0
5061 PARU(143)=1D0
5062 PARU(161)=-SIN(ALSU)/COS(BESU)
5063 PARU(162)=COS(ALSU)/SIN(BESU)
5064 PARU(163)=PARU(161)
5065 PARU(164)=SIN(BESU-ALSU)
5066 PARU(165)=PARU(164)
5067 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5068 PARU(171)=COS(ALSU)/COS(BESU)
5069 PARU(172)=SIN(ALSU)/SIN(BESU)
5070 PARU(173)=PARU(171)
5071 PARU(174)=COS(BESU-ALSU)
5072 PARU(175)=PARU(174)
5073 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5074 & SIN(BESU+ALSU)
5075 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5076 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5077 PARU(181)=TANBE
5078 PARU(182)=1D0/TANBE
5079 PARU(183)=PARU(181)
5080 PARU(184)=0D0
5081 PARU(185)=PARU(184)
5082 PARU(186)=COS(BESU-ALSU)
5083 PARU(187)=SIN(BESU-ALSU)
5084 PARU(188)=PARU(186)
5085 PARU(189)=PARU(187)
5086 PARU(190)=0D0
5087 PARU(195)=COS(BESU-ALSU)
5088 ENDIF
5089
5090C...Reset effective widths of gauge bosons.
5091 DO 110 I=1,500
5092 DO 100 J=1,5
5093 WIDS(I,J)=1D0
5094 100 CONTINUE
5095 110 CONTINUE
5096
5097C...Order resonances by increasing mass (except Z0 and W+/-).
5098 NRES=0
5099 DO 140 KC=1,500
5100 KF=KCHG(KC,4)
5101 IF(KF.EQ.0) GOTO 140
5102 IF(MWID(KC).EQ.0) GOTO 140
5103 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5104 IF(MSTP(1).LE.3) GOTO 140
5105 ENDIF
5106 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5107 IF(IMSS(1).LE.0) GOTO 140
5108 ENDIF
5109 NRES=NRES+1
5110 PMRES=PMAS(KC,1)
5111 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5112 DO 120 I1=NRES-1,1,-1
5113 IF(PMRES.GE.PMORD(I1)) GOTO 130
5114 KCORD(I1+1)=KCORD(I1)
5115 PMORD(I1+1)=PMORD(I1)
5116 120 CONTINUE
5117 130 KCORD(I1+1)=KC
5118 PMORD(I1+1)=PMRES
5119 140 CONTINUE
5120
5121C...Loop over possible resonances.
5122 DO 180 I=1,NRES
5123 KC=KCORD(I)
5124 KF=KCHG(KC,4)
5125
5126C...Check that no fourth generation channels on by mistake.
5127 IF(MSTP(1).LE.3) THEN
5128 DO 150 J=1,MDCY(KC,3)
5129 IDC=J+MDCY(KC,2)-1
5130 KFA1=IABS(KFDP(IDC,1))
5131 KFA2=IABS(KFDP(IDC,2))
5132 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5133 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5134 & MDME(IDC,1)=-1
5135 150 CONTINUE
5136 ENDIF
5137
5138C...Check that no supersymmetric channels on by mistake.
5139 IF(IMSS(1).LE.0) THEN
5140 DO 160 J=1,MDCY(KC,3)
5141 IDC=J+MDCY(KC,2)-1
5142 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5143 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5144 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5145 & MDME(IDC,1)=-1
5146 160 CONTINUE
5147 ENDIF
5148
5149C...Find mass and evaluate width.
5150 PMR=PMAS(KC,1)
5151 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5152 IF(MWID(KC).EQ.3) MINT(63)=1
5153 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5154 MINT(51)=0
5155
5156C...Evaluate suppression factors due to non-simulated channels.
5157 IF(KCHG(KC,3).EQ.0) THEN
5158 WDTP0I=0D0
5159 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5160 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5161 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5162 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5163 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5164 WIDS(KC,3)=0D0
5165 WIDS(KC,4)=0D0
5166 WIDS(KC,5)=0D0
5167 ELSE
5168 IF(MWID(KC).EQ.3) MINT(63)=1
5169 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5170 MINT(51)=0
5171 WDTP0I=0D0
5172 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5173 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5174 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5175 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5176 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5177 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5178 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5179 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5180 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5181 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5182 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5183 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5184 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5185 ENDIF
5186
5187C...Set resonance widths and branching ratios;
5188C...also on/off switch for decays.
5189 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5190 PMAS(KC,2)=WDTP(0)
5191 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5192 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5193 DO 170 J=1,MDCY(KC,3)
5194 IDC=J+MDCY(KC,2)-1
5195 BRAT(IDC)=0D0
5196 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5197 170 CONTINUE
5198 ENDIF
5199 180 CONTINUE
5200
5201C...Flavours of leptoquark: redefine charge and name.
5202 KFLQQ=KFDP(MDCY(42,2),1)
5203 KFLQL=KFDP(MDCY(42,2),2)
5204 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5205 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5206 LL=1
5207 IF(IABS(KFLQL).EQ.13) LL=2
5208 IF(IABS(KFLQL).EQ.15) LL=3
5209 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5210 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5211 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5212
5213C...Special cases in treatment of gamma*/Z0: redefine process name.
5214 IF(MSTP(43).EQ.1) THEN
5215 PROC(1)='f + fbar -> gamma*'
5216 PROC(15)='f + fbar -> g + gamma*'
5217 PROC(19)='f + fbar -> gamma + gamma*'
5218 PROC(30)='f + g -> f + gamma*'
5219 PROC(35)='f + gamma -> f + gamma*'
5220 ELSEIF(MSTP(43).EQ.2) THEN
5221 PROC(1)='f + fbar -> Z0'
5222 PROC(15)='f + fbar -> g + Z0'
5223 PROC(19)='f + fbar -> gamma + Z0'
5224 PROC(30)='f + g -> f + Z0'
5225 PROC(35)='f + gamma -> f + Z0'
5226 ELSEIF(MSTP(43).EQ.3) THEN
5227 PROC(1)='f + fbar -> gamma*/Z0'
5228 PROC(15)='f + fbar -> g + gamma*/Z0'
5229 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5230 PROC(30)='f + g -> f + gamma*/Z0'
5231 PROC(35)='f + gamma -> f + gamma*/Z0'
5232 ENDIF
5233
5234C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5235 IF(MSTP(44).EQ.1) THEN
5236 PROC(141)='f + fbar -> gamma*'
5237 ELSEIF(MSTP(44).EQ.2) THEN
5238 PROC(141)='f + fbar -> Z0'
5239 ELSEIF(MSTP(44).EQ.3) THEN
5240 PROC(141)='f + fbar -> Z''0'
5241 ELSEIF(MSTP(44).EQ.4) THEN
5242 PROC(141)='f + fbar -> gamma*/Z0'
5243 ELSEIF(MSTP(44).EQ.5) THEN
5244 PROC(141)='f + fbar -> gamma*/Z''0'
5245 ELSEIF(MSTP(44).EQ.6) THEN
5246 PROC(141)='f + fbar -> Z0/Z''0'
5247 ELSEIF(MSTP(44).EQ.7) THEN
5248 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5249 ENDIF
5250
5251C...Special cases in treatment of WW -> WW: redefine process name.
5252 IF(MSTP(45).EQ.1) THEN
5253 PROC(77)='W+ + W+ -> W+ + W+'
5254 ELSEIF(MSTP(45).EQ.2) THEN
5255 PROC(77)='W+ + W- -> W+ + W-'
5256 ELSEIF(MSTP(45).EQ.3) THEN
5257 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5258 ENDIF
5259
5260C...Format for error information.
5261 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5262 &'combination'/1X,'Execution stopped!')
5263
5264 RETURN
5265 END
5266
5267C*********************************************************************
5268
5269C...PYINBM
5270C...Identifies the two incoming particles and the choice of frame.
5271
5272 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5273
5274C...Double precision and integer declarations.
5275 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5276 IMPLICIT INTEGER(I-N)
5277 INTEGER PYK,PYCHGE,PYCOMP
5278
5279C...User process initialization commonblock.
5280 INTEGER MAXPUP
5281 PARAMETER (MAXPUP=100)
5282 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5283 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5284 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5285 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5286 &LPRUP(MAXPUP)
5287 SAVE /HEPRUP/
5288
5289C...Commonblocks.
5290 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5293 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5294 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5295 COMMON/PYINT1/MINT(400),VINT(400)
5296 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5297
5298C...Local arrays, character variables and data.
5299 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5300 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5301 DIMENSION LEN(3),KCDE(39),PM(2)
5302 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5303 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5304 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5305 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5306 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5307 &'nu_taubar ','pi+ ','pi- ','n0 ',
5308 &'nbar0 ','p+ ','pbar- ','gamma ',
5309 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5310 &'xi- ','xi0 ','omega- ','pi0 ',
5311 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5312 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5313 &'k+ ','k- ','ks0 ','kl0 '/
5314 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5315 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5316 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5317
5318C...Store initial energy. Default frame.
5319 VINT(290)=WIN
5320 MINT(111)=0
5321
5322C...Special user process initialization; convert to normal input.
5323 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5324 MINT(111)=11
5325 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5326 CALL PYNAME(IDBMUP(1),CHNAME)
5327 CHBEAM=CHNAME(1:12)
5328 CALL PYNAME(IDBMUP(2),CHNAME)
5329 CHTARG=CHNAME(1:12)
5330 ENDIF
5331
5332C...Convert character variables to lowercase and find their length.
5333 CHCOM(1)=CHFRAM
5334 CHCOM(2)=CHBEAM
5335 CHCOM(3)=CHTARG
5336 DO 130 I=1,3
5337 LEN(I)=12
5338 DO 110 LL=12,1,-1
5339 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5340 DO 100 LA=1,26
5341 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5342 & CHALP(1)(LA:LA)
5343 100 CONTINUE
5344 110 CONTINUE
5345 CHIDNT(I)=CHCOM(I)
5346
5347C...Fix up bar, underscore and charge in particle name (if needed).
5348 DO 120 LL=1,10
5349 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5350 CHTEMP=CHIDNT(I)
5351 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5352 ENDIF
5353 120 CONTINUE
5354 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5355 CHTEMP=CHIDNT(I)
5356 CHIDNT(I)='nu_'//CHTEMP(3:7)
5357 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5358 CHIDNT(I)(1:3)='n0 '
5359 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5360 CHIDNT(I)(1:5)='nbar0'
5361 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5362 CHIDNT(I)(1:3)='p+ '
5363 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5364 & CHIDNT(I)(1:2).EQ.'p-') THEN
5365 CHIDNT(I)(1:5)='pbar-'
5366 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5367 CHIDNT(I)(7:7)='0'
5368 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5369 CHIDNT(I)(1:7)='reggeon'
5370 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5371 CHIDNT(I)(1:7)='pomeron'
5372 ENDIF
5373 130 CONTINUE
5374
5375C...Identify free initialization.
5376 IF(CHCOM(1)(1:2).EQ.'no') THEN
5377 MINT(65)=1
5378 RETURN
5379 ENDIF
5380
5381C...Identify incoming beam and target particles.
5382 DO 160 I=1,2
5383 DO 140 J=1,39
5384 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5385 140 CONTINUE
5386 PM(I)=PYMASS(MINT(10+I))
5387 VINT(2+I)=PM(I)
5388 MINT(140+I)=0
5389 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5390 CHTEMP=CHIDNT(I+1)(7:12)//' '
5391 DO 150 J=1,12
5392 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5393 150 CONTINUE
5394 PM(I)=PYMASS(MINT(140+I))
5395 VINT(302+I)=PM(I)
5396 ENDIF
5397 160 CONTINUE
5398 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5399 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5400 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5401
5402C...Identify choice of frame and input energies.
5403 CHINIT=' '
5404
5405C...Events defined in the CM frame.
5406 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5407 MINT(111)=1
5408 S=WIN**2
5409 IF(MSTP(122).GE.1) THEN
5410 IF(CHCOM(2)(1:1).NE.'e') THEN
5411 LOFFS=(31-(LEN(2)+LEN(3)))/2
5412 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5413 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5414 & ' collider'//' '
5415 ELSE
5416 LOFFS=(30-(LEN(2)+LEN(3)))/2
5417 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5418 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5419 & ' collider'//' '
5420 ENDIF
5421 WRITE(MSTU(11),5200) CHINIT
5422 WRITE(MSTU(11),5300) WIN
5423 ENDIF
5424
5425C...Events defined in fixed target frame.
5426 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5427 MINT(111)=2
5428 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5429 IF(MSTP(122).GE.1) THEN
5430 LOFFS=(29-(LEN(2)+LEN(3)))/2
5431 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5432 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5433 & ' fixed target'//' '
5434 WRITE(MSTU(11),5200) CHINIT
5435 WRITE(MSTU(11),5400) WIN
5436 WRITE(MSTU(11),5500) SQRT(S)
5437 ENDIF
5438
5439C...Frame defined by user three-vectors.
5440 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5441 MINT(111)=3
5442 P(1,5)=PM(1)
5443 P(2,5)=PM(2)
5444 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5445 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5446 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5447 & (P(1,3)+P(2,3))**2
5448 IF(MSTP(122).GE.1) THEN
5449 LOFFS=(22-(LEN(2)+LEN(3)))/2
5450 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5451 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5452 & ' user configuration'//' '
5453 WRITE(MSTU(11),5200) CHINIT
5454 WRITE(MSTU(11),5600)
5455 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5456 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5457 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5458 ENDIF
5459
5460C...Frame defined by user four-vectors.
5461 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5462 MINT(111)=4
5463 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5464 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5465 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5466 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5467 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5468 & (P(1,3)+P(2,3))**2
5469 IF(MSTP(122).GE.1) THEN
5470 LOFFS=(22-(LEN(2)+LEN(3)))/2
5471 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5472 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5473 & ' user configuration'//' '
5474 WRITE(MSTU(11),5200) CHINIT
5475 WRITE(MSTU(11),5600)
5476 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5477 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5478 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5479 ENDIF
5480
5481C...Frame defined by user five-vectors.
5482 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5483 MINT(111)=5
5484 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5485 & (P(1,3)+P(2,3))**2
5486 IF(MSTP(122).GE.1) THEN
5487 LOFFS=(22-(LEN(2)+LEN(3)))/2
5488 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5489 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5490 & ' user configuration'//' '
5491 WRITE(MSTU(11),5200) CHINIT
5492 WRITE(MSTU(11),5600)
5493 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5494 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5495 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5496 ENDIF
5497
5498C...Frame defined by HEPRUP common block.
5499 ELSEIF(MINT(111).GE.11) THEN
5500 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5501 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5502 IF(MSTP(122).GE.1) THEN
5503 LOFFS=(22-(LEN(2)+LEN(3)))/2
5504 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5505 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5506 & ' user configuration'//' '
5507 WRITE(MSTU(11),5200) CHINIT
5508 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5509 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5510 ENDIF
5511
5512C...Unknown frame. Error for too low CM energy.
5513 ELSE
5514 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5515 CALL PYSTOP(7)
5516 ENDIF
5517 IF(S.LT.PARP(2)**2) THEN
5518 WRITE(MSTU(11),5900) SQRT(S)
5519 CALL PYSTOP(7)
5520 ENDIF
5521
5522C...Formats for initialization and error information.
5523 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5524 &1X,'Execution stopped!')
5525 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5526 &1X,'Execution stopped!')
5527 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5528 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5529 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5530 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5531 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5532 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5533 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5534 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5535 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5536 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5537 &1X,'Execution stopped!')
5538 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5539 &'generation.'/1X,'Execution stopped!')
5540 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5541 &'GeV beam energies',13X,'I')
5542
5543 RETURN
5544 END
5545
5546C*********************************************************************
5547
5548C...PYINKI
5549C...Sets up kinematics, including rotations and boosts to/from CM frame.
5550
5551 SUBROUTINE PYINKI(MODKI)
5552
5553C...Double precision and integer declarations.
5554 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5555 IMPLICIT INTEGER(I-N)
5556 INTEGER PYK,PYCHGE,PYCOMP
5557
5558C...User process initialization commonblock.
5559 INTEGER MAXPUP
5560 PARAMETER (MAXPUP=100)
5561 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5562 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5563 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5564 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5565 &LPRUP(MAXPUP)
5566 SAVE /HEPRUP/
5567
5568C...Commonblocks.
5569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5571 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5572 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5573 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5574 COMMON/PYINT1/MINT(400),VINT(400)
5575 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5576
5577C...Set initial flavour state.
5578 N=2
5579 DO 100 I=1,2
5580 K(I,1)=1
5581 K(I,2)=MINT(10+I)
5582 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5583 100 CONTINUE
5584
5585C...Reset boost. Do kinematics for various cases.
5586 DO 110 J=6,10
5587 VINT(J)=0D0
5588 110 CONTINUE
5589
5590C...Set up kinematics for events defined in CM frame.
5591 IF(MINT(111).EQ.1) THEN
5592 WIN=VINT(290)
5593 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5594 S=WIN**2
5595 P(1,5)=VINT(3)
5596 P(2,5)=VINT(4)
5597 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5598 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5599 P(1,1)=0D0
5600 P(1,2)=0D0
5601 P(2,1)=0D0
5602 P(2,2)=0D0
5603 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5604 & (4D0*S))
5605 P(2,3)=-P(1,3)
5606 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5607 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5608
5609C...Set up kinematics for fixed target events.
5610 ELSEIF(MINT(111).EQ.2) THEN
5611 WIN=VINT(290)
5612 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5613 P(1,5)=VINT(3)
5614 P(2,5)=VINT(4)
5615 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5616 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5617 P(1,1)=0D0
5618 P(1,2)=0D0
5619 P(2,1)=0D0
5620 P(2,2)=0D0
5621 P(1,3)=WIN
5622 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5623 P(2,3)=0D0
5624 P(2,4)=P(2,5)
5625 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5626 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5627 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5628
5629C...Set up kinematics for events in user-defined frame.
5630 ELSEIF(MINT(111).EQ.3) THEN
5631 P(1,5)=VINT(3)
5632 P(2,5)=VINT(4)
5633 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5634 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5635 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5636 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5637 DO 120 J=1,3
5638 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5639 120 CONTINUE
5640 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5641 VINT(7)=PYANGL(P(1,1),P(1,2))
5642 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5643 VINT(6)=PYANGL(P(1,3),P(1,1))
5644 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5645 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5646
5647C...Set up kinematics for events with user-defined four-vectors.
5648 ELSEIF(MINT(111).EQ.4) THEN
5649 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5650 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5651 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5652 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5653 DO 130 J=1,3
5654 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5655 130 CONTINUE
5656 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5657 VINT(7)=PYANGL(P(1,1),P(1,2))
5658 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5659 VINT(6)=PYANGL(P(1,3),P(1,1))
5660 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5661 S=(P(1,4)+P(2,4))**2
5662
5663C...Set up kinematics for events with user-defined five-vectors.
5664 ELSEIF(MINT(111).EQ.5) THEN
5665 DO 140 J=1,3
5666 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5667 140 CONTINUE
5668 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5669 VINT(7)=PYANGL(P(1,1),P(1,2))
5670 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5671 VINT(6)=PYANGL(P(1,3),P(1,1))
5672 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5673 S=(P(1,4)+P(2,4))**2
5674
5675C...Set up kinematics for events with external user processes.
5676 ELSEIF(MINT(111).GE.11) THEN
5677 P(1,5)=VINT(3)
5678 P(2,5)=VINT(4)
5679 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5680 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5681 P(1,1)=0D0
5682 P(1,2)=0D0
5683 P(2,1)=0D0
5684 P(2,2)=0D0
5685 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5686 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5687 P(1,4)=EBMUP(1)
5688 P(2,4)=EBMUP(2)
5689 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5690 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5691 S=(P(1,4)+P(2,4))**2
5692 ENDIF
5693
5694C...Return or error for too low CM energy.
5695 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5696 IF(MSTP(172).LE.1) THEN
5697 CALL PYERRM(23,
5698 & '(PYINKI:) too low invariant mass in this event')
5699 ELSE
5700 MSTI(61)=1
5701 RETURN
5702 ENDIF
5703 ENDIF
5704
5705C...Save information on incoming particles.
5706 VINT(1)=SQRT(S)
5707 VINT(2)=S
5708 IF(MINT(111).GE.4) THEN
5709 IF(MINT(141).EQ.0) THEN
5710 VINT(3)=P(1,5)
5711 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5712 ELSE
5713 VINT(303)=P(1,5)
5714 ENDIF
5715 IF(MINT(142).EQ.0) THEN
5716 VINT(4)=P(2,5)
5717 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5718 ELSE
5719 VINT(304)=P(2,5)
5720 ENDIF
5721 ENDIF
5722 VINT(5)=P(1,3)
5723 IF(MODKI.EQ.0) VINT(289)=S
5724 DO 150 J=1,5
5725 V(1,J)=0D0
5726 V(2,J)=0D0
5727 VINT(290+J)=P(1,J)
5728 VINT(295+J)=P(2,J)
5729 150 CONTINUE
5730
5731C...Store pT cut-off and related constants to be used in generation.
5732 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5733 IF(MSTP(82).LE.1) THEN
5734 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5735 ELSE
5736 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5737 ENDIF
5738 VINT(149)=4D0*PTMN**2/S
5739 VINT(154)=PTMN
5740
5741 RETURN
5742 END
5743
5744C*********************************************************************
5745
5746C...PYINPR
5747C...Selects partonic subprocesses to be included in the simulation.
5748
5749 SUBROUTINE PYINPR
5750
5751C...Double precision and integer declarations.
5752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5753 IMPLICIT INTEGER(I-N)
5754 INTEGER PYK,PYCHGE,PYCOMP
5755
5756C...User process initialization commonblock.
5757 INTEGER MAXPUP
5758 PARAMETER (MAXPUP=100)
5759 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5760 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5761 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5762 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5763 &LPRUP(MAXPUP)
5764 SAVE /HEPRUP/
5765
5766C...Commonblocks and character variables.
5767 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5768 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5769 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5770 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5771 COMMON/PYINT1/MINT(400),VINT(400)
5772 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5773 COMMON/PYINT6/PROC(0:500)
5774 CHARACTER PROC*28
5775 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5776 &/PYINT6/
5777 CHARACTER CHIPR*10
5778
5779C...Reset processes to be included.
5780 IF(MSEL.NE.0) THEN
5781 DO 100 I=1,500
5782 MSUB(I)=0
5783 100 CONTINUE
5784 ENDIF
5785
5786C...Set running pTmin scale.
5787 IF(MSTP(82).LE.1) THEN
5788 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5789 ELSE
5790 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5791 ENDIF
5792
5793C...Begin by assuming incoming photon to enter subprocess.
5794 IF(MINT(11).EQ.22) MINT(15)=22
5795 IF(MINT(12).EQ.22) MINT(16)=22
5796
5797C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5798 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5799 MSUB(10)=1
5800 MINT(123)=MINT(122)+1
5801
5802C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5803C...allow mixture.
5804C...Here also set a few parameters otherwise normally not touched.
5805 ELSEIF(MINT(121).GT.1) THEN
5806
5807C...Parton distributions dampened at small Q2; go to low energies,
5808C...alpha_s <1; no minimum pT cut-off a priori.
5809 IF(MSTP(18).EQ.2) THEN
5810 MSTP(57)=3
5811 PARP(2)=2D0
5812 PARU(115)=1D0
5813 CKIN(5)=0.2D0
5814 CKIN(6)=0.2D0
5815 ENDIF
5816
5817C...Define pT cut-off parameters and whether run involves low-pT.
5818 PTMVMD=PTMRUN
5819 VINT(154)=PTMVMD
5820 PTMDIR=PTMVMD
5821 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5822 PTMANO=PTMVMD
5823 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5824 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5825 IPTL=1
5826 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5827 IF(MSEL.EQ.2) IPTL=1
5828
5829C...Set up for p/gamma * gamma; real or virtual photons.
5830 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5831 & MSTP(14).EQ.30)) THEN
5832
5833C...Set up for p/VMD * VMD.
5834 IF(MINT(122).EQ.1) THEN
5835 MINT(123)=2
5836 MSUB(11)=1
5837 MSUB(12)=1
5838 MSUB(13)=1
5839 MSUB(28)=1
5840 MSUB(53)=1
5841 MSUB(68)=1
5842 IF(IPTL.EQ.1) MSUB(95)=1
5843 IF(MSEL.EQ.2) THEN
5844 MSUB(91)=1
5845 MSUB(92)=1
5846 MSUB(93)=1
5847 MSUB(94)=1
5848 ENDIF
5849 IF(IPTL.EQ.1) CKIN(3)=0D0
5850
5851C...Set up for p/VMD * direct gamma.
5852 ELSEIF(MINT(122).EQ.2) THEN
5853 MINT(123)=0
5854 IF(MINT(121).EQ.6) MINT(123)=5
5855 MSUB(131)=1
5856 MSUB(132)=1
5857 MSUB(135)=1
5858 MSUB(136)=1
5859 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5860
5861C...Set up for p/VMD * anomalous gamma.
5862 ELSEIF(MINT(122).EQ.3) THEN
5863 MINT(123)=3
5864 IF(MINT(121).EQ.6) MINT(123)=7
5865 MSUB(11)=1
5866 MSUB(12)=1
5867 MSUB(13)=1
5868 MSUB(28)=1
5869 MSUB(53)=1
5870 MSUB(68)=1
5871 IF(IPTL.EQ.1) MSUB(95)=1
5872 IF(MSEL.EQ.2) THEN
5873 MSUB(91)=1
5874 MSUB(92)=1
5875 MSUB(93)=1
5876 MSUB(94)=1
5877 ENDIF
5878 IF(IPTL.EQ.1) CKIN(3)=0D0
5879
5880C...Set up for DIS * p.
5881 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5882 & IABS(MINT(12)).GT.100)) THEN
5883 MINT(123)=8
5884 IF(IPTL.EQ.1) MSUB(99)=1
5885
5886C...Set up for direct * direct gamma (switch off leptons).
5887 ELSEIF(MINT(122).EQ.4) THEN
5888 MINT(123)=0
5889 MSUB(137)=1
5890 MSUB(138)=1
5891 MSUB(139)=1
5892 MSUB(140)=1
5893 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5894 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5895 110 CONTINUE
5896 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5897
5898C...Set up for direct * anomalous gamma.
5899 ELSEIF(MINT(122).EQ.5) THEN
5900 MINT(123)=6
5901 MSUB(131)=1
5902 MSUB(132)=1
5903 MSUB(135)=1
5904 MSUB(136)=1
5905 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5906
5907C...Set up for anomalous * anomalous gamma.
5908 ELSEIF(MINT(122).EQ.6) THEN
5909 MINT(123)=3
5910 MSUB(11)=1
5911 MSUB(12)=1
5912 MSUB(13)=1
5913 MSUB(28)=1
5914 MSUB(53)=1
5915 MSUB(68)=1
5916 IF(IPTL.EQ.1) MSUB(95)=1
5917 IF(MSEL.EQ.2) THEN
5918 MSUB(91)=1
5919 MSUB(92)=1
5920 MSUB(93)=1
5921 MSUB(94)=1
5922 ENDIF
5923 IF(IPTL.EQ.1) CKIN(3)=0D0
5924 ENDIF
5925
5926C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5927 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5928
5929C...Set up for direct * direct gamma (switch off leptons).
5930 IF(MINT(122).EQ.1) THEN
5931 MINT(123)=0
5932 MSUB(137)=1
5933 MSUB(138)=1
5934 MSUB(139)=1
5935 MSUB(140)=1
5936 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5937 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5938 120 CONTINUE
5939 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5940
5941C...Set up for direct * VMD and VMD * direct gamma.
5942 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5943 MINT(123)=5
5944 MSUB(131)=1
5945 MSUB(132)=1
5946 MSUB(135)=1
5947 MSUB(136)=1
5948 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5949
5950C...Set up for direct * anomalous and anomalous * direct gamma.
5951 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5952 MINT(123)=6
5953 MSUB(131)=1
5954 MSUB(132)=1
5955 MSUB(135)=1
5956 MSUB(136)=1
5957 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5958
5959C...Set up for VMD*VMD.
5960 ELSEIF(MINT(122).EQ.5) THEN
5961 MINT(123)=2
5962 MSUB(11)=1
5963 MSUB(12)=1
5964 MSUB(13)=1
5965 MSUB(28)=1
5966 MSUB(53)=1
5967 MSUB(68)=1
5968 IF(IPTL.EQ.1) MSUB(95)=1
5969 IF(MSEL.EQ.2) THEN
5970 MSUB(91)=1
5971 MSUB(92)=1
5972 MSUB(93)=1
5973 MSUB(94)=1
5974 ENDIF
5975 IF(IPTL.EQ.1) CKIN(3)=0D0
5976
5977C...Set up for VMD * anomalous and anomalous * VMD gamma.
5978 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5979 MINT(123)=7
5980 MSUB(11)=1
5981 MSUB(12)=1
5982 MSUB(13)=1
5983 MSUB(28)=1
5984 MSUB(53)=1
5985 MSUB(68)=1
5986 IF(IPTL.EQ.1) MSUB(95)=1
5987 IF(MSEL.EQ.2) THEN
5988 MSUB(91)=1
5989 MSUB(92)=1
5990 MSUB(93)=1
5991 MSUB(94)=1
5992 ENDIF
5993 IF(IPTL.EQ.1) CKIN(3)=0D0
5994
5995C...Set up for anomalous * anomalous gamma.
5996 ELSEIF(MINT(122).EQ.9) THEN
5997 MINT(123)=3
5998 MSUB(11)=1
5999 MSUB(12)=1
6000 MSUB(13)=1
6001 MSUB(28)=1
6002 MSUB(53)=1
6003 MSUB(68)=1
6004 IF(IPTL.EQ.1) MSUB(95)=1
6005 IF(MSEL.EQ.2) THEN
6006 MSUB(91)=1
6007 MSUB(92)=1
6008 MSUB(93)=1
6009 MSUB(94)=1
6010 ENDIF
6011 IF(IPTL.EQ.1) CKIN(3)=0D0
6012
6013C...Set up for DIS * VMD and VMD * DIS gamma.
6014 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6015 MINT(123)=8
6016 IF(IPTL.EQ.1) MSUB(99)=1
6017
6018C...Set up for DIS * anomalous and anomalous * DIS gamma.
6019 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6020 MINT(123)=9
6021 IF(IPTL.EQ.1) MSUB(99)=1
6022 ENDIF
6023
6024C...Set up for gamma* * p; virtual photons = dir, res.
6025 ELSEIF(MINT(121).EQ.2) THEN
6026
6027C...Set up for direct * p.
6028 IF(MINT(122).EQ.1) THEN
6029 MINT(123)=0
6030 MSUB(131)=1
6031 MSUB(132)=1
6032 MSUB(135)=1
6033 MSUB(136)=1
6034 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6035
6036C...Set up for resolved * p.
6037 ELSEIF(MINT(122).EQ.2) THEN
6038 MINT(123)=1
6039 MSUB(11)=1
6040 MSUB(12)=1
6041 MSUB(13)=1
6042 MSUB(28)=1
6043 MSUB(53)=1
6044 MSUB(68)=1
6045 IF(IPTL.EQ.1) MSUB(95)=1
6046 IF(MSEL.EQ.2) THEN
6047 MSUB(91)=1
6048 MSUB(92)=1
6049 MSUB(93)=1
6050 MSUB(94)=1
6051 ENDIF
6052 IF(IPTL.EQ.1) CKIN(3)=0D0
6053 ENDIF
6054
6055C...Set up for gamma* * gamma*; virtual photons = dir, res.
6056 ELSEIF(MINT(121).EQ.4) THEN
6057
6058C...Set up for direct * direct gamma (switch off leptons).
6059 IF(MINT(122).EQ.1) THEN
6060 MINT(123)=0
6061 MSUB(137)=1
6062 MSUB(138)=1
6063 MSUB(139)=1
6064 MSUB(140)=1
6065 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6066 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6067 130 CONTINUE
6068 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6069
6070C...Set up for direct * resolved and resolved * direct gamma.
6071 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6072 MINT(123)=5
6073 MSUB(131)=1
6074 MSUB(132)=1
6075 MSUB(135)=1
6076 MSUB(136)=1
6077 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6078
6079C...Set up for resolved * resolved gamma.
6080 ELSEIF(MINT(122).EQ.4) THEN
6081 MINT(123)=2
6082 MSUB(11)=1
6083 MSUB(12)=1
6084 MSUB(13)=1
6085 MSUB(28)=1
6086 MSUB(53)=1
6087 MSUB(68)=1
6088 IF(IPTL.EQ.1) MSUB(95)=1
6089 IF(MSEL.EQ.2) THEN
6090 MSUB(91)=1
6091 MSUB(92)=1
6092 MSUB(93)=1
6093 MSUB(94)=1
6094 ENDIF
6095 IF(IPTL.EQ.1) CKIN(3)=0D0
6096 ENDIF
6097
6098C...End of special set up for gamma-p and gamma-gamma.
6099 ENDIF
6100 CKIN(1)=2D0*CKIN(3)
6101 ENDIF
6102
6103C...Flavour information for individual beams.
6104 DO 140 I=1,2
6105 MINT(40+I)=1
6106 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6107 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6108 MINT(44+I)=MINT(40+I)
6109 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6110 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6111 140 CONTINUE
6112
6113C...If two real gammas, whereof one direct, pick the first.
6114C...For two virtual photons, keep requested order.
6115 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6116 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6117 MINT(41)=1
6118 MINT(45)=1
6119 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6120 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6121 MINT(41)=1
6122 MINT(45)=1
6123 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6124 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6125 MINT(42)=1
6126 MINT(46)=1
6127 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6128 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6129 MINT(41)=1
6130 MINT(45)=1
6131 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6132 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6133 MINT(42)=1
6134 MINT(46)=1
6135 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6136 MINT(41)=1
6137 MINT(45)=1
6138 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6139 MINT(42)=1
6140 MINT(46)=1
6141 ENDIF
6142 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6143 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6144 IF(MINT(11).EQ.22) THEN
6145 MINT(41)=1
6146 MINT(45)=1
6147 ELSE
6148 MINT(42)=1
6149 MINT(46)=1
6150 ENDIF
6151 ENDIF
6152 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6153 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6154 ENDIF
6155
6156C...Flavour information on combination of incoming particles.
6157 MINT(43)=2*MINT(41)+MINT(42)-2
6158 MINT(44)=MINT(43)
6159 IF(MINT(123).LE.0) THEN
6160 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6161 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6162 ELSEIF(MINT(123).LE.3) THEN
6163 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6164 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6165 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6166 MINT(43)=4
6167 MINT(44)=1
6168 ENDIF
6169 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6170 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6171 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6172 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6173 MINT(50)=0
6174 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6175 MINT(107)=0
6176 MINT(108)=0
6177 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6178 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6179 & MINT(107)=2
6180 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6181 & MINT(107)=3
6182 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6183 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6184 & MINT(122).EQ.10) MINT(108)=2
6185 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6186 & MINT(122).EQ.11) MINT(108)=3
6187 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6188 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6189 IF(MINT(122).GE.3) MINT(107)=1
6190 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6191 ELSEIF(MINT(121).EQ.2) THEN
6192 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6193 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6194 ELSE
6195 IF(MINT(11).EQ.22) THEN
6196 MINT(107)=MINT(123)
6197 IF(MINT(123).GE.4) MINT(107)=0
6198 IF(MINT(123).EQ.7) MINT(107)=2
6199 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6200 IF(MSTP(14).EQ.28) MINT(107)=2
6201 IF(MSTP(14).EQ.29) MINT(107)=3
6202 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6203 & MINT(107)=4
6204 ENDIF
6205 IF(MINT(12).EQ.22) THEN
6206 MINT(108)=MINT(123)
6207 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6208 IF(MINT(123).EQ.7) MINT(108)=3
6209 IF(MSTP(14).EQ.26) MINT(108)=2
6210 IF(MSTP(14).EQ.27) MINT(108)=3
6211 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6212 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6213 & MINT(108)=4
6214 ENDIF
6215 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6216 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6217 MINTTP=MINT(107)
6218 MINT(107)=MINT(108)
6219 MINT(108)=MINTTP
6220 ENDIF
6221 ENDIF
6222 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6223 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6224
6225C...Select default processes according to incoming beams
6226C...(already done for gamma-p and gamma-gamma with
6227C...MSTP(14) = 10, 20, 25 or 30).
6228 IF(MINT(121).GT.1) THEN
6229 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6230
6231 IF(MINT(43).EQ.1) THEN
6232C...Lepton + lepton -> gamma/Z0 or W.
6233 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6234 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6235
6236 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6237 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6238C...Unresolved photon + lepton: Compton scattering.
6239 MSUB(133)=1
6240 MSUB(134)=1
6241
6242 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6243 & .OR.MINT(12).EQ.22)) THEN
6244C...DIS as pure gamma* + f -> f process.
6245 MSUB(99)=1
6246
6247 ELSEIF(MINT(43).LE.3) THEN
6248C...Lepton + hadron: deep inelastic scattering.
6249 MSUB(10)=1
6250
6251 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6252 & MINT(12).EQ.22) THEN
6253C...Two unresolved photons: fermion pair production,
6254C...exclude lepton pairs.
6255 DO 150 ISUB=137,140
6256 MSUB(ISUB)=1
6257 150 CONTINUE
6258 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6259 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6260 160 CONTINUE
6261 PTMDIR=PTMRUN
6262 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6263 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6264 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6265
6266 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6267 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6268 & MINT(12).EQ.22)) THEN
6269C...Unresolved photon + hadron: photon-parton scattering.
6270 DO 170 ISUB=131,136
6271 MSUB(ISUB)=1
6272 170 CONTINUE
6273
6274 ELSEIF(MSEL.EQ.1) THEN
6275C...High-pT QCD processes:
6276 MSUB(11)=1
6277 MSUB(12)=1
6278 MSUB(13)=1
6279 MSUB(28)=1
6280 MSUB(53)=1
6281 MSUB(68)=1
6282 PTMN=PTMRUN
6283 VINT(154)=PTMN
6284 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6285 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6286
6287 ELSE
6288C...All QCD processes:
6289 MSUB(11)=1
6290 MSUB(12)=1
6291 MSUB(13)=1
6292 MSUB(28)=1
6293 MSUB(53)=1
6294 MSUB(68)=1
6295 MSUB(91)=1
6296 MSUB(92)=1
6297 MSUB(93)=1
6298 MSUB(94)=1
6299 MSUB(95)=1
6300 ENDIF
6301
6302 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6303C...Heavy quark production.
6304 MSUB(81)=1
6305 MSUB(82)=1
6306 MSUB(84)=1
6307 DO 180 J=1,MIN(8,MDCY(21,3))
6308 MDME(MDCY(21,2)+J-1,1)=0
6309 180 CONTINUE
6310 MDME(MDCY(21,2)+MSEL-1,1)=1
6311 MSUB(85)=1
6312 DO 190 J=1,MIN(12,MDCY(22,3))
6313 MDME(MDCY(22,2)+J-1,1)=0
6314 190 CONTINUE
6315 MDME(MDCY(22,2)+MSEL-1,1)=1
6316
6317 ELSEIF(MSEL.EQ.10) THEN
6318C...Prompt photon production:
6319 MSUB(14)=1
6320 MSUB(18)=1
6321 MSUB(29)=1
6322
6323 ELSEIF(MSEL.EQ.11) THEN
6324C...Z0/gamma* production:
6325 MSUB(1)=1
6326
6327 ELSEIF(MSEL.EQ.12) THEN
6328C...W+/- production:
6329 MSUB(2)=1
6330
6331 ELSEIF(MSEL.EQ.13) THEN
6332C...Z0 + jet:
6333 MSUB(15)=1
6334 MSUB(30)=1
6335
6336 ELSEIF(MSEL.EQ.14) THEN
6337C...W+/- + jet:
6338 MSUB(16)=1
6339 MSUB(31)=1
6340
6341 ELSEIF(MSEL.EQ.15) THEN
6342C...Z0 & W+/- pair production:
6343 MSUB(19)=1
6344 MSUB(20)=1
6345 MSUB(22)=1
6346 MSUB(23)=1
6347 MSUB(25)=1
6348
6349 ELSEIF(MSEL.EQ.16) THEN
6350C...h0 production:
6351 MSUB(3)=1
6352 MSUB(102)=1
6353 MSUB(103)=1
6354 MSUB(123)=1
6355 MSUB(124)=1
6356
6357 ELSEIF(MSEL.EQ.17) THEN
6358C...h0 & Z0 or W+/- pair production:
6359 MSUB(24)=1
6360 MSUB(26)=1
6361
6362 ELSEIF(MSEL.EQ.18) THEN
6363C...h0 production; interesting processes in e+e-.
6364 MSUB(24)=1
6365 MSUB(103)=1
6366 MSUB(123)=1
6367 MSUB(124)=1
6368
6369 ELSEIF(MSEL.EQ.19) THEN
6370C...h0, H0 and A0 production; interesting processes in e+e-.
6371 MSUB(24)=1
6372 MSUB(103)=1
6373 MSUB(123)=1
6374 MSUB(124)=1
6375 MSUB(153)=1
6376 MSUB(171)=1
6377 MSUB(173)=1
6378 MSUB(174)=1
6379 MSUB(158)=1
6380 MSUB(176)=1
6381 MSUB(178)=1
6382 MSUB(179)=1
6383
6384 ELSEIF(MSEL.EQ.21) THEN
6385C...Z'0 production:
6386 MSUB(141)=1
6387
6388 ELSEIF(MSEL.EQ.22) THEN
6389C...W'+/- production:
6390 MSUB(142)=1
6391
6392 ELSEIF(MSEL.EQ.23) THEN
6393C...H+/- production:
6394 MSUB(143)=1
6395
6396 ELSEIF(MSEL.EQ.24) THEN
6397C...R production:
6398 MSUB(144)=1
6399
6400 ELSEIF(MSEL.EQ.25) THEN
6401C...LQ (leptoquark) production.
6402 MSUB(145)=1
6403 MSUB(162)=1
6404 MSUB(163)=1
6405 MSUB(164)=1
6406
6407 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6408C...Production of one heavy quark (W exchange):
6409 MSUB(83)=1
6410 DO 200 J=1,MIN(8,MDCY(21,3))
6411 MDME(MDCY(21,2)+J-1,1)=0
6412 200 CONTINUE
6413 MDME(MDCY(21,2)+MSEL-31,1)=1
6414
6415CMRENNA++Define SUSY alternatives.
6416 ELSEIF(MSEL.EQ.39) THEN
6417C...Turn on all SUSY processes.
6418 IF(MINT(43).EQ.4) THEN
6419C...Hadron-hadron processes.
6420 DO 210 I=201,301
6421 IF(ISET(I).GE.0) MSUB(I)=1
6422 210 CONTINUE
6423 ELSEIF(MINT(43).EQ.1) THEN
6424C...Lepton-lepton processes: QED production of squarks.
6425 DO 220 I=201,214
6426 MSUB(I)=1
6427 220 CONTINUE
6428 MSUB(210)=0
6429 MSUB(211)=0
6430 MSUB(212)=0
6431 DO 230 I=216,228
6432 MSUB(I)=1
6433 230 CONTINUE
6434 DO 240 I=261,263
6435 MSUB(I)=1
6436 240 CONTINUE
6437 MSUB(277)=1
6438 MSUB(278)=1
6439 ENDIF
6440
6441 ELSEIF(MSEL.EQ.40) THEN
6442C...Gluinos and squarks.
6443 IF(MINT(43).EQ.4) THEN
6444 MSUB(243)=1
6445 MSUB(244)=1
6446 MSUB(258)=1
6447 MSUB(259)=1
6448 MSUB(261)=1
6449 MSUB(262)=1
6450 MSUB(264)=1
6451 MSUB(265)=1
6452 DO 250 I=271,296
6453 MSUB(I)=1
6454 250 CONTINUE
6455 ELSEIF(MINT(43).EQ.1) THEN
6456 MSUB(277)=1
6457 MSUB(278)=1
6458 ENDIF
6459
6460 ELSEIF(MSEL.EQ.41) THEN
6461C...Stop production.
6462 MSUB(261)=1
6463 MSUB(262)=1
6464 MSUB(263)=1
6465 IF(MINT(43).EQ.4) THEN
6466 MSUB(264)=1
6467 MSUB(265)=1
6468 ENDIF
6469
6470 ELSEIF(MSEL.EQ.42) THEN
6471C...Slepton production.
6472 DO 260 I=201,214
6473 MSUB(I)=1
6474 260 CONTINUE
6475 IF(MINT(43).NE.4) THEN
6476 MSUB(210)=0
6477 MSUB(211)=0
6478 MSUB(212)=0
6479 ENDIF
6480
6481 ELSEIF(MSEL.EQ.43) THEN
6482C...Neutralino/Chargino + Gluino/Squark.
6483 IF(MINT(43).EQ.4) THEN
6484 DO 270 I=237,242
6485 MSUB(I)=1
6486 270 CONTINUE
6487 DO 280 I=246,254
6488 MSUB(I)=1
6489 280 CONTINUE
6490 MSUB(256)=1
6491 ENDIF
6492
6493 ELSEIF(MSEL.EQ.44) THEN
6494C...Neutralino/Chargino pair production.
6495 IF(MINT(43).EQ.4) THEN
6496 DO 290 I=216,236
6497 MSUB(I)=1
6498 290 CONTINUE
6499 ELSEIF(MINT(43).EQ.1) THEN
6500 DO 300 I=216,228
6501 MSUB(I)=1
6502 300 CONTINUE
6503 ENDIF
6504
6505 ELSEIF(MSEL.EQ.45) THEN
6506C...Sbottom production.
6507 MSUB(287)=1
6508 MSUB(288)=1
6509 IF(MINT(43).EQ.4) THEN
6510 DO 310 I=281,296
6511 MSUB(I)=1
6512 310 CONTINUE
6513 ENDIF
6514
6515 ELSEIF(MSEL.EQ.50) THEN
6516C...Pair production of technipions and gauge bosons.
6517 DO 320 I=361,368
6518 MSUB(I)=1
6519 320 CONTINUE
6520 IF(MINT(43).EQ.4) THEN
6521 DO 330 I=370,377
6522 MSUB(I)=1
6523 330 CONTINUE
6524 ENDIF
6525
6526 ELSEIF(MSEL.EQ.51) THEN
6527C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6528 DO 340 I=381,386
6529 MSUB(I)=1
6530 340 CONTINUE
6531
6532 ELSEIF(MSEL.EQ.61) THEN
6533C...Charmonium production in colour octet model, with recoiling parton.
6534 DO 342 I=421,439
6535 MSUB(I)=1
6536 342 CONTINUE
6537
6538 ELSEIF(MSEL.EQ.62) THEN
6539C...Bottomonium production in colour octet model, with recoiling parton.
6540 DO 344 I=461,479
6541 MSUB(I)=1
6542 344 CONTINUE
6543
6544 ELSEIF(MSEL.EQ.63) THEN
6545C...Charmonium and bottomonium production in colour octet model.
6546 DO 346 I=421,439
6547 MSUB(I)=1
6548 MSUB(I+40)=1
6549 346 CONTINUE
6550 ENDIF
6551
6552C...Find heaviest new quark flavour allowed in processes 81-84.
6553 KFLQM=1
6554 DO 350 I=1,MIN(8,MDCY(21,3))
6555 IDC=I+MDCY(21,2)-1
6556 IF(MDME(IDC,1).LE.0) GOTO 350
6557 KFLQM=I
6558 350 CONTINUE
6559 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6560 &KFLQM=MSTP(7)
6561 MINT(55)=KFLQM
6562 KFPR(81,1)=KFLQM
6563 KFPR(81,2)=KFLQM
6564 KFPR(82,1)=KFLQM
6565 KFPR(82,2)=KFLQM
6566 KFPR(83,1)=KFLQM
6567 KFPR(84,1)=KFLQM
6568 KFPR(84,2)=KFLQM
6569
6570C...Find heaviest new fermion flavour allowed in process 85.
6571 KFLFM=1
6572 DO 360 I=1,MIN(12,MDCY(22,3))
6573 IDC=I+MDCY(22,2)-1
6574 IF(MDME(IDC,1).LE.0) GOTO 360
6575 KFLFM=KFDP(IDC,1)
6576 360 CONTINUE
6577 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6578 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6579 MINT(56)=KFLFM
6580 KFPR(85,1)=KFLFM
6581 KFPR(85,2)=KFLFM
6582
6583C...Import relevant information on external user processes.
6584 IF(MINT(111).GE.11) THEN
6585 IPYPR=0
6586 DO 390 IUP=1,NPRUP
6587C...Find next empty PYTHIA process number slot and enable it.
6588 370 IPYPR=IPYPR+1
6589 IF(IPYPR.GT.500) CALL PYERRM(26,
6590 & '(PYINPR.) no more empty slots for user processes')
6591 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6592 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6593 ISET(IPYPR)=11
6594C...Overwrite KFPR with references back to process number and ID.
6595 KFPR(IPYPR,1)=IUP
6596 KFPR(IPYPR,2)=LPRUP(IUP)
6597C...Process title.
6598 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6599 ICHIN=1
6600 DO 380 ICH=1,9
6601 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6602 380 CONTINUE
6603 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6604C...Switch on process.
6605 MSUB(IPYPR)=1
6606 390 CONTINUE
6607 ENDIF
6608
6609 RETURN
6610 END
6611
6612C*********************************************************************
6613
6614C...PYXTOT
6615C...Parametrizes total, elastic and diffractive cross-sections
6616C...for different energies and beams. Donnachie-Landshoff for
6617C...total and Schuler-Sjostrand for elastic and diffractive.
6618C...Process code IPROC:
6619C...= 1 : p + p;
6620C...= 2 : pbar + p;
6621C...= 3 : pi+ + p;
6622C...= 4 : pi- + p;
6623C...= 5 : pi0 + p;
6624C...= 6 : phi + p;
6625C...= 7 : J/psi + p;
6626C...= 11 : rho + rho;
6627C...= 12 : rho + phi;
6628C...= 13 : rho + J/psi;
6629C...= 14 : phi + phi;
6630C...= 15 : phi + J/psi;
6631C...= 16 : J/psi + J/psi;
6632C...= 21 : gamma + p (DL);
6633C...= 22 : gamma + p (VDM).
6634C...= 23 : gamma + pi (DL);
6635C...= 24 : gamma + pi (VDM);
6636C...= 25 : gamma + gamma (DL);
6637C...= 26 : gamma + gamma (VDM).
6638
6639 SUBROUTINE PYXTOT
6640
6641C...Double precision and integer declarations.
6642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6643 IMPLICIT INTEGER(I-N)
6644 INTEGER PYK,PYCHGE,PYCOMP
6645C...Commonblocks.
6646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6647 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6648 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6649 COMMON/PYINT1/MINT(400),VINT(400)
6650 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6651 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6652 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6653C...Local arrays.
6654 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6655 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6656 &CEFFD(10,9),SIGTMP(6,0:5)
6657
6658C...Common constants.
6659 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6660 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6661 &FACDD/0.0084D0/
6662
6663C...Number of multiple processes to be evaluated (= 0 : undefined).
6664 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6665C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6666 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6667 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6668 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6669 DATA YPAR/
6670 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6671 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6672 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6673
6674C...Beam and target hadron class:
6675C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6676 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6677 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6678C...Characteristic class masses, slope parameters, beta = sqrt(X).
6679 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6680 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6681 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6682
6683C...Fitting constants used in parametrizations of diffractive results.
6684 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6685 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6686 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6687 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6688 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6689 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6690 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6691 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6692 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6693 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6694 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6695 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6696 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6697 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6698 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6699 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6700 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6701 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6702 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6703 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6704 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6705 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6706 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6707 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6708 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6709 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6710 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6711 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6712 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6713
6714C...Parameters. Combinations of the energy.
6715 AEM=PARU(101)
6716 PMTH=PARP(102)
6717 S=VINT(2)
6718 SRT=VINT(1)
6719 SEPS=S**EPS
6720 SETA=S**ETA
6721 SLOG=LOG(S)
6722
6723C...Ratio of gamma/pi (for rescaling in parton distributions).
6724 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6725 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6726 VINT(317)=1D0
6727 IF(MINT(50).NE.1) RETURN
6728
6729C...Order flavours of incoming particles: KF1 < KF2.
6730 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6731 KF1=IABS(MINT(11))
6732 KF2=IABS(MINT(12))
6733 IORD=1
6734 ELSE
6735 KF1=IABS(MINT(12))
6736 KF2=IABS(MINT(11))
6737 IORD=2
6738 ENDIF
6739 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6740
6741C...Find process number (for lookup tables).
6742 IF(KF1.GT.1000) THEN
6743 IPROC=1
6744 IF(ISGN12.LT.0) IPROC=2
6745 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6746 IPROC=3
6747 IF(ISGN12.LT.0) IPROC=4
6748 IF(KF1.EQ.111) IPROC=5
6749 ELSEIF(KF1.GT.100) THEN
6750 IPROC=11
6751 ELSEIF(KF2.GT.1000) THEN
6752 IPROC=21
6753 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6754 ELSEIF(KF2.GT.100) THEN
6755 IPROC=23
6756 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6757 ELSE
6758 IPROC=25
6759 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6760 ENDIF
6761
6762C... Number of multiple processes to be stored; beam/target side.
6763 NPR=NPROC(IPROC)
6764 MINT(101)=1
6765 MINT(102)=1
6766 IF(NPR.EQ.3) THEN
6767 MINT(100+IORD)=4
6768 ELSEIF(NPR.EQ.6) THEN
6769 MINT(101)=4
6770 MINT(102)=4
6771 ENDIF
6772 N1=0
6773 IF(MINT(101).EQ.4) N1=4
6774 N2=0
6775 IF(MINT(102).EQ.4) N2=4
6776
6777C...Do not do any more for user-set or undefined cross-sections.
6778 IF(MSTP(31).LE.0) RETURN
6779 IF(NPR.EQ.0) CALL PYERRM(26,
6780 &'(PYXTOT:) cross section for this process not yet implemented')
6781
6782C...Parameters. Combinations of the energy.
6783 AEM=PARU(101)
6784 PMTH=PARP(102)
6785 S=VINT(2)
6786 SRT=VINT(1)
6787 SEPS=S**EPS
6788 SETA=S**ETA
6789 SLOG=LOG(S)
6790
6791C...Loop over multiple processes (for VDM).
6792 DO 110 I=1,NPR
6793 IF(NPR.EQ.1) THEN
6794 IPR=IPROC
6795 ELSEIF(NPR.EQ.3) THEN
6796 IPR=I+4
6797 IF(KF2.LT.1000) IPR=I+10
6798 ELSEIF(NPR.EQ.6) THEN
6799 IPR=I+10
6800 ENDIF
6801
6802C...Evaluate hadron species, mass, slope contribution and fit number.
6803 IHA=IHADA(IPR)
6804 IHB=IHADB(IPR)
6805 PMA=PMHAD(IHA)
6806 PMB=PMHAD(IHB)
6807 BHA=BHAD(IHA)
6808 BHB=BHAD(IHB)
6809 ISD=IFITSD(IPR)
6810 IDD=IFITDD(IPR)
6811
6812C...Skip if energy too low relative to masses.
6813 DO 100 J=0,5
6814 SIGTMP(I,J)=0D0
6815 100 CONTINUE
6816 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6817
6818C...Total cross-section. Elastic slope parameter and cross-section.
6819 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6820 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6821 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6822
6823C...Diffractive scattering A + B -> X + B.
6824 BSD=2D0*BHB
6825 SQML=(PMA+PMTH)**2
6826 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6827 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6828 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6829 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6830 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6831 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6832 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6833
6834C...Diffractive scattering A + B -> A + X.
6835 BSD=2D0*BHA
6836 SQML=(PMB+PMTH)**2
6837 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6838 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6839 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6840 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6841 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6842 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6843 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6844
6845C...Order single diffractive correctly.
6846 IF(IORD.EQ.2) THEN
6847 SIGSAV=SIGTMP(I,2)
6848 SIGTMP(I,2)=SIGTMP(I,3)
6849 SIGTMP(I,3)=SIGSAV
6850 ENDIF
6851
6852C...Double diffractive scattering A + B -> X1 + X2.
6853 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6854 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6855 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6856 IF(YEFF.LE.0) SUM1=0D0
6857 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6858 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6859 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6860 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6861 & (2D0*ALP)
6862 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6863 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6864 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6865 & (2D0*ALP)
6866 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6867 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6868 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6869 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6870 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6871
6872C...Non-diffractive by unitarity.
6873 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6874 & SIGTMP(I,4)
6875 110 CONTINUE
6876
6877C...Put temporary results in output array: only one process.
6878 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6879 DO 120 J=0,5
6880 SIGT(0,0,J)=SIGTMP(1,J)
6881 120 CONTINUE
6882
6883C...Beam multiple processes.
6884 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6885 IF(MINT(107).EQ.2) THEN
6886 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6887 ELSE
6888 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6889 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6890 ENDIF
6891 IF(MSTP(20).GT.0) THEN
6892 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6893 ENDIF
6894 DO 140 I=1,4
6895 IF(MINT(107).EQ.2) THEN
6896 CONV=(AEM/PARP(160+I))*VINT(317)
6897 ELSEIF(VINT(154).GT.PARP(15)) THEN
6898 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6899 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6900 ELSE
6901 CONV=0D0
6902 ENDIF
6903 I1=MAX(1,I-1)
6904 DO 130 J=0,5
6905 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6906 130 CONTINUE
6907 140 CONTINUE
6908 DO 150 J=0,5
6909 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6910 150 CONTINUE
6911
6912C...Target multiple processes.
6913 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6914 IF(MINT(108).EQ.2) THEN
6915 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6916 ELSE
6917 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6918 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6919 ENDIF
6920 IF(MSTP(20).GT.0) THEN
6921 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6922 ENDIF
6923 DO 170 I=1,4
6924 IF(MINT(108).EQ.2) THEN
6925 CONV=(AEM/PARP(160+I))*VINT(317)
6926 ELSEIF(VINT(154).GT.PARP(15)) THEN
6927 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6928 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6929 ELSE
6930 CONV=0D0
6931 ENDIF
6932 IV=MAX(1,I-1)
6933 DO 160 J=0,5
6934 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6935 160 CONTINUE
6936 170 CONTINUE
6937 DO 180 J=0,5
6938 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6939 180 CONTINUE
6940
6941C...Both beam and target multiple processes.
6942 ELSE
6943 IF(MINT(107).EQ.2) THEN
6944 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6945 ELSE
6946 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6947 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6948 ENDIF
6949 IF(MINT(108).EQ.2) THEN
6950 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6951 ELSE
6952 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6953 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6954 ENDIF
6955 IF(MSTP(20).GT.0) THEN
6956 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6957 & VINT(308)))**MSTP(20)
6958 ENDIF
6959 DO 210 I1=1,4
6960 DO 200 I2=1,4
6961 IF(MINT(107).EQ.2) THEN
6962 CONV=(AEM/PARP(160+I1))*VINT(317)
6963 ELSEIF(VINT(154).GT.PARP(15)) THEN
6964 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6965 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6966 ELSE
6967 CONV=0D0
6968 ENDIF
6969 IF(MINT(108).EQ.2) THEN
6970 CONV=CONV*(AEM/PARP(160+I2))
6971 ELSEIF(VINT(154).GT.PARP(15)) THEN
6972 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6973 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6974 ELSE
6975 CONV=0D0
6976 ENDIF
6977 IF(I1.LE.2) THEN
6978 IV=MAX(1,I2-1)
6979 ELSEIF(I2.LE.2) THEN
6980 IV=MAX(1,I1-1)
6981 ELSEIF(I1.EQ.I2) THEN
6982 IV=2*I1-2
6983 ELSE
6984 IV=5
6985 ENDIF
6986 DO 190 J=0,5
6987 JV=J
6988 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6989 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
6990 190 CONTINUE
6991 200 CONTINUE
6992 210 CONTINUE
6993 DO 230 J=0,5
6994 DO 220 I=1,4
6995 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
6996 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
6997 220 CONTINUE
6998 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6999 230 CONTINUE
7000 ENDIF
7001
7002C...Scale up uniformly for Donnachie-Landshoff parametrization.
7003 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7004 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7005 DO 260 I1=0,N1
7006 DO 250 I2=0,N2
7007 DO 240 J=0,5
7008 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7009 240 CONTINUE
7010 250 CONTINUE
7011 260 CONTINUE
7012 ENDIF
7013
7014 RETURN
7015 END
7016
7017C*********************************************************************
7018
7019C...PYMAXI
7020C...Finds optimal set of coefficients for kinematical variable selection
7021C...and the maximum of the part of the differential cross-section used
7022C...in the event weighting.
7023
7024 SUBROUTINE PYMAXI
7025
7026C...Double precision and integer declarations.
7027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7028 IMPLICIT INTEGER(I-N)
7029 INTEGER PYK,PYCHGE,PYCOMP
7030C...Parameter statement to help give large particle numbers.
7031 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7032 &KEXCIT=4000000,KDIMEN=5000000)
7033
7034C...User process initialization commonblock.
7035 INTEGER MAXPUP
7036 PARAMETER (MAXPUP=100)
7037 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7038 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7039 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7040 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7041 &LPRUP(MAXPUP)
7042 SAVE /HEPRUP/
7043
7044C...Commonblocks.
7045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7046 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7047 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7048 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7049 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7050 COMMON/PYINT1/MINT(400),VINT(400)
7051 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7052 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7053 COMMON/PYINT4/MWID(500),WIDS(500,5)
7054 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7055 COMMON/PYINT6/PROC(0:500)
7056 CHARACTER PROC*28
7057 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7058 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7059 COMMON/PYTCCO/COEFX(194:380,2)
7060 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7061 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7062 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7063 &/PYTCSM/,/TCPARA/
7064C...Local arrays, character variables and data.
7065 LOGICAL IOK
7066 CHARACTER CVAR(4)*4
7067 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7068 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7069 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7070 DATA CVAR/'tau ','tau''','y* ','cth '/
7071 DATA SIGSSM/3*0D0/
7072
7073C...Initial values and loop over subprocesses.
7074 NPOSI=0
7075 VINT(143)=1D0
7076 VINT(144)=1D0
7077 XSEC(0,1)=0D0
7078 ITECH=0
7079 DO 460 ISUB=1,500
7080 MINT(1)=ISUB
7081 MINT(51)=0
7082
7083C...Find maximum weight factors for photon flux.
7084 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7085 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7086 ENDIF
7087
7088C...Select subprocess to study: skip cases not applicable.
7089 IF(ISET(ISUB).EQ.11) THEN
7090 IF(MSUB(ISUB).NE.1) GOTO 460
7091C...User process intialization: cross section model dependent.
7092 IF(IABS(IDWTUP).EQ.1) THEN
7093 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7094 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7095 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7096 ELSE
7097 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7098 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7099 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7100 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7101 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7102 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7103 ENDIF
7104 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7105 & WTGAGA*XSEC(ISUB,1)
7106 NPOSI=NPOSI+1
7107 GOTO 450
7108 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7109 CALL PYSIGH(NCHN,SIGS)
7110 XSEC(ISUB,1)=SIGS
7111 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7112 & WTGAGA*XSEC(ISUB,1)
7113 IF(MSUB(ISUB).NE.1) GOTO 460
7114 NPOSI=NPOSI+1
7115 GOTO 450
7116 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7117 CALL PYSIGH(NCHN,SIGS)
7118 XSEC(ISUB,1)=SIGS
7119 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7120 & WTGAGA*XSEC(ISUB,1)
7121 IF(XSEC(ISUB,1).EQ.0D0) THEN
7122 MSUB(ISUB)=0
7123 ELSE
7124 NPOSI=NPOSI+1
7125 ENDIF
7126 GOTO 450
7127 ELSEIF(ISUB.EQ.96) THEN
7128 IF(MINT(50).EQ.0) GOTO 460
7129 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7130 & GOTO 460
7131 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7132 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7133 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7134 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7135 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7136 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7137 ELSE
7138 IF(MSUB(ISUB).NE.1) GOTO 460
7139 ENDIF
7140 ISTSB=ISET(ISUB)
7141 IF(ISUB.EQ.96) ISTSB=2
7142 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7143 MWTXS=0
7144 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7145 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7146
7147C...Find resonances (explicit or implicit in cross-section).
7148 MINT(72)=0
7149 KFR1=0
7150 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7151 KFR1=KFPR(ISUB,1)
7152 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7153 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7154 KFR1=23
7155 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7156 & .OR.ISUB.EQ.177) THEN
7157 KFR1=24
7158 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7159 KFR1=25
7160 IF(MSTP(46).EQ.5) THEN
7161 KFR1=89
7162 PMAS(89,1)=PARP(45)
7163 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7164 ENDIF
7165 ENDIF
7166 CKMX=CKIN(2)
7167 IF(CKMX.LE.0D0) CKMX=VINT(1)
7168 KCR1=PYCOMP(KFR1)
7169 IF(KFR1.NE.0) THEN
7170 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7171 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7172 ENDIF
7173 IF(KFR1.NE.0) THEN
7174 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7175 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7176 MINT(72)=1
7177 MINT(73)=KFR1
7178 VINT(73)=TAUR1
7179 VINT(74)=GAMR1
7180 ENDIF
7181 KFR2=0
7182 KFR3=0
7183 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7184 $ (ISUB.GE.361.AND.ISUB.LE.380))
7185 $ THEN
7186 KFR2=23
7187 IF(ISUB.EQ.141) THEN
7188 KCR2=PYCOMP(KFR2)
7189 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7190 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7191 KFR2=0
7192 ELSE
7193 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7194 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7195 MINT(72)=2
7196 MINT(74)=KFR2
7197 VINT(75)=TAUR2
7198 VINT(76)=GAMR2
7199 ENDIF
7200 ELSEIF(ITECH.EQ.0) THEN
7201 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7202 ITECH=1
7203 KFR1=KTECHN+113
7204 KCR1=PYCOMP(KFR1)
7205 KFR2=KTECHN+223
7206 KCR2=PYCOMP(KFR2)
7207 KFR3=KTECHN+115
7208 KCR3=PYCOMP(KFR3)
7209 IRES=0
7210C...Order the resonances
7211 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7212 KCT=KCR3
7213 KCR3=KCR2
7214 KCR2=KCT
7215 ENDIF
7216 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7217 KCT=KCR3
7218 KCR3=KCR1
7219 KCR1=KCT
7220 ENDIF
7221 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7222 KCT=KCR2
7223 KCR2=KCR1
7224 KCR1=KCT
7225 ENDIF
7226 DO 101 I=1,3
7227 IF(I.EQ.1) THEN
7228 SHN0=PMAS(KCR1,1)**2
7229 ELSEIF(I.EQ.2) THEN
7230 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7231 SHN0=PMAS(KCR2,1)**2
7232 ELSEIF(I.EQ.3) THEN
7233 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7234 SHN0=PMAS(KCR3,1)**2
7235 ENDIF
7236 AEM=PYALEM(SHN0)
7237 FAR=SQRT(AEM/ALPRHT)
7238 SHN=SHN0*(1D0-FAR)
7239 CALL PYTECM(SHN,S1,WIDO,1)
7240 RES=SHN-S1
7241 SHN=S1*.99D0
7242 SHSTEP=2D0
7243 102 SHN=SHN+SHSTEP
7244 CALL PYTECM(SHN,S1,WIDO,1)
7245 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7246 IOK=.FALSE.
7247 IF(IRES.GT.0) THEN
7248 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7249 ELSEIF(IRES.EQ.0) THEN
7250 IOK=.TRUE.
7251 ENDIF
7252 IF(IOK) THEN
7253 IRES=IRES+1
7254 XMAS(IRES)=SQRT(S1)
7255 XWID(IRES)=WIDO
7256 ENDIF
7257 ENDIF
7258 RES=SHN-S1
7259 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7260 101 CONTINUE
7261 JRES=0
7262 KFR1=KTECHN+213
7263 KCR1=PYCOMP(KFR1)
7264 KFR2=KTECHN+215
7265 KCR2=PYCOMP(KFR2)
7266 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7267 KCT=KCR2
7268 KCR2=KCR1
7269 KCR1=KCT
7270 ENDIF
7271 DO 103 I=1,2
7272 IF(I.EQ.1) THEN
7273 SHN0=PMAS(KCR1,1)**2
7274 ELSEIF(I.EQ.2) THEN
7275 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7276 SHN0=PMAS(KCR2,1)**2
7277 ENDIF
7278 AEM=PYALEM(SHN0)
7279 FAR=SQRT(AEM/ALPRHT)
7280 SHN=SHN0*(1D0-FAR)
7281 CALL PYTECM(SHN,S1,WIDO,2)
7282 RES=SHN-S1
7283 SHN=S1*.99D0
7284 SHSTEP=2D0
7285 104 SHN=SHN+SHSTEP
7286 CALL PYTECM(SHN,S1,WIDO,2)
7287 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7288 IOK=.FALSE.
7289 IF(JRES.GT.0) THEN
7290 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7291 ELSEIF(JRES.EQ.0) THEN
7292 IOK=.TRUE.
7293 ENDIF
7294 IF(IOK) THEN
7295 JRES=JRES+1
7296 YMAS(JRES)=SQRT(S1)
7297 YWID(JRES)=WIDO
7298 ENDIF
7299 ENDIF
7300 RES=SHN-S1
7301 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7302 103 CONTINUE
7303 ENDIF
7304 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7305 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7306 MINT(72)=IRES
7307 IF(IRES.GE.1) THEN
7308 VINT(73)=XMAS(1)**2/VINT(2)
7309 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7310 TAUR1=VINT(73)
7311 GAMR1=VINT(74)
7312 XM1=XMAS(1)
7313 XG1=XWID(1)
7314 KFR1=1
7315 ENDIF
7316 IF(IRES.GE.2) THEN
7317 VINT(75)=XMAS(2)**2/VINT(2)
7318 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7319 TAUR2=VINT(75)
7320 GAMR2=VINT(76)
7321 XM2=XMAS(2)
7322 XG2=XWID(2)
7323 KFR2=2
7324 ENDIF
7325 IF(IRES.EQ.3) THEN
7326 VINT(77)=XMAS(3)**2/VINT(2)
7327 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7328 TAUR3=VINT(77)
7329 GAMR3=VINT(78)
7330 XM3=XMAS(3)
7331 XG3=XWID(3)
7332 KFR3=3
7333 ENDIF
7334C...Charged current: rho+- and a+-
7335 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7336 MINT(72)=IRES
7337 IF(JRES.GE.1) THEN
7338 VINT(73)=YMAS(1)**2/VINT(2)
7339 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7340 KFR1=1
7341 TAUR1=VINT(73)
7342 GAMR1=VINT(74)
7343 XM1=YMAS(1)
7344 XG1=YWID(1)
7345 ENDIF
7346 IF(JRES.GE.2) THEN
7347 VINT(75)=YMAS(2)**2/VINT(2)
7348 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7349 KFR2=2
7350 TAUR2=VINT(73)
7351 GAMR2=VINT(74)
7352 XM2=YMAS(2)
7353 XG2=YWID(2)
7354 ENDIF
7355 KFR3=0
7356 ENDIF
7357 IF(ISUB.NE.141) THEN
7358 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7359 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7360 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7361 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7362 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7363 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7364 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7365
7366 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7367 MINT(72)=2
7368 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7369 MINT(72)=2
7370 MINT(74)=KFR3
7371 VINT(75)=TAUR3
7372 VINT(76)=GAMR3
7373 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7374 MINT(72)=2
7375 MINT(73)=KFR2
7376 VINT(73)=TAUR2
7377 VINT(74)=GAMR2
7378 MINT(74)=KFR3
7379 VINT(75)=TAUR3
7380 VINT(76)=GAMR3
7381 ELSEIF(KFR1.NE.0) THEN
7382 MINT(72)=1
7383 ELSEIF(KFR2.NE.0) THEN
7384 MINT(72)=1
7385 MINT(73)=KFR2
7386 VINT(73)=TAUR2
7387 VINT(74)=GAMR2
7388 ELSEIF(KFR3.NE.0) THEN
7389 MINT(72)=1
7390 MINT(73)=KFR3
7391 VINT(73)=TAUR3
7392 VINT(74)=GAMR3
7393 ELSE
7394 MINT(72)=0
7395 ENDIF
7396 ELSE
7397 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7398
7399 ELSEIF(KFR2.NE.0) THEN
7400 KFR1=KFR2
7401 TAUR1=TAUR2
7402 GAMR1=GAMR2
7403 MINT(72)=1
7404 MINT(73)=KFR1
7405 VINT(73)=TAUR1
7406 VINT(74)=GAMR1
7407 KFR2=0
7408 ELSE
7409 MINT(72)=0
7410 ENDIF
7411 ENDIF
7412 ENDIF
7413
7414C...Find product masses and minimum pT of process.
7415 SQM3=0D0
7416 SQM4=0D0
7417 MINT(71)=0
7418 VINT(71)=CKIN(3)
7419 VINT(80)=1D0
7420 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7421 NBW=0
7422 DO 110 I=1,2
7423 PMMN(I)=0D0
7424 IF(KFPR(ISUB,I).EQ.0) THEN
7425 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7426 & PARP(41)) THEN
7427 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7428 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7429 ELSE
7430 NBW=NBW+1
7431C...This prevents SUSY/t particles from becoming too light.
7432 KFLW=KFPR(ISUB,I)
7433 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7434 KCW=PYCOMP(KFLW)
7435 PMMN(I)=PMAS(KCW,1)
7436 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7437 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7438 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7439 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7440 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7441 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7442 PMMN(I)=MIN(PMMN(I),PMSUM)
7443 ENDIF
7444 100 CONTINUE
7445 ELSEIF(KFLW.EQ.6) THEN
7446 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7447 ENDIF
7448 ENDIF
7449 110 CONTINUE
7450 IF(NBW.GE.1) THEN
7451 CKIN41=CKIN(41)
7452 CKIN43=CKIN(43)
7453 CKIN(41)=MAX(PMMN(1),CKIN(41))
7454 CKIN(43)=MAX(PMMN(2),CKIN(43))
7455 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7456 CKIN(41)=CKIN41
7457 CKIN(43)=CKIN43
7458 IF(MINT(51).EQ.1) THEN
7459 WRITE(MSTU(11),5100) ISUB
7460 MSUB(ISUB)=0
7461 GOTO 460
7462 ENDIF
7463 SQM3=PQM3**2
7464 SQM4=PQM4**2
7465 ENDIF
7466 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7467 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7468 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7469 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7470 ELSEIF(ISUB.EQ.96) THEN
7471 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7472 ENDIF
7473 ENDIF
7474 VINT(63)=SQM3
7475 VINT(64)=SQM4
7476
7477C...Prepare for additional variable choices in 2 -> 3.
7478 IF(ISTSB.EQ.5) THEN
7479 VINT(201)=0D0
7480 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7481 VINT(206)=VINT(201)
7482 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7483 VINT(204)=PMAS(23,1)
7484 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7485 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7486 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7487 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7488 & VINT(204)=VINT(201)
7489 VINT(209)=VINT(204)
7490 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7491 ENDIF
7492
7493C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7494 IPEAK7=0
7495 NPTS(1)=2+2*MINT(72)
7496 IF(MINT(47).EQ.1) THEN
7497 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7498 ELSEIF(MINT(47).GE.5) THEN
7499 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7500 NPTS(1)=NPTS(1)+1
7501 IPEAK7=1
7502 ENDIF
7503 ENDIF
7504 NPTS(2)=1
7505 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7506 IF(MINT(47).GE.2) NPTS(2)=2
7507 IF(MINT(47).GE.5) NPTS(2)=3
7508 ENDIF
7509 NPTS(3)=1
7510 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7511 NPTS(3)=3
7512 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7513 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7514 ENDIF
7515 NPTS(4)=1
7516 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7517 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7518
7519C...Reset coefficients of cross-section weighting.
7520 DO 120 J=1,20
7521 COEF(ISUB,J)=0D0
7522 120 CONTINUE
7523 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7524 & .AND.ISUB.LE.380)) THEN
7525 DO 125 J=1,2
7526 COEFX(ISUB,J)=0D0
7527 125 CONTINUE
7528 ENDIF
7529 COEF(ISUB,1)=1D0
7530 COEF(ISUB,8)=0.5D0
7531 COEF(ISUB,9)=0.5D0
7532 COEF(ISUB,13)=1D0
7533 COEF(ISUB,18)=1D0
7534 MCTH=0
7535 MTAUP=0
7536 METAUP=0
7537 VINT(23)=0D0
7538 VINT(26)=0D0
7539 SIGSAM=0D0
7540
7541C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7542C...in grid of phase space points.
7543 CALL PYKLIM(1)
7544 METAU=MINT(51)
7545 NACC=0
7546 DO 150 ITRY=1,NTRY
7547 MINT(51)=0
7548 IF(METAU.EQ.1) GOTO 150
7549 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7550 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7551 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7552 MTAU=7
7553 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7554 MTAU=MTAU+1
7555 ENDIF
7556 RTAU=0.5D0
7557C...Special case when both resonances have same mass,
7558C...as is often the case in process 194.
7559c IF(MINT(72).GE.2) THEN
7560c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7561c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7562c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7563c RTAU=0.4D0
7564c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7565c RTAU=0.6D0
7566c ENDIF
7567c ENDIF
7568c ENDIF
7569 CALL PYKMAP(1,MTAU,RTAU)
7570 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7571 METAUP=MINT(51)
7572 ENDIF
7573 IF(METAUP.EQ.1) GOTO 150
7574 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7575 & .EQ.0) THEN
7576 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7577 CALL PYKMAP(4,MTAUP,0.5D0)
7578 ENDIF
7579 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7580 CALL PYKLIM(2)
7581 MEYST=MINT(51)
7582 ENDIF
7583 IF(MEYST.EQ.1) GOTO 150
7584 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7585 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7586 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7587 CALL PYKMAP(2,MYST,0.5D0)
7588 CALL PYKLIM(3)
7589 MECTH=MINT(51)
7590 ENDIF
7591 IF(MECTH.EQ.1) GOTO 150
7592 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7593 MCTH=1+MOD(ITRY-1,NPTS(4))
7594 CALL PYKMAP(3,MCTH,0.5D0)
7595 ENDIF
7596 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7597
7598C...Store position and limits.
7599 MINT(51)=0
7600 CALL PYKLIM(0)
7601 IF(MINT(51).EQ.1) GOTO 150
7602 NACC=NACC+1
7603 MVARPT(NACC,1)=MTAU
7604 MVARPT(NACC,2)=MTAUP
7605 MVARPT(NACC,3)=MYST
7606 MVARPT(NACC,4)=MCTH
7607 DO 130 J=1,30
7608 VINTPT(NACC,J)=VINT(10+J)
7609 130 CONTINUE
7610
7611C...Normal case: calculate cross-section.
7612 IF(ISTSB.NE.5) THEN
7613 CALL PYSIGH(NCHN,SIGS)
7614 IF(MWTXS.EQ.1) THEN
7615 CALL PYEVWT(WTXS)
7616 SIGS=WTXS*SIGS
7617 ENDIF
7618
7619C..2 -> 3: find highest value out of a number of tries.
7620 ELSE
7621 SIGS=0D0
7622 DO 140 IKIN3=1,MSTP(129)
7623 CALL PYKMAP(5,0,0D0)
7624 IF(MINT(51).EQ.1) GOTO 140
7625 CALL PYSIGH(NCHN,SIGTMP)
7626 IF(MWTXS.EQ.1) THEN
7627 CALL PYEVWT(WTXS)
7628 SIGTMP=WTXS*SIGTMP
7629 ENDIF
7630 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7631 140 CONTINUE
7632 ENDIF
7633
7634C...Store cross-section.
7635 SIGSPT(NACC)=SIGS
7636 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7637 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7638 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7639 150 CONTINUE
7640 IF(NACC.EQ.0) THEN
7641 WRITE(MSTU(11),5100) ISUB
7642 MSUB(ISUB)=0
7643 GOTO 460
7644 ELSEIF(SIGSAM.EQ.0D0) THEN
7645 WRITE(MSTU(11),5300) ISUB
7646 MSUB(ISUB)=0
7647 GOTO 460
7648 ENDIF
7649 IF(ISUB.NE.96) NPOSI=NPOSI+1
7650
7651C...Calculate integrals in tau over maximal phase space limits.
7652 TAUMIN=VINT(11)
7653 TAUMAX=VINT(31)
7654 ATAU1=LOG(TAUMAX/TAUMIN)
7655 IF(NPTS(1).GE.2) THEN
7656 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7657 ENDIF
7658 IF(NPTS(1).GE.4) THEN
7659 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7660 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7661 & GAMR1
7662 ENDIF
7663 IF(NPTS(1).GE.6) THEN
7664 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7665 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7666 & GAMR2
7667 ENDIF
7668 IF(NPTS(1).GE.8) THEN
7669 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7670 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7671 & GAMR3
7672 ENDIF
7673 IF(IPEAK7.EQ.1) THEN
7674 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7675 ENDIF
7676
7677C...Reset. Sum up cross-sections in points calculated.
7678 DO 320 IVAR=1,4
7679 IF(NPTS(IVAR).EQ.1) GOTO 320
7680 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7681 NBIN=NPTS(IVAR)
7682 DO 170 J1=1,NBIN
7683 NAREL(J1)=0
7684 WTREL(J1)=0D0
7685 COEFU(J1)=0D0
7686 DO 160 J2=1,NBIN
7687 WTMAT(J1,J2)=0D0
7688 160 CONTINUE
7689 170 CONTINUE
7690 DO 180 IACC=1,NACC
7691 IBIN=MVARPT(IACC,IVAR)
7692 IF(IVAR.EQ.1) THEN
7693 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7694 IBIN=IBIN-1
7695 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7696 IBIN=3+2*MINT(72)
7697 ENDIF
7698 ENDIF
7699 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7700 NAREL(IBIN)=NAREL(IBIN)+1
7701 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7702
7703C...Sum up tau cross-section pieces in points used.
7704 IF(IVAR.EQ.1) THEN
7705 TAU=VINTPT(IACC,11)
7706 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7707 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7708 IF(NBIN.GE.4) THEN
7709 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7710 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7711 & ((TAU-TAUR1)**2+GAMR1**2)
7712 ENDIF
7713 IF(NBIN.GE.6) THEN
7714 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7715 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7716 & ((TAU-TAUR2)**2+GAMR2**2)
7717 ENDIF
7718 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7719 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7720 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7721 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7722 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7723 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7724 ENDIF
7725 IF(MINT(72).EQ.3) THEN
7726 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7727 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7728 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7729 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7730 ENDIF
7731C...Sum up tau' cross-section pieces in points used.
7732 ELSEIF(IVAR.EQ.2) THEN
7733 TAU=VINTPT(IACC,11)
7734 TAUP=VINTPT(IACC,16)
7735 TAUPMN=VINTPT(IACC,6)
7736 TAUPMX=VINTPT(IACC,26)
7737 ATAUP1=LOG(TAUPMX/TAUPMN)
7738 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7739 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7740 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7741 & (1D0-TAU/TAUP)**3/TAUP
7742 IF(NBIN.GE.3) THEN
7743 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7744 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7745 & TAUP/MAX(2D-10,1D0-TAUP)
7746 ENDIF
7747
7748C...Sum up y* cross-section pieces in points used.
7749 ELSEIF(IVAR.EQ.3) THEN
7750 YST=VINTPT(IACC,12)
7751 YSTMIN=VINTPT(IACC,2)
7752 YSTMAX=VINTPT(IACC,22)
7753 AYST0=YSTMAX-YSTMIN
7754 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7755 AYST2=AYST1
7756 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7757 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7758 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7759 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7760 IF(MINT(45).EQ.3) THEN
7761 TAUE=VINTPT(IACC,11)
7762 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7763 YST0=-0.5D0*LOG(TAUE)
7764 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7765 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7766 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7767 & MAX(1D-10,1D0-EXP(YST-YST0))
7768 ENDIF
7769 IF(MINT(46).EQ.3) THEN
7770 TAUE=VINTPT(IACC,11)
7771 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7772 YST0=-0.5D0*LOG(TAUE)
7773 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7774 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7775 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7776 & MAX(1D-10,1D0-EXP(-YST-YST0))
7777 ENDIF
7778
7779C...Sum up cos(theta-hat) cross-section pieces in points used.
7780 ELSE
7781 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7782 RSQM=1D0+RM34
7783 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7784 CTHMIN=-CTHMAX
7785 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7786 & (TAUMAX*VINT(2)))
7787 ACTH1=CTHMAX-CTHMIN
7788 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7789 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7790 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7791 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7792 CTH=VINTPT(IACC,13)
7793 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7794 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7795 & MAX(RM34,RSQM-CTH)
7796 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7797 & MAX(RM34,RSQM+CTH)
7798 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7799 & MAX(RM34,RSQM-CTH)**2
7800 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7801 & MAX(RM34,RSQM+CTH)**2
7802 ENDIF
7803 180 CONTINUE
7804
7805C...Check that equation system solvable.
7806 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7807 MSOLV=1
7808 WTRELS=0D0
7809 DO 190 IBIN=1,NBIN
7810 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7811 & IRED=1,NBIN),WTREL(IBIN)
7812 IF(NAREL(IBIN).EQ.0) MSOLV=0
7813 WTRELS=WTRELS+WTREL(IBIN)
7814 190 CONTINUE
7815 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7816
7817C...Solve to find relative importance of cross-section pieces.
7818 IF(MSOLV.EQ.1) THEN
7819 DO 200 IBIN=1,NBIN
7820 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7821 200 CONTINUE
7822 DO 230 IRED=1,NBIN-1
7823 DO 220 IBIN=IRED+1,NBIN
7824 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7825 MSOLV=0
7826 GOTO 260
7827 ENDIF
7828 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7829 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7830 DO 210 ICOE=IRED,NBIN
7831 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7832 210 CONTINUE
7833 220 CONTINUE
7834 230 CONTINUE
7835 DO 250 IRED=NBIN,1,-1
7836 DO 240 ICOE=IRED+1,NBIN
7837 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7838 240 CONTINUE
7839 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7840 250 CONTINUE
7841 ENDIF
7842
7843C...Share evenly if failure.
7844 260 IF(MSOLV.EQ.0) THEN
7845 DO 270 IBIN=1,NBIN
7846 COEFU(IBIN)=1D0
7847 WTRELN(IBIN)=0.1D0
7848 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7849 & WTREL(IBIN)/WTRELS)
7850 270 CONTINUE
7851 ENDIF
7852
7853C...Normalize coefficients, with piece shared democratically.
7854 COEFSU=0D0
7855 WTRELS=0D0
7856 DO 280 IBIN=1,NBIN
7857 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7858 COEFSU=COEFSU+COEFU(IBIN)
7859 WTRELS=WTRELS+WTRELN(IBIN)
7860 280 CONTINUE
7861 IF(COEFSU.GT.0D0) THEN
7862 DO 290 IBIN=1,NBIN
7863 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7864 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7865 290 CONTINUE
7866 ELSE
7867 DO 300 IBIN=1,NBIN
7868 COEFO(IBIN)=1D0/NBIN
7869 300 CONTINUE
7870 ENDIF
7871 IF(IVAR.EQ.1) IOFF=0
7872 IF(IVAR.EQ.2) IOFF=17
7873 IF(IVAR.EQ.3) IOFF=7
7874 IF(IVAR.EQ.4) IOFF=12
7875 DO 310 IBIN=1,NBIN
7876 ICOF=IOFF+IBIN
7877 IF(IVAR.EQ.1) THEN
7878 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
7879 ICOF=7
7880 ENDIF
7881 ENDIF
7882 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7883 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
7884 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
7885 ELSE
7886 COEF(ISUB,ICOF)=COEFO(IBIN)
7887 ENDIF
7888 310 CONTINUE
7889
7890 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7891 & (COEFO(IBIN),IBIN=1,NBIN)
7892
7893 320 CONTINUE
7894
7895C...Find two most promising maxima among points previously determined.
7896 DO 330 J=1,4
7897 IACCMX(J)=0
7898 SIGSMX(J)=0D0
7899 330 CONTINUE
7900 NMAX=0
7901 DO 390 IACC=1,NACC
7902 DO 340 J=1,30
7903 VINT(10+J)=VINTPT(IACC,J)
7904 340 CONTINUE
7905 IF(ISTSB.NE.5) THEN
7906 CALL PYSIGH(NCHN,SIGS)
7907 IF(MWTXS.EQ.1) THEN
7908 CALL PYEVWT(WTXS)
7909 SIGS=WTXS*SIGS
7910 ENDIF
7911 ELSE
7912 SIGS=0D0
7913 DO 350 IKIN3=1,MSTP(129)
7914 CALL PYKMAP(5,0,0D0)
7915 IF(MINT(51).EQ.1) GOTO 350
7916 CALL PYSIGH(NCHN,SIGTMP)
7917 IF(MWTXS.EQ.1) THEN
7918 CALL PYEVWT(WTXS)
7919 SIGTMP=WTXS*SIGTMP
7920 ENDIF
7921 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7922 350 CONTINUE
7923 ENDIF
7924 IEQ=0
7925 DO 360 IMV=1,NMAX
7926 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7927 360 CONTINUE
7928 IF(IEQ.EQ.0) THEN
7929 DO 370 IMV=NMAX,1,-1
7930 IIN=IMV+1
7931 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7932 IACCMX(IMV+1)=IACCMX(IMV)
7933 SIGSMX(IMV+1)=SIGSMX(IMV)
7934 370 CONTINUE
7935 IIN=1
7936 380 IACCMX(IIN)=IACC
7937 SIGSMX(IIN)=SIGS
7938 IF(NMAX.LE.1) NMAX=NMAX+1
7939 ENDIF
7940 390 CONTINUE
7941
7942C...Read out starting position for search.
7943 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7944 SIGSAM=SIGSMX(1)
7945 DO 440 IMAX=1,NMAX
7946 IACC=IACCMX(IMAX)
7947 MTAU=MVARPT(IACC,1)
7948 MTAUP=MVARPT(IACC,2)
7949 MYST=MVARPT(IACC,3)
7950 MCTH=MVARPT(IACC,4)
7951 VTAU=0.5D0
7952 VYST=0.5D0
7953 VCTH=0.5D0
7954 VTAUP=0.5D0
7955
7956C...Starting point and step size in parameter space.
7957 DO 430 IRPT=1,2
7958 DO 420 IVAR=1,4
7959 IF(NPTS(IVAR).EQ.1) GOTO 420
7960 IF(IVAR.EQ.1) VVAR=VTAU
7961 IF(IVAR.EQ.2) VVAR=VTAUP
7962 IF(IVAR.EQ.3) VVAR=VYST
7963 IF(IVAR.EQ.4) VVAR=VCTH
7964 IF(IVAR.EQ.1) MVAR=MTAU
7965 IF(IVAR.EQ.2) MVAR=MTAUP
7966 IF(IVAR.EQ.3) MVAR=MYST
7967 IF(IVAR.EQ.4) MVAR=MCTH
7968 IF(IRPT.EQ.1) VDEL=0.1D0
7969 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7970 & 0.98D0-VVAR))
7971 IF(IRPT.EQ.1) VMAR=0.02D0
7972 IF(IRPT.EQ.2) VMAR=0.002D0
7973 IMOV0=1
7974 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7975 DO 410 IMOV=IMOV0,8
7976
7977C...Define new point in parameter space.
7978 IF(IMOV.EQ.0) THEN
7979 INEW=2
7980 VNEW=VVAR
7981 ELSEIF(IMOV.EQ.1) THEN
7982 INEW=3
7983 VNEW=VVAR+VDEL
7984 ELSEIF(IMOV.EQ.2) THEN
7985 INEW=1
7986 VNEW=VVAR-VDEL
7987 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7988 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7989 VVAR=VVAR+VDEL
7990 SIGSSM(1)=SIGSSM(2)
7991 SIGSSM(2)=SIGSSM(3)
7992 INEW=3
7993 VNEW=VVAR+VDEL
7994 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7995 & VVAR-2D0*VDEL.GT.VMAR) THEN
7996 VVAR=VVAR-VDEL
7997 SIGSSM(3)=SIGSSM(2)
7998 SIGSSM(2)=SIGSSM(1)
7999 INEW=1
8000 VNEW=VVAR-VDEL
8001 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8002 VDEL=0.5D0*VDEL
8003 VVAR=VVAR+VDEL
8004 SIGSSM(1)=SIGSSM(2)
8005 INEW=2
8006 VNEW=VVAR
8007 ELSE
8008 VDEL=0.5D0*VDEL
8009 VVAR=VVAR-VDEL
8010 SIGSSM(3)=SIGSSM(2)
8011 INEW=2
8012 VNEW=VVAR
8013 ENDIF
8014
8015C...Convert to relevant variables and find derived new limits.
8016 ILERR=0
8017 IF(IVAR.EQ.1) THEN
8018 VTAU=VNEW
8019 CALL PYKMAP(1,MTAU,VTAU)
8020 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8021 CALL PYKLIM(4)
8022 IF(MINT(51).EQ.1) ILERR=1
8023 ENDIF
8024 ENDIF
8025 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8026 & ILERR.EQ.0) THEN
8027 IF(IVAR.EQ.2) VTAUP=VNEW
8028 CALL PYKMAP(4,MTAUP,VTAUP)
8029 ENDIF
8030 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8031 CALL PYKLIM(2)
8032 IF(MINT(51).EQ.1) ILERR=1
8033 ENDIF
8034 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8035 IF(IVAR.EQ.3) VYST=VNEW
8036 CALL PYKMAP(2,MYST,VYST)
8037 CALL PYKLIM(3)
8038 IF(MINT(51).EQ.1) ILERR=1
8039 ENDIF
8040 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8041 & ILERR.EQ.0) THEN
8042 IF(IVAR.EQ.4) VCTH=VNEW
8043 CALL PYKMAP(3,MCTH,VCTH)
8044 ENDIF
8045 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8046
8047C...Evaluate cross-section. Save new maximum. Final maximum.
8048 IF(ILERR.NE.0) THEN
8049 SIGS=0.
8050 ELSEIF(ISTSB.NE.5) THEN
8051 CALL PYSIGH(NCHN,SIGS)
8052 IF(MWTXS.EQ.1) THEN
8053 CALL PYEVWT(WTXS)
8054 SIGS=WTXS*SIGS
8055 ENDIF
8056 ELSE
8057 SIGS=0D0
8058 DO 400 IKIN3=1,MSTP(129)
8059 CALL PYKMAP(5,0,0D0)
8060 IF(MINT(51).EQ.1) GOTO 400
8061 CALL PYSIGH(NCHN,SIGTMP)
8062 IF(MWTXS.EQ.1) THEN
8063 CALL PYEVWT(WTXS)
8064 SIGTMP=WTXS*SIGTMP
8065 ENDIF
8066 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8067 400 CONTINUE
8068 ENDIF
8069 SIGSSM(INEW)=SIGS
8070 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8071 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8072 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8073 410 CONTINUE
8074 420 CONTINUE
8075 430 CONTINUE
8076 440 CONTINUE
8077 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8078 XSEC(ISUB,1)=1.05D0*SIGSAM
8079 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8080 & WTGAGA*XSEC(ISUB,1)
8081 450 CONTINUE
8082 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8083 & PARP(174)*XSEC(ISUB,1)
8084 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8085 460 CONTINUE
8086 MINT(51)=0
8087
8088C...Print summary table.
8089 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8090 IF(MSTP(127).NE.1) THEN
8091 WRITE(MSTU(11),5900)
8092 CALL PYSTOP(1)
8093 ELSE
8094 WRITE(MSTU(11),6400)
8095 MSTI(53)=1
8096 ENDIF
8097 ENDIF
8098 IF(MSTP(122).GE.1) THEN
8099 WRITE(MSTU(11),6000)
8100 WRITE(MSTU(11),6100)
8101 DO 470 ISUB=1,500
8102 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8103 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8104 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8105 & GOTO 470
8106 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8107 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8108 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8109 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8110 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8111 470 CONTINUE
8112 WRITE(MSTU(11),6300)
8113 ENDIF
8114
8115C...Format statements for maximization results.
8116 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8117 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8118 &'cth',9X,'tau''',7X,'sigma')
8119 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8120 &'phase space.'/1X,'Process switched off!')
8121 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8122 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8123 &'cross-section.'/1X,'Process switched off!')
8124 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8125 5500 FORMAT(1X,1P,10D11.3)
8126 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8127 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8128 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8129 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8130 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8131 &'cross-section.'/1X,'Execution stopped!')
8132 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8133 &'cross-section maximum search',1X,8('*'))
8134 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8135 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8136 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8137 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8138 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8139 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8140 &'cross-section.'/
8141 &1X,'Execution will stop if you try to generate events.')
8142
8143 RETURN
8144 END
8145
8146C*********************************************************************
8147
8148C...PYPILE
8149C...Initializes multiplicity distribution and selects mutliplicity
8150C...of pileup events, i.e. several events occuring at the same
8151C...beam crossing.
8152
8153 SUBROUTINE PYPILE(MPILE)
8154
8155C...Double precision and integer declarations.
8156 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8157 IMPLICIT INTEGER(I-N)
8158 INTEGER PYK,PYCHGE,PYCOMP
8159C...Commonblocks.
8160 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8161 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8162 COMMON/PYINT1/MINT(400),VINT(400)
8163 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8164 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8165C...Local arrays and saved variables.
8166 DIMENSION WTI(0:200)
8167 SAVE IMIN,IMAX,WTI,WTS
8168
8169C...Sum of allowed cross-sections for pileup events.
8170 IF(MPILE.EQ.1) THEN
8171 VINT(131)=SIGT(0,0,5)
8172 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8173 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8174 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8175 IF(MSTP(133).LE.0) RETURN
8176
8177C...Initialize multiplicity distribution at maximum.
8178 XNAVE=VINT(131)*PARP(131)
8179 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8180 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8181 WTI(INAVE)=1D0
8182 WTS=WTI(INAVE)
8183 WTN=WTI(INAVE)*INAVE
8184
8185C...Find shape of multiplicity distribution below maximum.
8186 IMIN=INAVE
8187 DO 100 I=INAVE-1,1,-1
8188 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8189 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8190 IF(WTI(I).LT.1D-6) GOTO 110
8191 WTS=WTS+WTI(I)
8192 WTN=WTN+WTI(I)*I
8193 IMIN=I
8194 100 CONTINUE
8195
8196C...Find shape of multiplicity distribution above maximum.
8197 110 IMAX=INAVE
8198 DO 120 I=INAVE+1,200
8199 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8200 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8201 IF(WTI(I).LT.1D-6) GOTO 130
8202 WTS=WTS+WTI(I)
8203 WTN=WTN+WTI(I)*I
8204 IMAX=I
8205 120 CONTINUE
8206 130 VINT(132)=XNAVE
8207 VINT(133)=WTN/WTS
8208 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8209 & WTS/(WTS+WTI(1)/XNAVE)
8210 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8211 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8212
8213C...Pick multiplicity of pileup events.
8214 ELSE
8215 IF(MSTP(133).LE.0) THEN
8216 MINT(81)=MAX(1,MSTP(134))
8217 ELSE
8218 WTR=WTS*PYR(0)
8219 DO 140 I=IMIN,IMAX
8220 MINT(81)=I
8221 WTR=WTR-WTI(I)
8222 IF(WTR.LE.0D0) GOTO 150
8223 140 CONTINUE
8224 150 CONTINUE
8225 ENDIF
8226 ENDIF
8227
8228C...Format statement for error message.
8229 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8230 &'crossing too large, ',1P,D12.4)
8231
8232 RETURN
8233 END
8234
8235C*********************************************************************
8236
8237C...PYSAVE
8238C...Saves and restores parameter and cross section values for the
8239C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8240C...Also makes random choice between alternatives.
8241
8242 SUBROUTINE PYSAVE(ISAVE,IGA)
8243
8244C...Double precision and integer declarations.
8245 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8246 IMPLICIT INTEGER(I-N)
8247 INTEGER PYK,PYCHGE,PYCOMP
8248C...Commonblocks.
8249 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8251 COMMON/PYINT1/MINT(400),VINT(400)
8252 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8253 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8254 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8255 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8256C...Local arrays and saved variables.
8257 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8258 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8259 &INTCP(15,20),RECP(15,20)
8260 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8261
8262C...Save list of subprocesses and cross-section information.
8263 IF(ISAVE.EQ.1) THEN
8264 ICP=0
8265 DO 120 I=1,500
8266 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8267 ICP=ICP+1
8268 NSUBCP(IGA,ICP)=I
8269 MSUBCP(IGA,ICP)=MSUB(I)
8270 DO 100 J=1,20
8271 COEFCP(IGA,ICP,J)=COEF(I,J)
8272 100 CONTINUE
8273 DO 110 J=1,3
8274 NGENCP(IGA,ICP,J)=NGEN(I,J)
8275 XSECCP(IGA,ICP,J)=XSEC(I,J)
8276 110 CONTINUE
8277 120 CONTINUE
8278 NCP(IGA)=ICP
8279 DO 130 J=1,3
8280 NGENCP(IGA,0,J)=NGEN(0,J)
8281 XSECCP(IGA,0,J)=XSEC(0,J)
8282 130 CONTINUE
8283 DO 160 I1=0,6
8284 DO 150 I2=0,6
8285 DO 140 J=0,5
8286 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8287 140 CONTINUE
8288 150 CONTINUE
8289 160 CONTINUE
8290
8291C...Save various common process variables.
8292 DO 170 J=1,10
8293 INTCP(IGA,J)=MINT(40+J)
8294 170 CONTINUE
8295 INTCP(IGA,11)=MINT(101)
8296 INTCP(IGA,12)=MINT(102)
8297 INTCP(IGA,13)=MINT(107)
8298 INTCP(IGA,14)=MINT(108)
8299 INTCP(IGA,15)=MINT(123)
8300 RECP(IGA,1)=CKIN(3)
8301 RECP(IGA,2)=VINT(318)
8302
8303C...Save cross-section information only.
8304 ELSEIF(ISAVE.EQ.2) THEN
8305 DO 190 ICP=1,NCP(IGA)
8306 I=NSUBCP(IGA,ICP)
8307 DO 180 J=1,3
8308 NGENCP(IGA,ICP,J)=NGEN(I,J)
8309 XSECCP(IGA,ICP,J)=XSEC(I,J)
8310 180 CONTINUE
8311 190 CONTINUE
8312 DO 200 J=1,3
8313 NGENCP(IGA,0,J)=NGEN(0,J)
8314 XSECCP(IGA,0,J)=XSEC(0,J)
8315 200 CONTINUE
8316
8317C...Choose between allowed alternatives.
8318 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8319 IF(ISAVE.EQ.4) THEN
8320 XSUMCP=0D0
8321 DO 210 IG=1,MINT(121)
8322 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8323 210 CONTINUE
8324 XSUMCP=XSUMCP*PYR(0)
8325 DO 220 IG=1,MINT(121)
8326 IGA=IG
8327 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8328 IF(XSUMCP.LE.0D0) GOTO 230
8329 220 CONTINUE
8330 230 CONTINUE
8331 ENDIF
8332
8333C...Restore cross-section information.
8334 DO 240 I=1,500
8335 MSUB(I)=0
8336 240 CONTINUE
8337 DO 270 ICP=1,NCP(IGA)
8338 I=NSUBCP(IGA,ICP)
8339 MSUB(I)=MSUBCP(IGA,ICP)
8340 DO 250 J=1,20
8341 COEF(I,J)=COEFCP(IGA,ICP,J)
8342 250 CONTINUE
8343 DO 260 J=1,3
8344 NGEN(I,J)=NGENCP(IGA,ICP,J)
8345 XSEC(I,J)=XSECCP(IGA,ICP,J)
8346 260 CONTINUE
8347 270 CONTINUE
8348 DO 280 J=1,3
8349 NGEN(0,J)=NGENCP(IGA,0,J)
8350 XSEC(0,J)=XSECCP(IGA,0,J)
8351 280 CONTINUE
8352 DO 310 I1=0,6
8353 DO 300 I2=0,6
8354 DO 290 J=0,5
8355 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8356 290 CONTINUE
8357 300 CONTINUE
8358 310 CONTINUE
8359
8360C...Restore various common process variables.
8361 DO 320 J=1,10
8362 MINT(40+J)=INTCP(IGA,J)
8363 320 CONTINUE
8364 MINT(101)=INTCP(IGA,11)
8365 MINT(102)=INTCP(IGA,12)
8366 MINT(107)=INTCP(IGA,13)
8367 MINT(108)=INTCP(IGA,14)
8368 MINT(123)=INTCP(IGA,15)
8369 CKIN(3)=RECP(IGA,1)
8370 CKIN(1)=2D0*CKIN(3)
8371 VINT(318)=RECP(IGA,2)
8372
8373C...Sum up cross-section info (for PYSTAT).
8374 ELSEIF(ISAVE.EQ.5) THEN
8375 DO 330 I=1,500
8376 MSUB(I)=0
8377 NGEN(I,1)=0
8378 NGEN(I,3)=0
8379 XSEC(I,3)=0D0
8380 330 CONTINUE
8381 NGEN(0,1)=0
8382 NGEN(0,2)=0
8383 NGEN(0,3)=0
8384 XSEC(0,3)=0
8385 DO 350 IG=1,MINT(121)
8386 DO 340 ICP=1,NCP(IG)
8387 I=NSUBCP(IG,ICP)
8388 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8389 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8390 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8391 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8392 340 CONTINUE
8393 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8394 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8395 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8396 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8397 350 CONTINUE
8398 ENDIF
8399
8400 RETURN
8401 END
8402
8403C*********************************************************************
8404
8405C...PYGAGA
8406C...For lepton beams it gives photon-hadron or photon-photon systems
8407C...to be treated with the ordinary machinery and combines this with a
8408C...description of the lepton -> lepton + photon branching.
8409
8410 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8411
8412C...Double precision and integer declarations.
8413 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8414 IMPLICIT INTEGER(I-N)
8415 INTEGER PYK,PYCHGE,PYCOMP
8416C...Commonblocks.
8417 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8418 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8419 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8420 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8421 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8422 COMMON/PYINT1/MINT(400),VINT(400)
8423 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8424 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8425 &/PYINT5/
8426C...Local variables and data statement.
8427 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8428 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8429 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8430 DATA EPS/1D-4/
8431
8432C...Initialize generation of photons inside leptons.
8433 IF(IGAGA.EQ.1) THEN
8434
8435C...Save quantities on incoming lepton system.
8436 VINT(301)=VINT(1)
8437 VINT(302)=VINT(2)
8438 PMS(1)=VINT(303)**2
8439 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8440 PMS(2)=VINT(304)**2
8441 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8442 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8443 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8444
8445C...Calculate range of x and Q2 values allowed in generation.
8446 DO 100 I=1,2
8447 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8448 IF(MINT(140+I).NE.0) THEN
8449 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8450 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8451 & PMC(I),1D0-EPS)
8452 YMIN=MAX(CKIN(71+2*I),EPS)
8453 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8454 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8455 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8456 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8457 THEMIN=MAX(CKIN(67+2*I),0D0)
8458 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8459 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8460 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8461 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8462 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8463 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8464 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8465 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8466 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8467C...W limits when lepton on one side only.
8468 IF(MINT(143-I).EQ.0) THEN
8469 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8470 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8471 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8472 ENDIF
8473 ENDIF
8474 100 CONTINUE
8475
8476C...W limits when lepton on both sides.
8477 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8478 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8479 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8480 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8481 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8482 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8483 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8484 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8485 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8486 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8487 ELSE
8488 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8489 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8490 ENDIF
8491 ENDIF
8492
8493C...Q2 and W values and photon flux weight factors for initialization.
8494 ELSEIF(IGAGA.EQ.2) THEN
8495 ISUB=MINT(1)
8496 MINT(15)=0
8497 MINT(16)=0
8498
8499C...W value for photon on one or both sides, and for processes
8500C...with gamma-gamma cross section peaked at small shat.
8501 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8502 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8503 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8504 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8505 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8506 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8507 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8508 ELSE
8509 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8510 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8511 ENDIF
8512 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8513
8514C...Upper estimate of photon flux weight factor.
8515C...Initialization Q2 scale. Flag incoming unresolved photon.
8516 WTGAGA=1D0
8517 DO 110 I=1,2
8518 IF(MINT(140+I).NE.0) THEN
8519 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8520 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8521 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8522 & THEN
8523 Q2INIT=5D0+Q2MIN(3-I)
8524 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8525 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8526 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8527 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8528 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8529 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8530 Q2INIT=VINT(2)/3D0
8531 ELSEIF(ISUB.EQ.140) THEN
8532 Q2INIT=VINT(2)/2D0
8533 ELSE
8534 Q2INIT=Q2MIN(I)
8535 ENDIF
8536 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8537 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8538 & MINT(14+I)=22
8539 VINT(306+I)=VINT(2+I)**2
8540 ENDIF
8541 110 CONTINUE
8542 VINT(320)=WTGAGA
8543
8544C...Update pTmin and cross section information.
8545 IF(MSTP(82).LE.1) THEN
8546 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8547 ELSE
8548 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8549 ENDIF
8550 VINT(149)=4D0*PTMN**2/VINT(2)
8551 VINT(154)=PTMN
8552 CALL PYXTOT
8553 VINT(318)=VINT(317)
8554
8555C...Generate photons inside leptons and
8556C...calculate photon flux weight factors.
8557 ELSEIF(IGAGA.EQ.3) THEN
8558 ISUB=MINT(1)
8559 MINT(15)=0
8560 MINT(16)=0
8561
8562C...Generate phase space point and check against cuts.
8563 LOOP=0
8564 120 LOOP=LOOP+1
8565 DO 130 I=1,2
8566 IF(MINT(140+I).NE.0) THEN
8567C...Pick x and Q2
8568 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8569 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8570C...Cuts on internal consistency in x and Q2.
8571 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8572 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8573 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8574C...Cuts on y and theta.
8575 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8576 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8577 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8578 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8579 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8580 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8581 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8582 & GOTO 120
8583
8584C...Phi angle isotropic. Reconstruct pT.
8585 PHI(I)=PARU(2)*PYR(0)
8586 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8587 & PMS(I))*SIN(THETA(I))
8588
8589C...Store info on variables selected, for documentation purposes.
8590 VINT(2+I)=-SQRT(Q2(I))
8591 VINT(304+I)=X(I)
8592 VINT(306+I)=Q2(I)
8593 VINT(308+I)=Y(I)
8594 VINT(310+I)=THETA(I)
8595 VINT(312+I)=PHI(I)
8596 ELSE
8597 VINT(304+I)=1D0
8598 VINT(306+I)=0D0
8599 VINT(308+I)=1D0
8600 VINT(310+I)=0D0
8601 VINT(312+I)=0D0
8602 ENDIF
8603 130 CONTINUE
8604
8605C...Cut on W combines info from two sides.
8606 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8607 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8608 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8609 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8610 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8611 IF(W2.LT.W2MIN) GOTO 120
8612 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8613 PMS1=-Q2(1)
8614 PMS2=-Q2(2)
8615 ELSEIF(MINT(141).NE.0) THEN
8616 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8617 PMS1=-Q2(1)
8618 PMS2=PMS(2)
8619 ELSEIF(MINT(142).NE.0) THEN
8620 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8621 PMS1=PMS(1)
8622 PMS2=-Q2(2)
8623 ENDIF
8624
8625C...Store kinematics info for photon(s) in subsystem cm frame.
8626 VINT(2)=W2
8627 VINT(1)=SQRT(W2)
8628 VINT(291)=0D0
8629 VINT(292)=0D0
8630 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8631 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8632 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8633 VINT(296)=0D0
8634 VINT(297)=0D0
8635 VINT(298)=-VINT(293)
8636 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8637 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8638
8639C...Assign weight for photon flux; different for transverse and
8640C...longitudinal photons. Flag incoming unresolved photon.
8641 WTGAGA=1D0
8642 DO 140 I=1,2
8643 IF(MINT(140+I).NE.0) THEN
8644 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8645 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8646 IF(MSTP(16).EQ.0) THEN
8647 XY=X(I)
8648 ELSE
8649 WTGAGA=WTGAGA*X(I)/Y(I)
8650 XY=Y(I)
8651 ENDIF
8652 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8653 WTGAGA=WTGAGA*(1D0-XY)
8654 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8655 WTGAGA=WTGAGA*(1D0-XY)
8656 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8657 WTGAGA=WTGAGA*(1D0-XY)
8658 ELSE
8659 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8660 & PMS(I)*XY**2/Q2(I))
8661 ENDIF
8662 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8663 ENDIF
8664 140 CONTINUE
8665 VINT(319)=WTGAGA
8666 MINT(143)=LOOP
8667
8668C...Update pTmin and cross section information.
8669 IF(MSTP(82).LE.1) THEN
8670 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8671 ELSE
8672 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8673 ENDIF
8674 VINT(149)=4D0*PTMN**2/VINT(2)
8675 VINT(154)=PTMN
8676 CALL PYXTOT
8677
8678C...Reconstruct kinematics of photons inside leptons.
8679 ELSEIF(IGAGA.EQ.4) THEN
8680
8681C...Make place for incoming particles and scattered leptons.
8682 MOVE=3
8683 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8684 MINT(4)=MINT(4)+MOVE
8685 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8686 IF(K(I,1).EQ.21) THEN
8687 DO 150 J=1,5
8688 K(I+MOVE,J)=K(I,J)
8689 P(I+MOVE,J)=P(I,J)
8690 V(I+MOVE,J)=V(I,J)
8691 150 CONTINUE
8692 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8693 & K(I+MOVE,3)=K(I,3)+MOVE
8694 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8695 & K(I+MOVE,4)=K(I,4)+MOVE
8696 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8697 & K(I+MOVE,5)=K(I,5)+MOVE
8698 ENDIF
8699 160 CONTINUE
8700 DO 170 I=MINT(84)+1,N
8701 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8702 & K(I,3)=K(I,3)+MOVE
8703 170 CONTINUE
8704
8705C...Fill in incoming particles.
8706 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8707 DO 180 J=1,5
8708 K(I,J)=0
8709 P(I,J)=0D0
8710 V(I,J)=0D0
8711 180 CONTINUE
8712 190 CONTINUE
8713 DO 200 I=1,2
8714 K(MINT(83)+I,1)=21
8715 IF(MINT(140+I).NE.0) THEN
8716 K(MINT(83)+I,2)=MINT(140+I)
8717 P(MINT(83)+I,5)=VINT(302+I)
8718 ELSE
8719 K(MINT(83)+I,2)=MINT(10+I)
8720 P(MINT(83)+I,5)=VINT(2+I)
8721 ENDIF
8722 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8723 & VINT(302))*(-1D0)**(I+1)
8724 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8725 200 CONTINUE
8726
8727C...New mother-daughter relations in documentation section.
8728 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8729 K(MINT(83)+1,4)=MINT(83)+3
8730 K(MINT(83)+1,5)=MINT(83)+5
8731 K(MINT(83)+2,4)=MINT(83)+4
8732 K(MINT(83)+2,5)=MINT(83)+6
8733 K(MINT(83)+3,3)=MINT(83)+1
8734 K(MINT(83)+5,3)=MINT(83)+1
8735 K(MINT(83)+4,3)=MINT(83)+2
8736 K(MINT(83)+6,3)=MINT(83)+2
8737 ELSEIF(MINT(141).NE.0) THEN
8738 K(MINT(83)+1,4)=MINT(83)+3
8739 K(MINT(83)+1,5)=MINT(83)+4
8740 K(MINT(83)+2,4)=MINT(83)+5
8741 K(MINT(83)+3,3)=MINT(83)+1
8742 K(MINT(83)+4,3)=MINT(83)+1
8743 K(MINT(83)+5,3)=MINT(83)+2
8744 ELSEIF(MINT(142).NE.0) THEN
8745 K(MINT(83)+1,4)=MINT(83)+4
8746 K(MINT(83)+2,4)=MINT(83)+3
8747 K(MINT(83)+2,5)=MINT(83)+5
8748 K(MINT(83)+3,3)=MINT(83)+2
8749 K(MINT(83)+4,3)=MINT(83)+1
8750 K(MINT(83)+5,3)=MINT(83)+2
8751 ENDIF
8752
8753C...Fill scattered lepton(s).
8754 DO 210 I=1,2
8755 IF(MINT(140+I).NE.0) THEN
8756 LSC=MINT(83)+MIN(I+2,MOVE)
8757 K(LSC,1)=21
8758 K(LSC,2)=MINT(140+I)
8759 P(LSC,1)=PT(I)*COS(PHI(I))
8760 P(LSC,2)=PT(I)*SIN(PHI(I))
8761 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8762 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8763 & (-1D0)**(I-1)
8764 P(LSC,5)=VINT(302+I)
8765 ENDIF
8766 210 CONTINUE
8767
8768C...Find incoming four-vectors to subprocess.
8769 K(N+1,1)=21
8770 IF(MINT(141).NE.0) THEN
8771 DO 220 J=1,4
8772 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8773 220 CONTINUE
8774 ELSE
8775 DO 230 J=1,4
8776 P(N+1,J)=P(MINT(83)+1,J)
8777 230 CONTINUE
8778 ENDIF
8779 K(N+2,1)=21
8780 IF(MINT(142).NE.0) THEN
8781 DO 240 J=1,4
8782 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8783 240 CONTINUE
8784 ELSE
8785 DO 250 J=1,4
8786 P(N+2,J)=P(MINT(83)+2,J)
8787 250 CONTINUE
8788 ENDIF
8789
8790C...Define boost and rotation between hadronic subsystem and
8791C...collision rest frame; boost hadronic subsystem to this frame.
8792 DO 260 J=1,3
8793 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8794 260 CONTINUE
8795 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8796 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8797 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8798 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8799 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8800 & BETA(3))
8801
8802C...Add on scattered leptons to final state.
8803 DO 280 I=1,2
8804 IF(MINT(140+I).NE.0) THEN
8805 LSC=MINT(83)+MIN(I+2,MOVE)
8806 N=N+1
8807 DO 270 J=1,5
8808 K(N,J)=K(LSC,J)
8809 P(N,J)=P(LSC,J)
8810 V(N,J)=V(LSC,J)
8811 270 CONTINUE
8812 K(N,1)=1
8813 K(N,3)=LSC
8814 ENDIF
8815 280 CONTINUE
8816 ENDIF
8817
8818 RETURN
8819 END
8820
8821C*********************************************************************
8822
8823C...PYRAND
8824C...Generates quantities characterizing the high-pT scattering at the
8825C...parton level according to the matrix elements. Chooses incoming,
8826C...reacting partons, their momentum fractions and one of the possible
8827C...subprocesses.
8828
8829 SUBROUTINE PYRAND
8830
8831C...Double precision and integer declarations.
8832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8833 IMPLICIT INTEGER(I-N)
8834 INTEGER PYK,PYCHGE,PYCOMP
8835C...Parameter statement to help give large particle numbers.
8836 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8837 &KEXCIT=4000000,KDIMEN=5000000)
8838
8839C...User process initialization and event commonblocks.
8840 INTEGER MAXPUP
8841 PARAMETER (MAXPUP=100)
8842 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8843 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8844 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8845 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8846 &LPRUP(MAXPUP)
8847 INTEGER MAXNUP
8848 PARAMETER (MAXNUP=500)
8849 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8850 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8851 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8852 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8853 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8854 SAVE /HEPRUP/,/HEPEUP/
8855
8856C...Commonblocks.
8857 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8858 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8859 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8860 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8861 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8862 COMMON/PYINT1/MINT(400),VINT(400)
8863 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8864 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8865 COMMON/PYINT4/MWID(500),WIDS(500,5)
8866 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8867 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8868 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8869 COMMON/PYTCCO/COEFX(194:380,2)
8870 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
8871 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8872 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
8873 &/TCPARA/
8874C...Local arrays.
8875 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8876
8877C...Parameters and data used in elastic/diffractive treatment.
8878 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8879 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8880
8881C...Initial values, specifically for (first) semihard interaction.
8882 MINT(10)=0
8883 MINT(17)=0
8884 MINT(18)=0
8885 VINT(143)=1D0
8886 VINT(144)=1D0
8887 VINT(157)=0D0
8888 VINT(158)=0D0
8889 MFAIL=0
8890 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8891 ISUB=0
8892 ISTSB=0
8893 LOOP=0
8894 100 LOOP=LOOP+1
8895 MINT(51)=0
8896 MINT(143)=1
8897 VINT(97)=1D0
8898
8899C...Start by assuming incoming photon is entering subprocess.
8900 IF(MINT(11).EQ.22) THEN
8901 MINT(15)=22
8902 VINT(307)=VINT(3)**2
8903 ENDIF
8904 IF(MINT(12).EQ.22) THEN
8905 MINT(16)=22
8906 VINT(308)=VINT(4)**2
8907 ENDIF
8908 MINT(103)=MINT(11)
8909 MINT(104)=MINT(12)
8910
8911C...Choice of process type - first event of pileup.
8912 INMULT=0
8913 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8914 ELSEIF(MINT(82).EQ.1) THEN
8915
8916C...For gamma-p or gamma-gamma first pick between alternatives.
8917 IGA=0
8918 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8919 MINT(122)=IGA
8920
8921C...For real gamma + gamma with different nature, flip at random.
8922 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8923 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8924 MINTSV=MINT(41)
8925 MINT(41)=MINT(42)
8926 MINT(42)=MINTSV
8927 MINTSV=MINT(45)
8928 MINT(45)=MINT(46)
8929 MINT(46)=MINTSV
8930 MINTSV=MINT(107)
8931 MINT(107)=MINT(108)
8932 MINT(108)=MINTSV
8933 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8934 ENDIF
8935
8936C...Pick process type, possibly by user process machinery.
8937C...(If the latter, also event will be picked here.)
8938 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8939 CALL UPEVNT
8940 CALL PYUPRE
8941 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8942 CALL UPEVNT
8943 CALL PYUPRE
8944 ISUB=0
8945 110 ISUB=ISUB+1
8946 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8947 & ISUB.LT.500) GOTO 110
8948 ELSE
8949 RSUB=XSEC(0,1)*PYR(0)
8950 DO 120 I=1,500
8951 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8952 ISUB=I
8953 RSUB=RSUB-XSEC(I,1)
8954 IF(RSUB.LE.0D0) GOTO 130
8955 120 CONTINUE
8956 130 IF(ISUB.EQ.95) ISUB=96
8957 IF(ISUB.EQ.96) INMULT=1
8958 IF(ISET(ISUB).EQ.11) THEN
8959 IDPRUP=KFPR(ISUB,2)
8960 CALL UPEVNT
8961 CALL PYUPRE
8962 ENDIF
8963 ENDIF
8964
8965C...Choice of inclusive process type - pileup events.
8966 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8967 RSUB=VINT(131)*PYR(0)
8968 ISUB=96
8969 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8970 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8971 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8972 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8973 & ISUB=91
8974 IF(ISUB.EQ.96) INMULT=1
8975 ENDIF
8976
8977C...Choice of photon energy and flux factor inside lepton.
8978 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8979 CALL PYGAGA(3,WTGAGA)
8980 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8981 CKIN(3)=MAX(VINT(285),VINT(154))
8982 CKIN(1)=2D0*CKIN(3)
8983 ENDIF
8984C...When necessary set direct/resolved photon by hand.
8985 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8986 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8987 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8988 ENDIF
8989
8990C...Restrict direct*resolved processes to pTmin >= Q,
8991C...to avoid doublecounting with DIS.
8992 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8993 IF(MINT(15).EQ.22) THEN
8994 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
8995 ELSE
8996 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
8997 ENDIF
8998 CKIN(1)=2D0*CKIN(3)
8999 ENDIF
9000
9001C...Set up for multiple interactions (may include impact parameter).
9002 IF(INMULT.EQ.1) THEN
9003 IF(MINT(35).LE.1) CALL PYMULT(2)
9004 IF(MINT(35).GE.2) CALL PYMIGN(2)
9005 ENDIF
9006
9007C...Loopback point for minimum bias in photon physics.
9008 LOOP2=0
9009 140 LOOP2=LOOP2+1
9010 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9011 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9012 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9013 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9014 MINT(1)=ISUB
9015 ISTSB=ISET(ISUB)
9016
9017C...Random choice of flavour for some SUSY processes.
9018 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9019C...~e_L ~nu_e or ~mu_L ~nu_mu.
9020 IF(ISUB.EQ.210) THEN
9021 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9022 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9023C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9024 ELSEIF(ISUB.EQ.213) THEN
9025 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9026 KFPR(ISUB,2)=KFPR(ISUB,1)
9027C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9028 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9029 & ISUB.NE.257) THEN
9030 IF(ISUB.GE.258) THEN
9031 RKF=4D0
9032 ELSE
9033 RKF=5D0
9034 ENDIF
9035 IF(MOD(ISUB,2).EQ.0) THEN
9036 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9037 ELSE
9038 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9039 ENDIF
9040C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9041 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9042 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9043 KSU1=KSUSY1
9044 KSU2=KSUSY1
9045 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9046 KSU1=KSUSY2
9047 KSU2=KSUSY2
9048 ELSEIF(PYR(0).LT.0.5D0) THEN
9049 KSU1=KSUSY1
9050 KSU2=KSUSY2
9051 ELSE
9052 KSU1=KSUSY2
9053 KSU2=KSUSY1
9054 ENDIF
9055 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9056 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9057C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9058 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9059 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9060 KFPR(ISUB,2)=KFPR(ISUB,1)
9061 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9062 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9063 KFPR(ISUB,2)=KFPR(ISUB,1)
9064C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9065 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9066 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9067 KSU1=KSUSY1
9068 KSU2=KSUSY1
9069 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9070 KSU1=KSUSY2
9071 KSU2=KSUSY2
9072 ELSEIF(PYR(0).LT.0.5D0) THEN
9073 KSU1=KSUSY1
9074 KSU2=KSUSY2
9075 ELSE
9076 KSU1=KSUSY2
9077 KSU2=KSUSY1
9078 ENDIF
9079 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9080 RKF=5D0
9081 ELSE
9082 RKF=4D0
9083 ENDIF
9084 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9085 ENDIF
9086 ENDIF
9087
9088C...Find resonances (explicit or implicit in cross-section).
9089 MINT(72)=0
9090 KFR1=0
9091 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9092 KFR1=KFPR(ISUB,1)
9093 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9094 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9095 KFR1=23
9096 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9097 & ISUB.EQ.177) THEN
9098 KFR1=24
9099 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9100 KFR1=25
9101 IF(MSTP(46).EQ.5) THEN
9102 KFR1=89
9103 PMAS(89,1)=PARP(45)
9104 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9105 ENDIF
9106 ENDIF
9107 CKMX=CKIN(2)
9108 IF(CKMX.LE.0D0) CKMX=VINT(1)
9109 KCR1=PYCOMP(KFR1)
9110 IF(KFR1.NE.0) THEN
9111 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9112 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9113 ENDIF
9114 IF(KFR1.NE.0) THEN
9115 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9116 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9117 MINT(72)=1
9118 MINT(73)=KFR1
9119 VINT(73)=TAUR1
9120 VINT(74)=GAMR1
9121 ENDIF
9122 KFR2=0
9123 KFR3=0
9124 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9125 $(ISUB.GE.361.AND.ISUB.LE.380))
9126 $THEN
9127 KFR2=23
9128 IF(ISUB.EQ.141) THEN
9129 KCR2=PYCOMP(KFR2)
9130 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9131 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9132 KFR2=0
9133 ELSE
9134 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9135 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9136 MINT(72)=2
9137 MINT(74)=KFR2
9138 VINT(75)=TAUR2
9139 VINT(76)=GAMR2
9140 ENDIF
9141C...3 resonances at work: rho, omega, a
9142 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9143 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9144 MINT(72)=IRES
9145 IF(IRES.GE.1) THEN
9146 VINT(73)=XMAS(1)**2/VINT(2)
9147 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9148 TAUR1=VINT(73)
9149 GAMR1=VINT(74)
9150 KFR1=1
9151 ENDIF
9152 IF(IRES.GE.2) THEN
9153 VINT(75)=XMAS(2)**2/VINT(2)
9154 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9155 TAUR2=VINT(75)
9156 GAMR2=VINT(76)
9157 KFR2=2
9158 ENDIF
9159 IF(IRES.EQ.3) THEN
9160 VINT(77)=XMAS(3)**2/VINT(2)
9161 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9162 TAUR3=VINT(77)
9163 GAMR3=VINT(78)
9164 KFR3=3
9165 ENDIF
9166C...Charged current: rho+- and a+-
9167 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9168 MINT(72)=IRES
9169 IF(JRES.GE.1) THEN
9170 VINT(73)=YMAS(1)**2/VINT(2)
9171 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9172 KFR1=1
9173 TAUR1=VINT(73)
9174 GAMR1=VINT(74)
9175 ENDIF
9176 IF(JRES.GE.2) THEN
9177 VINT(75)=YMAS(2)**2/VINT(2)
9178 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9179 KFR2=2
9180 TAUR2=VINT(73)
9181 GAMR2=VINT(74)
9182 ENDIF
9183 KFR3=0
9184 ENDIF
9185 IF(ISUB.NE.141) THEN
9186 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9187
9188 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9189 MINT(72)=2
9190 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9191 MINT(72)=2
9192 MINT(74)=KFR3
9193 VINT(75)=TAUR3
9194 VINT(76)=GAMR3
9195 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9196 MINT(72)=2
9197 MINT(73)=KFR2
9198 VINT(73)=TAUR2
9199 VINT(74)=GAMR2
9200 MINT(74)=KFR3
9201 VINT(75)=TAUR3
9202 VINT(76)=GAMR3
9203 ELSEIF(KFR1.NE.0) THEN
9204 MINT(72)=1
9205 ELSEIF(KFR2.NE.0) THEN
9206 MINT(72)=1
9207 MINT(73)=KFR2
9208 VINT(73)=TAUR2
9209 VINT(74)=GAMR2
9210 ELSEIF(KFR3.NE.0) THEN
9211 MINT(72)=1
9212 MINT(73)=KFR3
9213 VINT(73)=TAUR3
9214 VINT(74)=GAMR3
9215 ELSE
9216 MINT(72)=0
9217 ENDIF
9218 ELSE
9219 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9220
9221 ELSEIF(KFR2.NE.0) THEN
9222 KFR1=KFR2
9223 TAUR1=TAUR2
9224 GAMR1=GAMR2
9225 MINT(72)=1
9226 MINT(73)=KFR1
9227 VINT(73)=TAUR1
9228 VINT(74)=GAMR1
9229 KFR2=0
9230 ELSE
9231 MINT(72)=0
9232 ENDIF
9233 ENDIF
9234 ENDIF
9235
9236C...Find product masses and minimum pT of process,
9237C...optionally with broadening according to a truncated Breit-Wigner.
9238 VINT(63)=0D0
9239 VINT(64)=0D0
9240 MINT(71)=0
9241 VINT(71)=CKIN(3)
9242 IF(MINT(82).GE.2) VINT(71)=0D0
9243 VINT(80)=1D0
9244 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9245 NBW=0
9246 DO 160 I=1,2
9247 PMMN(I)=0D0
9248 IF(KFPR(ISUB,I).EQ.0) THEN
9249 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9250 & PARP(41)) THEN
9251 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9252 ELSE
9253 NBW=NBW+1
9254C...This prevents SUSY/t particles from becoming too light.
9255 KFLW=KFPR(ISUB,I)
9256 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9257 KCW=PYCOMP(KFLW)
9258 PMMN(I)=PMAS(KCW,1)
9259 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9260 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9261 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9262 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9263 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9264 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9265 PMMN(I)=MIN(PMMN(I),PMSUM)
9266 ENDIF
9267 150 CONTINUE
9268 ELSEIF(KFLW.EQ.6) THEN
9269 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9270 ENDIF
9271 ENDIF
9272 160 CONTINUE
9273 IF(NBW.GE.1) THEN
9274 CKIN41=CKIN(41)
9275 CKIN43=CKIN(43)
9276 CKIN(41)=MAX(PMMN(1),CKIN(41))
9277 CKIN(43)=MAX(PMMN(2),CKIN(43))
9278 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9279 CKIN(41)=CKIN41
9280 CKIN(43)=CKIN43
9281 IF(MINT(51).EQ.1) THEN
9282 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9283 IF(MFAIL.EQ.1) THEN
9284 MSTI(61)=1
9285 RETURN
9286 ENDIF
9287 GOTO 100
9288 ENDIF
9289 VINT(63)=PQM3**2
9290 VINT(64)=PQM4**2
9291 ENDIF
9292 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9293 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9294 ENDIF
9295
9296C...Prepare for additional variable choices in 2 -> 3.
9297 IF(ISTSB.EQ.5) THEN
9298 VINT(201)=0D0
9299 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9300 VINT(206)=VINT(201)
9301 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9302 VINT(204)=PMAS(23,1)
9303 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9304 & VINT(204)=PMAS(24,1)
9305 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9306 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9307 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9308 & VINT(204)=VINT(201)
9309 VINT(209)=VINT(204)
9310 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9311 ENDIF
9312
9313C...Select incoming VDM particle (rho/omega/phi/J/psi).
9314 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9315 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9316 VRN=PYR(0)*SIGT(0,0,5)
9317 IF(MINT(101).LE.1) THEN
9318 I1MN=0
9319 I1MX=0
9320 ELSE
9321 I1MN=1
9322 I1MX=MINT(101)
9323 ENDIF
9324 IF(MINT(102).LE.1) THEN
9325 I2MN=0
9326 I2MX=0
9327 ELSE
9328 I2MN=1
9329 I2MX=MINT(102)
9330 ENDIF
9331 DO 180 I1=I1MN,I1MX
9332 KFV1=110*I1+3
9333 DO 170 I2=I2MN,I2MX
9334 KFV2=110*I2+3
9335 VRN=VRN-SIGT(I1,I2,5)
9336 IF(VRN.LE.0D0) GOTO 190
9337 170 CONTINUE
9338 180 CONTINUE
9339 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9340 IF(MINT(102).GE.2) MINT(104)=KFV2
9341 ENDIF
9342
9343 IF(ISTSB.EQ.0) THEN
9344C...Elastic scattering or single or double diffractive scattering.
9345
9346C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9347 MINT(103)=MINT(11)
9348 MINT(104)=MINT(12)
9349 PMM(1)=VINT(3)
9350 PMM(2)=VINT(4)
9351 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9352 JJ=ISUB-90
9353 VRN=PYR(0)*SIGT(0,0,JJ)
9354 IF(MINT(101).LE.1) THEN
9355 I1MN=0
9356 I1MX=0
9357 ELSE
9358 I1MN=1
9359 I1MX=MINT(101)
9360 ENDIF
9361 IF(MINT(102).LE.1) THEN
9362 I2MN=0
9363 I2MX=0
9364 ELSE
9365 I2MN=1
9366 I2MX=MINT(102)
9367 ENDIF
9368 DO 210 I1=I1MN,I1MX
9369 KFV1=110*I1+3
9370 DO 200 I2=I2MN,I2MX
9371 KFV2=110*I2+3
9372 VRN=VRN-SIGT(I1,I2,JJ)
9373 IF(VRN.LE.0D0) GOTO 220
9374 200 CONTINUE
9375 210 CONTINUE
9376 220 IF(MINT(101).GE.2) THEN
9377 MINT(103)=KFV1
9378 PMM(1)=PYMASS(KFV1)
9379 ENDIF
9380 IF(MINT(102).GE.2) THEN
9381 MINT(104)=KFV2
9382 PMM(2)=PYMASS(KFV2)
9383 ENDIF
9384 ENDIF
9385 VINT(67)=PMM(1)
9386 VINT(68)=PMM(2)
9387
9388C...Select mass for GVMD states (rejecting previous assignment).
9389 Q0S=4D0*PARP(15)**2
9390 Q1S=4D0*VINT(154)**2
9391 LOOP3=0
9392 230 LOOP3=LOOP3+1
9393 DO 240 JT=1,2
9394 IF(MINT(106+JT).EQ.3) THEN
9395 PS=VINT(2+JT)**2
9396 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9397 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9398 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9399 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9400 ENDIF
9401 240 CONTINUE
9402 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9403 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9404 & GOTO 230
9405 GOTO 100
9406 ENDIF
9407
9408C...Side/sides of diffractive system.
9409 MINT(17)=0
9410 MINT(18)=0
9411 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9412 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9413
9414C...Find masses of particles and minimal masses of diffractive states.
9415 DO 250 JT=1,2
9416 PDIF(JT)=PMM(JT)
9417 VINT(68+JT)=PDIF(JT)
9418 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9419 250 CONTINUE
9420 SH=VINT(2)
9421 SQM1=PMM(1)**2
9422 SQM2=PMM(2)**2
9423 SQM3=PDIF(1)**2
9424 SQM4=PDIF(2)**2
9425 SMRES1=(PMM(1)+PMRC)**2
9426 SMRES2=(PMM(2)+PMRC)**2
9427
9428C...Find elastic slope and lower limit diffractive slope.
9429 IHA=MAX(2,IABS(MINT(103))/110)
9430 IF(IHA.GE.5) IHA=1
9431 IHB=MAX(2,IABS(MINT(104))/110)
9432 IF(IHB.GE.5) IHB=1
9433 IF(ISUB.EQ.91) THEN
9434 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9435 ELSEIF(ISUB.EQ.92) THEN
9436 BMN=MAX(2D0,2D0*BHAD(IHB))
9437 ELSEIF(ISUB.EQ.93) THEN
9438 BMN=MAX(2D0,2D0*BHAD(IHA))
9439 ELSEIF(ISUB.EQ.94) THEN
9440 BMN=2D0*ALP*4D0
9441 ENDIF
9442
9443C...Determine maximum possible t range and coefficient of generation.
9444 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9445 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9446 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9447 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9448 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9449 & (SQM1*SQM4-SQM2*SQM3)/SH
9450 THL=-0.5D0*(THA+THB)
9451 THU=THC/THL
9452 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9453
9454C...Select diffractive mass/masses according to dm^2/m^2.
9455 LOOP3=0
9456 260 LOOP3=LOOP3+1
9457 DO 270 JT=1,2
9458 IF(MINT(16+JT).EQ.0) THEN
9459 PDIF(2+JT)=PDIF(JT)
9460 ELSE
9461 PMMIN=PDIF(JT)
9462 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9463 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9464 ENDIF
9465 270 CONTINUE
9466 SQM3=PDIF(3)**2
9467 SQM4=PDIF(4)**2
9468
9469C..Additional mass factors, including resonance enhancement.
9470 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9471 IF(LOOP3.LT.100) GOTO 260
9472 GOTO 100
9473 ENDIF
9474 IF(ISUB.EQ.92) THEN
9475 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9476 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9477 ELSEIF(ISUB.EQ.93) THEN
9478 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9479 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9480 ELSEIF(ISUB.EQ.94) THEN
9481 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9482 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9483 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9484 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9485 ENDIF
9486
9487C...Select t according to exp(Bmn*t) and correct to right slope.
9488 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9489 IF(ISUB.GE.92) THEN
9490 IF(ISUB.EQ.92) THEN
9491 BADD=2D0*ALP*LOG(SH/SQM3)
9492 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9493 ELSEIF(ISUB.EQ.93) THEN
9494 BADD=2D0*ALP*LOG(SH/SQM4)
9495 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9496 ELSEIF(ISUB.EQ.94) THEN
9497 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9498 ENDIF
9499 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9500 ENDIF
9501
9502C...Check whether m^2 and t choices are consistent.
9503 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9504 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9505 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9506 IF(THB.LE.1D-8) GOTO 260
9507 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9508 & (SQM1*SQM4-SQM2*SQM3)/SH
9509 THLM=-0.5D0*(THA+THB)
9510 THUM=THC/THLM
9511 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9512
9513C...Information to output.
9514 VINT(21)=1D0
9515 VINT(22)=0D0
9516 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9517 VINT(45)=TH
9518 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9519 VINT(63)=PDIF(3)**2
9520 VINT(64)=PDIF(4)**2
9521 VINT(283)=PMM(1)**2/4D0
9522 VINT(284)=PMM(2)**2/4D0
9523
9524C...Note: in the following, by In is meant the integral over the
9525C...quantity multiplying coefficient cn.
9526C...Choose tau according to h1(tau)/tau, where
9527C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9528C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9529C...I1/I5*c5*1/(tau+tau_R') +
9530C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9531C...I1/I7*c7*tau/(1.-tau), and
9532C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9533 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9534 CALL PYKLIM(1)
9535 IF(MINT(51).NE.0) THEN
9536 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9537 IF(MFAIL.EQ.1) THEN
9538 MSTI(61)=1
9539 RETURN
9540 ENDIF
9541 GOTO 100
9542 ENDIF
9543 RTAU=PYR(0)
9544 MTAU=1
9545 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9546 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9547 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9548 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9549 & MTAU=5
9550 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9551 & COEF(ISUB,5)) MTAU=6
9552 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9553 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9554C...Additional check to handle techni-processes with extra resonance
9555C....Only modify tau treatment
9556 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9557 & THEN
9558 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9559 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9560 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9561 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9562 & +COEFX(ISUB,1)) MTAU=9
9563 ENDIF
9564 CALL PYKMAP(1,MTAU,PYR(0))
9565
9566C...2 -> 3, 4 processes:
9567C...Choose tau' according to h4(tau,tau')/tau', where
9568C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9569C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9570 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9571 CALL PYKLIM(4)
9572 IF(MINT(51).NE.0) THEN
9573 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9574 IF(MFAIL.EQ.1) THEN
9575 MSTI(61)=1
9576 RETURN
9577 ENDIF
9578 GOTO 100
9579 ENDIF
9580 RTAUP=PYR(0)
9581 MTAUP=1
9582 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9583 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9584 CALL PYKMAP(4,MTAUP,PYR(0))
9585 ENDIF
9586
9587C...Choose y* according to h2(y*), where
9588C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9589C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9590C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9591C...and c1 + c2 + c3 + c4 + c5 = 1.
9592 CALL PYKLIM(2)
9593 IF(MINT(51).NE.0) THEN
9594 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9595 IF(MFAIL.EQ.1) THEN
9596 MSTI(61)=1
9597 RETURN
9598 ENDIF
9599 GOTO 100
9600 ENDIF
9601 RYST=PYR(0)
9602 MYST=1
9603 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9604 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9605 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9606 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9607 & COEF(ISUB,11)) MYST=5
9608 CALL PYKMAP(2,MYST,PYR(0))
9609
9610C...2 -> 2 processes:
9611C...Choose cos(theta-hat) (cth) according to h3(cth), where
9612C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9613C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9614C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9615C...and c0 + c1 + c2 + c3 + c4 = 1.
9616 CALL PYKLIM(3)
9617 IF(MINT(51).NE.0) THEN
9618 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9619 IF(MFAIL.EQ.1) THEN
9620 MSTI(61)=1
9621 RETURN
9622 ENDIF
9623 GOTO 100
9624 ENDIF
9625 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9626 RCTH=PYR(0)
9627 MCTH=1
9628 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9629 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9630 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9631 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9632 & COEF(ISUB,16)) MCTH=5
9633 CALL PYKMAP(3,MCTH,PYR(0))
9634 ENDIF
9635
9636C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9637 IF(ISTSB.EQ.5) THEN
9638 CALL PYKMAP(5,0,0D0)
9639 IF(MINT(51).NE.0) THEN
9640 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9641 IF(MFAIL.EQ.1) THEN
9642 MSTI(61)=1
9643 RETURN
9644 ENDIF
9645 GOTO 100
9646 ENDIF
9647 ENDIF
9648
9649C...DIS as f + gamma* -> f process: set dummy values.
9650 ELSEIF(ISTSB.EQ.8) THEN
9651 VINT(21)=0.9D0
9652 VINT(22)=0D0
9653 VINT(23)=0D0
9654 VINT(47)=0D0
9655 VINT(48)=0D0
9656
9657C...Low-pT or multiple interactions (first semihard interaction).
9658 ELSEIF(ISTSB.EQ.9) THEN
9659 IF(MINT(35).LE.1) CALL PYMULT(3)
9660 IF(MINT(35).GE.2) CALL PYMIGN(3)
9661 ISUB=MINT(1)
9662
9663C...Study user-defined process: kinematics plus weight.
9664 ELSEIF(ISTSB.EQ.11) THEN
9665 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9666 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9667 MSTI(51)=0
9668 IF(NUP.LE.0) THEN
9669 MINT(51)=2
9670 MSTI(51)=1
9671 IF(MINT(82).EQ.1) THEN
9672 NGEN(0,1)=NGEN(0,1)-1
9673 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9674 ENDIF
9675 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9676 RETURN
9677 ENDIF
9678
9679C...Extract cross section event weight.
9680 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9681 SIGS=1D-9*XWGTUP
9682 ELSE
9683 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9684 ENDIF
9685 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9686 VINT(97)=SIGN(1D0,XWGTUP)
9687 ELSE
9688 VINT(97)=1D-9*XWGTUP
9689 ENDIF
9690
9691C...Construct 'trivial' kinematical variables needed.
9692 KFL1=IDUP(1)
9693 KFL2=IDUP(2)
9694 VINT(41)=PUP(4,1)/EBMUP(1)
9695 VINT(42)=PUP(4,2)/EBMUP(2)
9696 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
9697 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
9698 & '(listing follows):')
9699 CALL PYLIST(7)
9700 ENDIF
9701 VINT(21)=VINT(41)*VINT(42)
9702 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9703 VINT(44)=VINT(21)*VINT(2)
9704 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9705 VINT(55)=SCALUP
9706 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9707 VINT(56)=VINT(55)**2
9708 VINT(57)=AQEDUP
9709 VINT(58)=AQCDUP
9710
9711C...Construct other kinematical variables needed (approximately).
9712 VINT(23)=0D0
9713 VINT(26)=VINT(21)
9714 VINT(45)=-0.5D0*VINT(44)
9715 VINT(46)=-0.5D0*VINT(44)
9716 VINT(49)=VINT(43)
9717 VINT(50)=VINT(44)
9718 VINT(51)=VINT(55)
9719 VINT(52)=VINT(56)
9720 VINT(53)=VINT(55)
9721 VINT(54)=VINT(56)
9722 VINT(25)=0D0
9723 VINT(48)=0D0
9724 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9725 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9726 DO 280 IUP=3,NUP
9727 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9728 & '(PYRAND:) unacceptable ISTUP code for particles')
9729 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9730 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9731 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9732 & PUP(2,IUP)**2)
9733 280 CONTINUE
9734 VINT(47)=SQRT(VINT(48))
9735 ENDIF
9736
9737C...Choose azimuthal angle.
9738 VINT(24)=0D0
9739 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9740
9741C...Check against user cuts on kinematics at parton level.
9742 MINT(51)=0
9743 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9744 IF(MINT(51).NE.0) THEN
9745 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9746 IF(MFAIL.EQ.1) THEN
9747 MSTI(61)=1
9748 RETURN
9749 ENDIF
9750 GOTO 100
9751 ENDIF
9752 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9753 MCUT=0
9754 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9755 & CALL PYKCUT(MCUT)
9756 IF(MCUT.NE.0) THEN
9757 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9758 IF(MFAIL.EQ.1) THEN
9759 MSTI(61)=1
9760 RETURN
9761 ENDIF
9762 GOTO 100
9763 ENDIF
9764 ENDIF
9765
9766C...Calculate differential cross-section for different subprocesses.
9767 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9768 SIGSOR=SIGS
9769 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9770
9771C...Multiply cross section by lepton -> photon flux factor.
9772 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9773 SIGS=WTGAGA*SIGS
9774 DO 290 ICHN=1,NCHN
9775 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9776 290 CONTINUE
9777 SIGLPT=WTGAGA*SIGLPT
9778 ENDIF
9779
9780C...Multiply cross-section by user-defined weights.
9781 IF(MSTP(173).EQ.1) THEN
9782 SIGS=PARP(173)*SIGS
9783 DO 300 ICHN=1,NCHN
9784 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9785 300 CONTINUE
9786 SIGLPT=PARP(173)*SIGLPT
9787 ENDIF
9788 WTXS=1D0
9789 SIGSWT=SIGS
9790 VINT(99)=1D0
9791 VINT(100)=1D0
9792 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9793 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9794 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9795 SIGSWT=WTXS*SIGS
9796 VINT(99)=WTXS
9797 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9798 ENDIF
9799
9800C...Calculations for Monte Carlo estimate of all cross-sections.
9801 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9802 IF(MSTP(142).LE.1) THEN
9803 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9804 ELSE
9805 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9806 ENDIF
9807 ELSEIF(MINT(82).EQ.1) THEN
9808 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9809 ENDIF
9810 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9811 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9812
9813C...Multiple interactions: store results of cross-section calculation.
9814 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9815 VINT(153)=SIGSOR
9816 IF(MINT(35).LE.1) CALL PYMULT(4)
9817 IF(MINT(35).GE.2) CALL PYMIGN(4)
9818 ENDIF
9819
9820C...Ratio of actual to maximum cross section.
9821 IF(ISTSB.NE.11) THEN
9822 VIOL=SIGSWT/XSEC(ISUB,1)
9823 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9824 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9825 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9826 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9827 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9828 ELSE
9829 VIOL=1D0
9830 ENDIF
9831
9832C...Check that weight not negative.
9833 IF(MSTP(123).LE.0) THEN
9834 IF(VIOL.LT.-1D-3) THEN
9835 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9836 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9837 & VINT(22),VINT(23),VINT(26)
9838 CALL PYSTOP(2)
9839 ENDIF
9840 ELSE
9841 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9842 VINT(109)=VIOL
9843 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9844 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9845 & VINT(22),VINT(23),VINT(26)
9846 ENDIF
9847 ENDIF
9848
9849C...Weighting using estimate of maximum of differential cross-section.
9850 RATND=1D0
9851 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9852 IF(VIOL.LT.PYR(0)) THEN
9853 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9854 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9855 GOTO 100
9856 ENDIF
9857 ELSEIF(MFAIL.EQ.0) THEN
9858 RATND=SIGLPT/XSEC(95,1)
9859 VIOL=VIOL/RATND
9860 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9861 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9862 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9863 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9864 ISUB=0
9865 GOTO 100
9866 ENDIF
9867 IF(VIOL.LT.PYR(0)) THEN
9868 GOTO 140
9869 ENDIF
9870 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9871 IF(VIOL.LT.PYR(0)) THEN
9872 MSTI(61)=1
9873 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9874 RETURN
9875 ENDIF
9876 ELSE
9877 RATND=SIGLPT/XSEC(95,1)
9878 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9879 MSTI(61)=1
9880 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9881 RETURN
9882 ENDIF
9883 VIOL=VIOL/RATND
9884 IF(VIOL.LT.PYR(0)) THEN
9885 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9886 GOTO 100
9887 ENDIF
9888 ENDIF
9889
9890C...Check for possible violation of estimated maximum of differential
9891C...cross-section used in weighting.
9892 IF(MSTP(123).LE.0) THEN
9893 IF(VIOL.GT.1D0) THEN
9894 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9895 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9896 & VINT(22),VINT(23),VINT(26)
9897 CALL PYSTOP(2)
9898 ENDIF
9899 ELSEIF(MSTP(123).EQ.1) THEN
9900 IF(VIOL.GT.VINT(108)) THEN
9901 VINT(108)=VIOL
9902 IF(VIOL.GT.1.0001D0) THEN
9903 MINT(10)=1
9904 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9905 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9906 & VINT(22),VINT(23),VINT(26)
9907 ENDIF
9908 ENDIF
9909 ELSEIF(VIOL.GT.VINT(108)) THEN
9910 VINT(108)=VIOL
9911 IF(VIOL.GT.1D0) THEN
9912 MINT(10)=1
9913 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9914 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9915 & THEN
9916 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9917 IF(KFPR(ISUB,1).LE.9) THEN
9918 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9919 & XMAXUP(KFPR(ISUB,1))
9920 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9921 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9922 & XMAXUP(KFPR(ISUB,1))
9923 ELSE
9924 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9925 & XMAXUP(KFPR(ISUB,1))
9926 ENDIF
9927 ENDIF
9928 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9929 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9930 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9931 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9932 & XSEC(0,1)=XSEC(0,1)+XDIF
9933 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9934 & VINT(22),VINT(23),VINT(26)
9935 IF(ISUB.LE.9) THEN
9936 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9937 ELSEIF(ISUB.LE.99) THEN
9938 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9939 ELSE
9940 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9941 ENDIF
9942 ENDIF
9943 VINT(108)=1D0
9944 ENDIF
9945 ENDIF
9946
9947C...Multiple interactions: choose impact parameter (if not already done).
9948 IF(MINT(39).EQ.0) VINT(148)=1D0
9949 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9950 &MSTP(82).GE.3) THEN
9951 IF(MINT(35).LE.1) CALL PYMULT(5)
9952 IF(MINT(35).GE.2) CALL PYMIGN(5)
9953 IF(VINT(150).LT.PYR(0)) THEN
9954 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9955 IF(MFAIL.EQ.1) THEN
9956 MSTI(61)=1
9957 RETURN
9958 ENDIF
9959 GOTO 100
9960 ENDIF
9961 ENDIF
9962 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9963 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9964 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9965 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9966 ENDIF
9967 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9968
9969C...Choose flavour of reacting partons (and subprocess).
9970 IF(ISTSB.GE.11) GOTO 320
9971 RSIGS=SIGS*PYR(0)
9972 QT2=VINT(48)
9973 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9974 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9975 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9976 &PYR(0).GT.RQQBAR)) THEN
9977 DO 310 ICHN=1,NCHN
9978 KFL1=ISIG(ICHN,1)
9979 KFL2=ISIG(ICHN,2)
9980 MINT(2)=ISIG(ICHN,3)
9981 RSIGS=RSIGS-SIGH(ICHN)
9982 IF(RSIGS.LE.0D0) GOTO 320
9983 310 CONTINUE
9984
9985C...Multiple interactions: choose qqbar preferentially at small pT.
9986 ELSEIF(ISUB.EQ.96) THEN
9987 MINT(105)=MINT(103)
9988 MINT(109)=MINT(107)
9989 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9990 MINT(105)=MINT(104)
9991 MINT(109)=MINT(108)
9992 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
9993 MINT(1)=11
9994 MINT(2)=1
9995 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
9996
9997C...Low-pT: choose string drawing configuration.
9998 ELSE
9999 KFL1=21
10000 KFL2=21
10001 RSIGS=6D0*PYR(0)
10002 MINT(2)=1
10003 IF(RSIGS.GT.1D0) MINT(2)=2
10004 IF(RSIGS.GT.2D0) MINT(2)=3
10005 ENDIF
10006
10007C...Reassign QCD process. Partons before initial state radiation.
10008 320 IF(MINT(2).GT.10) THEN
10009 MINT(1)=MINT(2)/10
10010 MINT(2)=MOD(MINT(2),10)
10011 ENDIF
10012 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10013 &NGEN(MINT(1),2)+1
10014 MINT(15)=KFL1
10015 MINT(16)=KFL2
10016 MINT(13)=MINT(15)
10017 MINT(14)=MINT(16)
10018 VINT(141)=VINT(41)
10019 VINT(142)=VINT(42)
10020 VINT(151)=0D0
10021 VINT(152)=0D0
10022
10023C...Calculate x value of photon for parton inside photon inside e.
10024 DO 350 JT=1,2
10025 MINT(18+JT)=0
10026 VINT(154+JT)=0D0
10027 MSPLI=0
10028 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10029 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10030 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10031 IF(MSPLI.EQ.2) THEN
10032 KFLH=MINT(14+JT)
10033 XHRD=VINT(140+JT)
10034 Q2HRD=VINT(54)
10035 MINT(105)=MINT(102+JT)
10036 MINT(109)=MINT(106+JT)
10037 VINT(120)=VINT(2+JT)
10038 IF(MSTP(57).LE.1) THEN
10039 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10040 ELSE
10041 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10042 ENDIF
10043 WTMX=4D0*XPQ(KFLH)
10044 IF(MSTP(13).EQ.2) THEN
10045 Q2PMS=Q2HRD/PMAS(11,1)**2
10046 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10047 ENDIF
10048 330 XE=XHRD**PYR(0)
10049 XG=MIN(1D0-1D-10,XHRD/XE)
10050 IF(MSTP(57).LE.1) THEN
10051 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10052 ELSE
10053 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10054 ENDIF
10055 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10056 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10057 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10058 MINT(18+JT)=1
10059 VINT(154+JT)=XE
10060 DO 340 KFLS=-25,25
10061 XSFX(JT,KFLS)=XPQ(KFLS)
10062 340 CONTINUE
10063 ENDIF
10064 350 CONTINUE
10065
10066C...Pick scale where photon is resolved.
10067 Q0S=PARP(15)**2
10068 Q1S=VINT(154)**2
10069 VINT(283)=0D0
10070 IF(MINT(107).EQ.3) THEN
10071 IF(MSTP(66).EQ.1) THEN
10072 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10073 ELSEIF(MSTP(66).EQ.2) THEN
10074 PS=VINT(3)**2
10075 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10076 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10077 Q2INT=SQRT(Q0S*Q2EFF)
10078 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10079 ELSEIF(MSTP(66).EQ.3) THEN
10080 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10081 ELSEIF(MSTP(66).GE.4) THEN
10082 PS=0.25D0*VINT(3)**2
10083 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10084 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10085 ENDIF
10086 ENDIF
10087 VINT(284)=0D0
10088 IF(MINT(108).EQ.3) THEN
10089 IF(MSTP(66).EQ.1) THEN
10090 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10091 ELSEIF(MSTP(66).EQ.2) THEN
10092 PS=VINT(4)**2
10093 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10094 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10095 Q2INT=SQRT(Q0S*Q2EFF)
10096 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10097 ELSEIF(MSTP(66).EQ.3) THEN
10098 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10099 ELSEIF(MSTP(66).GE.4) THEN
10100 PS=0.25D0*VINT(4)**2
10101 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10102 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10103 ENDIF
10104 ENDIF
10105 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10106
10107C...Format statements for differential cross-section maximum violations.
10108 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10109 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10110 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10111 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10112 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10113 &'in event',1X,I7)
10114 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10115 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10116 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10117 &'in event',1X,I7)
10118 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10119 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10120 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10121 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10122 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10123 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10124
10125 RETURN
10126 END
10127
10128C*********************************************************************
10129
10130C...PYSCAT
10131C...Finds outgoing flavours and event type; sets up the kinematics
10132C...and colour flow of the hard scattering
10133
10134 SUBROUTINE PYSCAT
10135
10136C...Double precision and integer declarations
10137 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10138 IMPLICIT INTEGER(I-N)
10139 INTEGER PYK,PYCHGE,PYCOMP
10140C...Parameter statement to help give large particle numbers.
10141 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10142 &KEXCIT=4000000,KDIMEN=5000000)
10143C...Parameter statement for maximum size of showers.
10144 PARAMETER (MAXNUR=1000)
10145
10146C...User process event common block.
10147 INTEGER MAXNUP
10148 PARAMETER (MAXNUP=500)
10149 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10150 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10151 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10152 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10153 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10154 SAVE /HEPEUP/
10155
10156C...Commonblocks.
10157 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10158 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10159 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10160 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10161 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10162 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10163 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10164 COMMON/PYINT1/MINT(400),VINT(400)
10165 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10166 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10167 COMMON/PYINT4/MWID(500),WIDS(500,5)
10168 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10169 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10170 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10171 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10172 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10173 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10174 &/PYTCSM/
10175C...Local arrays and saved variables
10176 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10177 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10178 SAVE VINTSV
10179
10180C...Read out process
10181 ISUB=MINT(1)
10182 ISUBSV=ISUB
10183
10184C...Restore information for low-pT processes
10185 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10186 DO 100 J=41,66
10187 100 VINT(J)=VINTSV(J)
10188 ENDIF
10189
10190C...Convert H' or A process into equivalent H one
10191 IHIGG=1
10192 KFHIGG=25
10193 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10194 &ISUB.LE.190)) THEN
10195 IHIGG=2
10196 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10197 KFHIGG=33+IHIGG
10198 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10199 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10200 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10201 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10202 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10203 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10204 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10205 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10206 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10207 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10208 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10209 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10210 ENDIF
10211
10212 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10213
10214C...Convert bottomonium process into equivalent charmonium ones.
10215 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10216
10217C...Choice of subprocess, number of documentation lines
10218 IDOC=6+ISET(ISUB)
10219 IF(ISUB.EQ.95) IDOC=8
10220 IF(ISET(ISUB).EQ.5) IDOC=9
10221 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10222 MINT(3)=IDOC-6
10223 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10224 MINT(4)=IDOC
10225 IPU1=MINT(84)+1
10226 IPU2=MINT(84)+2
10227 IPU3=MINT(84)+3
10228 IPU4=MINT(84)+4
10229 IPU5=MINT(84)+5
10230 IPU6=MINT(84)+6
10231
10232C...Reset K, P and V vectors. Store incoming particles
10233 DO 120 JT=1,MSTP(126)+100
10234 I=MINT(83)+JT
10235 IF(I.GT.MSTU(4)) GOTO 120
10236 DO 110 J=1,5
10237 K(I,J)=0
10238 P(I,J)=0D0
10239 V(I,J)=0D0
10240 110 CONTINUE
10241 120 CONTINUE
10242 DO 140 JT=1,2
10243 I=MINT(83)+JT
10244 K(I,1)=21
10245 K(I,2)=MINT(10+JT)
10246 DO 130 J=1,5
10247 P(I,J)=VINT(285+5*JT+J)
10248 130 CONTINUE
10249 140 CONTINUE
10250 MINT(6)=2
10251 KFRES=0
10252
10253C...Store incoming partons in their CM-frame. Save pdf value.
10254 SH=VINT(44)
10255 SHR=SQRT(SH)
10256 SHP=VINT(26)*VINT(2)
10257 SHPR=SQRT(SHP)
10258 SHUSER=SHR
10259 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10260 DO 150 JT=1,2
10261 I=MINT(84)+JT
10262 K(I,1)=14
10263 K(I,2)=MINT(14+JT)
10264 K(I,3)=MINT(83)+2+JT
10265 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10266 P(I,4)=0.5D0*SHUSER
10267 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10268 150 CONTINUE
10269
10270C...Copy incoming partons to documentation lines
10271 DO 170 JT=1,2
10272 I1=MINT(83)+4+JT
10273 I2=MINT(84)+JT
10274 K(I1,1)=21
10275 K(I1,2)=K(I2,2)
10276 K(I1,3)=I1-2
10277 DO 160 J=1,5
10278 P(I1,J)=P(I2,J)
10279 160 CONTINUE
10280 170 CONTINUE
10281
10282C...Choose new quark/lepton flavour for relevant annihilation graphs
10283 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10284 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10285 IGLGA=21
10286 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10287 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10288 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10289 DO 190 I=1,MDCY(IGLGA,3)
10290 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10291 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10292 IF(RKFL.LE.0D0) GOTO 200
10293 190 CONTINUE
10294 200 CONTINUE
10295 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
10296 IF(KFLF.GE.4) GOTO 180
10297 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
10298 KFLF=4
10299 MINT(2)=MINT(2)-2
10300 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
10301 KFLF=5
10302 MINT(2)=MINT(2)-4
10303 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10304 & .AND.IABS(KFLF).GE.3) THEN
10305 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10306 & VINT(44)**2
10307 FACCIB=VINT(46)**2/RTCM(41)**4
10308 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10309 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10310 KFLF=5
10311 MINT(2)=1
10312 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10313 IF(KFLF.EQ.5) GOTO 180
10314 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10315 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10316 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10317 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10318 ENDIF
10319 ENDIF
10320
10321C...Final state flavours and colour flow: default values
10322 JS=1
10323 MINT(21)=MINT(15)
10324 MINT(22)=MINT(16)
10325 MINT(23)=0
10326 MINT(24)=0
10327 KCC=20
10328 KCS=ISIGN(1,MINT(15))
10329
10330 IF(ISET(ISUB).EQ.11) THEN
10331C...User-defined processes: find products
10332 MINT(3)=0
10333 DO 210 IUP=3,NUP
10334 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10335 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10336 MINT(21+IUP)=IDUP(IUP)
10337 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10338 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10339 ELSEIF(IDUP(IUP).EQ.0) THEN
10340 ELSE
10341 MINT(3)=MINT(3)+1
10342 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10343 ENDIF
10344 210 CONTINUE
10345
10346 ELSEIF(ISUB.LE.10) THEN
10347 IF(ISUB.EQ.1) THEN
10348C...f + fbar -> gamma*/Z0
10349 KFRES=23
10350
10351 ELSEIF(ISUB.EQ.2) THEN
10352C...f + fbar' -> W+/-
10353 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10354 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10355 KFRES=ISIGN(24,KCH1+KCH2)
10356
10357 ELSEIF(ISUB.EQ.3) THEN
10358C...f + fbar -> h0 (or H0, or A0)
10359 KFRES=KFHIGG
10360
10361 ELSEIF(ISUB.EQ.4) THEN
10362C...gamma + W+/- -> W+/-
10363
10364 ELSEIF(ISUB.EQ.5) THEN
10365C...Z0 + Z0 -> h0
10366 XH=SH/SHP
10367 MINT(21)=MINT(15)
10368 MINT(22)=MINT(16)
10369 PMQ(1)=PYMASS(MINT(21))
10370 PMQ(2)=PYMASS(MINT(22))
10371 220 JT=INT(1.5D0+PYR(0))
10372 ZMIN=2D0*PMQ(JT)/SHPR
10373 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10374 & (SHPR*(SHPR-PMQ(3-JT)))
10375 ZMAX=MIN(1D0-XH,ZMAX)
10376 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10377 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10378 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10379 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10380 IF(SQC1.LT.1D-8) GOTO 220
10381 C1=SQRT(SQC1)
10382 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10383 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10384 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10385 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10386 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10387 IF(SQC1.LT.1D-8) GOTO 220
10388 C1=SQRT(SQC1)
10389 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10390 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10391 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10392 PHIR=PARU(2)*PYR(0)
10393 CPHI=COS(PHIR)
10394 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10395 & SQRT(1D0-CTHE(2)**2)*CPHI
10396 Z1=2D0-Z(JT)
10397 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10398 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10399 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10400 & PMQ(3-JT)**2/SHP))
10401 ZMIN=2D0*PMQ(3-JT)/SHPR
10402 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10403 ZMAX=MIN(1D0-XH,ZMAX)
10404 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10405 KCC=22
10406 KFRES=25
10407
10408 ELSEIF(ISUB.EQ.6) THEN
10409C...Z0 + W+/- -> W+/-
10410
10411 ELSEIF(ISUB.EQ.7) THEN
10412C...W+ + W- -> Z0
10413
10414 ELSEIF(ISUB.EQ.8) THEN
10415C...W+ + W- -> h0
10416 XH=SH/SHP
10417 230 DO 260 JT=1,2
10418 I=MINT(14+JT)
10419 IA=IABS(I)
10420 IF(IA.LE.10) THEN
10421 RVCKM=VINT(180+I)*PYR(0)
10422 DO 240 J=1,MSTP(1)
10423 IB=2*J-1+MOD(IA,2)
10424 IPM=(5-ISIGN(1,I))/2
10425 IDC=J+MDCY(IA,2)+2
10426 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10427 MINT(20+JT)=ISIGN(IB,I)
10428 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10429 IF(RVCKM.LE.0D0) GOTO 250
10430 240 CONTINUE
10431 ELSE
10432 IB=2*((IA+1)/2)-1+MOD(IA,2)
10433 MINT(20+JT)=ISIGN(IB,I)
10434 ENDIF
10435 250 PMQ(JT)=PYMASS(MINT(20+JT))
10436 260 CONTINUE
10437 JT=INT(1.5D0+PYR(0))
10438 ZMIN=2D0*PMQ(JT)/SHPR
10439 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10440 & (SHPR*(SHPR-PMQ(3-JT)))
10441 ZMAX=MIN(1D0-XH,ZMAX)
10442 IF(ZMIN.GE.ZMAX) GOTO 230
10443 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10444 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10445 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10446 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10447 IF(SQC1.LT.1D-8) GOTO 230
10448 C1=SQRT(SQC1)
10449 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10450 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10451 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10452 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10453 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10454 IF(SQC1.LT.1D-8) GOTO 230
10455 C1=SQRT(SQC1)
10456 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10457 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10458 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10459 PHIR=PARU(2)*PYR(0)
10460 CPHI=COS(PHIR)
10461 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10462 & SQRT(1D0-CTHE(2)**2)*CPHI
10463 Z1=2D0-Z(JT)
10464 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10465 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10466 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10467 & PMQ(3-JT)**2/SHP))
10468 ZMIN=2D0*PMQ(3-JT)/SHPR
10469 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10470 ZMAX=MIN(1D0-XH,ZMAX)
10471 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10472 KCC=22
10473 KFRES=25
10474
10475 ELSEIF(ISUB.EQ.10) THEN
10476C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10477 IF(MINT(2).EQ.1) THEN
10478 KCC=22
10479 ELSE
10480C...W exchange: need to mix flavours according to CKM matrix
10481 DO 280 JT=1,2
10482 I=MINT(14+JT)
10483 IA=IABS(I)
10484 IF(IA.LE.10) THEN
10485 RVCKM=VINT(180+I)*PYR(0)
10486 DO 270 J=1,MSTP(1)
10487 IB=2*J-1+MOD(IA,2)
10488 IPM=(5-ISIGN(1,I))/2
10489 IDC=J+MDCY(IA,2)+2
10490 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10491 MINT(20+JT)=ISIGN(IB,I)
10492 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10493 IF(RVCKM.LE.0D0) GOTO 280
10494 270 CONTINUE
10495 ELSE
10496 IB=2*((IA+1)/2)-1+MOD(IA,2)
10497 MINT(20+JT)=ISIGN(IB,I)
10498 ENDIF
10499 280 CONTINUE
10500 KCC=22
10501 ENDIF
10502 ENDIF
10503
10504 ELSEIF(ISUB.LE.20) THEN
10505 IF(ISUB.EQ.11) THEN
10506C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10507 KCC=MINT(2)
10508 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10509
10510 ELSEIF(ISUB.EQ.12) THEN
10511C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10512 MINT(21)=ISIGN(KFLF,MINT(15))
10513 MINT(22)=-MINT(21)
10514 KCC=4
10515
10516 ELSEIF(ISUB.EQ.13) THEN
10517C...f + fbar -> g + g; th arbitrary
10518 MINT(21)=21
10519 MINT(22)=21
10520 KCC=MINT(2)+4
10521
10522 ELSEIF(ISUB.EQ.14) THEN
10523C...f + fbar -> g + gamma; th arbitrary
10524 IF(PYR(0).GT.0.5D0) JS=2
10525 MINT(20+JS)=21
10526 MINT(23-JS)=22
10527 KCC=17+JS
10528
10529 ELSEIF(ISUB.EQ.15) THEN
10530C...f + fbar -> g + Z0; th arbitrary
10531 IF(PYR(0).GT.0.5D0) JS=2
10532 MINT(20+JS)=21
10533 MINT(23-JS)=23
10534 KCC=17+JS
10535
10536 ELSEIF(ISUB.EQ.16) THEN
10537C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10538 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10539 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10540 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10541 MINT(20+JS)=21
10542 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10543 KCC=17+JS
10544
10545 ELSEIF(ISUB.EQ.17) THEN
10546C...f + fbar -> g + h0; th arbitrary
10547 IF(PYR(0).GT.0.5D0) JS=2
10548 MINT(20+JS)=21
10549 MINT(23-JS)=25
10550 KCC=17+JS
10551
10552 ELSEIF(ISUB.EQ.18) THEN
10553C...f + fbar -> gamma + gamma; th arbitrary
10554 MINT(21)=22
10555 MINT(22)=22
10556
10557 ELSEIF(ISUB.EQ.19) THEN
10558C...f + fbar -> gamma + Z0; th arbitrary
10559 IF(PYR(0).GT.0.5D0) JS=2
10560 MINT(20+JS)=22
10561 MINT(23-JS)=23
10562
10563 ELSEIF(ISUB.EQ.20) THEN
10564C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10565C...(p(fbar')-p(W+))**2
10566 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10567 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10568 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10569 MINT(20+JS)=22
10570 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10571 ENDIF
10572
10573 ELSEIF(ISUB.LE.30) THEN
10574 IF(ISUB.EQ.21) THEN
10575C...f + fbar -> gamma + h0; th arbitrary
10576 IF(PYR(0).GT.0.5D0) JS=2
10577 MINT(20+JS)=22
10578 MINT(23-JS)=25
10579
10580 ELSEIF(ISUB.EQ.22) THEN
10581C...f + fbar -> Z0 + Z0; th arbitrary
10582 MINT(21)=23
10583 MINT(22)=23
10584
10585 ELSEIF(ISUB.EQ.23) THEN
10586C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10587 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10588 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10589 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10590 MINT(20+JS)=23
10591 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10592
10593 ELSEIF(ISUB.EQ.24) THEN
10594C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10595 IF(PYR(0).GT.0.5D0) JS=2
10596 MINT(20+JS)=23
10597 MINT(23-JS)=KFHIGG
10598
10599 ELSEIF(ISUB.EQ.25) THEN
10600C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10601 MINT(21)=-ISIGN(24,MINT(15))
10602 MINT(22)=-MINT(21)
10603
10604 ELSEIF(ISUB.EQ.26) THEN
10605C...f + fbar' -> W+/- + h0 (or H0, or A0);
10606C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10607 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10608 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10609 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10610 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10611 MINT(23-JS)=KFHIGG
10612
10613 ELSEIF(ISUB.EQ.27) THEN
10614C...f + fbar -> h0 + h0
10615
10616 ELSEIF(ISUB.EQ.28) THEN
10617C...f + g -> f + g; th = (p(f)-p(f))**2
10618 IF(MINT(15).EQ.21) JS=2
10619 KCC=MINT(2)+6
10620 IF(MINT(15).EQ.21) KCC=KCC+2
10621 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10622 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10623
10624 ELSEIF(ISUB.EQ.29) THEN
10625C...f + g -> f + gamma; th = (p(f)-p(f))**2
10626 IF(MINT(15).EQ.21) JS=2
10627 MINT(23-JS)=22
10628 KCC=15+JS
10629 KCS=ISIGN(1,MINT(14+JS))
10630
10631 ELSEIF(ISUB.EQ.30) THEN
10632C...f + g -> f + Z0; th = (p(f)-p(f))**2
10633 IF(MINT(15).EQ.21) JS=2
10634 MINT(23-JS)=23
10635 KCC=15+JS
10636 KCS=ISIGN(1,MINT(14+JS))
10637 ENDIF
10638
10639 ELSEIF(ISUB.LE.40) THEN
10640 IF(ISUB.EQ.31) THEN
10641C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10642 IF(MINT(15).EQ.21) JS=2
10643 I=MINT(14+JS)
10644 IA=IABS(I)
10645 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10646 RVCKM=VINT(180+I)*PYR(0)
10647 DO 290 J=1,MSTP(1)
10648 IB=2*J-1+MOD(IA,2)
10649 IPM=(5-ISIGN(1,I))/2
10650 IDC=J+MDCY(IA,2)+2
10651 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10652 MINT(20+JS)=ISIGN(IB,I)
10653 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10654 IF(RVCKM.LE.0D0) GOTO 300
10655 290 CONTINUE
10656 300 KCC=15+JS
10657 KCS=ISIGN(1,MINT(14+JS))
10658
10659 ELSEIF(ISUB.EQ.32) THEN
10660C...f + g -> f + h0; th = (p(f)-p(f))**2
10661 IF(MINT(15).EQ.21) JS=2
10662 MINT(23-JS)=25
10663 KCC=15+JS
10664 KCS=ISIGN(1,MINT(14+JS))
10665
10666 ELSEIF(ISUB.EQ.33) THEN
10667C...f + gamma -> f + g; th=(p(f)-p(f))**2
10668 IF(MINT(15).EQ.22) JS=2
10669 MINT(23-JS)=21
10670 KCC=24+JS
10671 KCS=ISIGN(1,MINT(14+JS))
10672
10673 ELSEIF(ISUB.EQ.34) THEN
10674C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10675 IF(MINT(15).EQ.22) JS=2
10676 KCC=22
10677 KCS=ISIGN(1,MINT(14+JS))
10678
10679 ELSEIF(ISUB.EQ.35) THEN
10680C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10681 IF(MINT(15).EQ.22) JS=2
10682 MINT(23-JS)=23
10683 KCC=22
10684
10685 ELSEIF(ISUB.EQ.36) THEN
10686C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10687 IF(MINT(15).EQ.22) JS=2
10688 I=MINT(14+JS)
10689 IA=IABS(I)
10690 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10691 IF(IA.LE.10) THEN
10692 RVCKM=VINT(180+I)*PYR(0)
10693 DO 310 J=1,MSTP(1)
10694 IB=2*J-1+MOD(IA,2)
10695 IPM=(5-ISIGN(1,I))/2
10696 IDC=J+MDCY(IA,2)+2
10697 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10698 MINT(20+JS)=ISIGN(IB,I)
10699 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10700 IF(RVCKM.LE.0D0) GOTO 320
10701 310 CONTINUE
10702 ELSE
10703 IB=2*((IA+1)/2)-1+MOD(IA,2)
10704 MINT(20+JS)=ISIGN(IB,I)
10705 ENDIF
10706 320 KCC=22
10707
10708 ELSEIF(ISUB.EQ.37) THEN
10709C...f + gamma -> f + h0
10710
10711 ELSEIF(ISUB.EQ.38) THEN
10712C...f + Z0 -> f + g
10713
10714 ELSEIF(ISUB.EQ.39) THEN
10715C...f + Z0 -> f + gamma
10716
10717 ELSEIF(ISUB.EQ.40) THEN
10718C...f + Z0 -> f + Z0
10719 ENDIF
10720
10721 ELSEIF(ISUB.LE.50) THEN
10722 IF(ISUB.EQ.41) THEN
10723C...f + Z0 -> f' + W+/-
10724
10725 ELSEIF(ISUB.EQ.42) THEN
10726C...f + Z0 -> f + h0
10727
10728 ELSEIF(ISUB.EQ.43) THEN
10729C...f + W+/- -> f' + g
10730
10731 ELSEIF(ISUB.EQ.44) THEN
10732C...f + W+/- -> f' + gamma
10733
10734 ELSEIF(ISUB.EQ.45) THEN
10735C...f + W+/- -> f' + Z0
10736
10737 ELSEIF(ISUB.EQ.46) THEN
10738C...f + W+/- -> f' + W+/-
10739
10740 ELSEIF(ISUB.EQ.47) THEN
10741C...f + W+/- -> f' + h0
10742
10743 ELSEIF(ISUB.EQ.48) THEN
10744C...f + h0 -> f + g
10745
10746 ELSEIF(ISUB.EQ.49) THEN
10747C...f + h0 -> f + gamma
10748
10749 ELSEIF(ISUB.EQ.50) THEN
10750C...f + h0 -> f + Z0
10751 ENDIF
10752
10753 ELSEIF(ISUB.LE.60) THEN
10754 IF(ISUB.EQ.51) THEN
10755C...f + h0 -> f' + W+/-
10756
10757 ELSEIF(ISUB.EQ.52) THEN
10758C...f + h0 -> f + h0
10759
10760 ELSEIF(ISUB.EQ.53) THEN
10761C...g + g -> f + fbar; th arbitrary
10762 KCS=(-1)**INT(1.5D0+PYR(0))
10763 MINT(21)=ISIGN(KFLF,KCS)
10764 MINT(22)=-MINT(21)
10765 KCC=MINT(2)+10
10766
10767 ELSEIF(ISUB.EQ.54) THEN
10768C...g + gamma -> f + fbar; th arbitrary
10769 KCS=(-1)**INT(1.5D0+PYR(0))
10770 MINT(21)=ISIGN(KFLF,KCS)
10771 MINT(22)=-MINT(21)
10772 KCC=27
10773 IF(MINT(16).EQ.21) KCC=28
10774
10775 ELSEIF(ISUB.EQ.55) THEN
10776C...g + Z0 -> f + fbar
10777
10778 ELSEIF(ISUB.EQ.56) THEN
10779C...g + W+/- -> f + fbar'
10780
10781 ELSEIF(ISUB.EQ.57) THEN
10782C...g + h0 -> f + fbar
10783
10784 ELSEIF(ISUB.EQ.58) THEN
10785C...gamma + gamma -> f + fbar; th arbitrary
10786 KCS=(-1)**INT(1.5D0+PYR(0))
10787 MINT(21)=ISIGN(KFLF,KCS)
10788 MINT(22)=-MINT(21)
10789 KCC=21
10790
10791 ELSEIF(ISUB.EQ.59) THEN
10792C...gamma + Z0 -> f + fbar
10793
10794 ELSEIF(ISUB.EQ.60) THEN
10795C...gamma + W+/- -> f + fbar'
10796 ENDIF
10797
10798 ELSEIF(ISUB.LE.70) THEN
10799 IF(ISUB.EQ.61) THEN
10800C...gamma + h0 -> f + fbar
10801
10802 ELSEIF(ISUB.EQ.62) THEN
10803C...Z0 + Z0 -> f + fbar
10804
10805 ELSEIF(ISUB.EQ.63) THEN
10806C...Z0 + W+/- -> f + fbar'
10807
10808 ELSEIF(ISUB.EQ.64) THEN
10809C...Z0 + h0 -> f + fbar
10810
10811 ELSEIF(ISUB.EQ.65) THEN
10812C...W+ + W- -> f + fbar
10813
10814 ELSEIF(ISUB.EQ.66) THEN
10815C...W+/- + h0 -> f + fbar'
10816
10817 ELSEIF(ISUB.EQ.67) THEN
10818C...h0 + h0 -> f + fbar
10819
10820 ELSEIF(ISUB.EQ.68) THEN
10821C...g + g -> g + g; th arbitrary
10822 KCC=MINT(2)+12
10823 KCS=(-1)**INT(1.5D0+PYR(0))
10824
10825 ELSEIF(ISUB.EQ.69) THEN
10826C...gamma + gamma -> W+ + W-; th arbitrary
10827 MINT(21)=24
10828 MINT(22)=-24
10829 KCC=21
10830
10831 ELSEIF(ISUB.EQ.70) THEN
10832C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10833 IF(MINT(15).EQ.22) MINT(21)=23
10834 IF(MINT(16).EQ.22) MINT(22)=23
10835 KCC=21
10836 ENDIF
10837
10838 ELSEIF(ISUB.LE.80) THEN
10839 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10840C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10841 XH=SH/SHP
10842 MINT(21)=MINT(15)
10843 MINT(22)=MINT(16)
10844 PMQ(1)=PYMASS(MINT(21))
10845 PMQ(2)=PYMASS(MINT(22))
10846 330 JT=INT(1.5D0+PYR(0))
10847 ZMIN=2D0*PMQ(JT)/SHPR
10848 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10849 & (SHPR*(SHPR-PMQ(3-JT)))
10850 ZMAX=MIN(1D0-XH,ZMAX)
10851 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10852 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10853 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10854 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10855 IF(SQC1.LT.1D-8) GOTO 330
10856 C1=SQRT(SQC1)
10857 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10858 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10859 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10860 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10861 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10862 IF(SQC1.LT.1D-8) GOTO 330
10863 C1=SQRT(SQC1)
10864 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10865 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10866 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10867 PHIR=PARU(2)*PYR(0)
10868 CPHI=COS(PHIR)
10869 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10870 & SQRT(1D0-CTHE(2)**2)*CPHI
10871 Z1=2D0-Z(JT)
10872 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10873 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10874 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10875 & PMQ(3-JT)**2/SHP))
10876 ZMIN=2D0*PMQ(3-JT)/SHPR
10877 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10878 ZMAX=MIN(1D0-XH,ZMAX)
10879 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10880 KCC=22
10881
10882 ELSEIF(ISUB.EQ.73) THEN
10883C...Z0 + W+/- -> Z0 + W+/-
10884 JS=MINT(2)
10885 XH=SH/SHP
10886 340 JT=3-MINT(2)
10887 I=MINT(14+JT)
10888 IA=IABS(I)
10889 IF(IA.LE.10) THEN
10890 RVCKM=VINT(180+I)*PYR(0)
10891 DO 350 J=1,MSTP(1)
10892 IB=2*J-1+MOD(IA,2)
10893 IPM=(5-ISIGN(1,I))/2
10894 IDC=J+MDCY(IA,2)+2
10895 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10896 MINT(20+JT)=ISIGN(IB,I)
10897 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10898 IF(RVCKM.LE.0D0) GOTO 360
10899 350 CONTINUE
10900 ELSE
10901 IB=2*((IA+1)/2)-1+MOD(IA,2)
10902 MINT(20+JT)=ISIGN(IB,I)
10903 ENDIF
10904 360 PMQ(JT)=PYMASS(MINT(20+JT))
10905 MINT(23-JT)=MINT(17-JT)
10906 PMQ(3-JT)=PYMASS(MINT(23-JT))
10907 JT=INT(1.5D0+PYR(0))
10908 ZMIN=2D0*PMQ(JT)/SHPR
10909 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10910 & (SHPR*(SHPR-PMQ(3-JT)))
10911 ZMAX=MIN(1D0-XH,ZMAX)
10912 IF(ZMIN.GE.ZMAX) GOTO 340
10913 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10914 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10915 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10916 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10917 IF(SQC1.LT.1D-8) GOTO 340
10918 C1=SQRT(SQC1)
10919 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10920 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10921 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10922 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10923 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10924 IF(SQC1.LT.1D-8) GOTO 340
10925 C1=SQRT(SQC1)
10926 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10927 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10928 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10929 PHIR=PARU(2)*PYR(0)
10930 CPHI=COS(PHIR)
10931 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10932 & SQRT(1D0-CTHE(2)**2)*CPHI
10933 Z1=2D0-Z(JT)
10934 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10935 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10936 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10937 & PMQ(3-JT)**2/SHP))
10938 ZMIN=2D0*PMQ(3-JT)/SHPR
10939 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10940 ZMAX=MIN(1D0-XH,ZMAX)
10941 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10942 KCC=22
10943
10944 ELSEIF(ISUB.EQ.74) THEN
10945C...Z0 + h0 -> Z0 + h0
10946
10947 ELSEIF(ISUB.EQ.75) THEN
10948C...W+ + W- -> gamma + gamma
10949
10950 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10951C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10952 XH=SH/SHP
10953 370 DO 400 JT=1,2
10954 I=MINT(14+JT)
10955 IA=IABS(I)
10956 IF(IA.LE.10) THEN
10957 RVCKM=VINT(180+I)*PYR(0)
10958 DO 380 J=1,MSTP(1)
10959 IB=2*J-1+MOD(IA,2)
10960 IPM=(5-ISIGN(1,I))/2
10961 IDC=J+MDCY(IA,2)+2
10962 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10963 MINT(20+JT)=ISIGN(IB,I)
10964 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10965 IF(RVCKM.LE.0D0) GOTO 390
10966 380 CONTINUE
10967 ELSE
10968 IB=2*((IA+1)/2)-1+MOD(IA,2)
10969 MINT(20+JT)=ISIGN(IB,I)
10970 ENDIF
10971 390 PMQ(JT)=PYMASS(MINT(20+JT))
10972 400 CONTINUE
10973 JT=INT(1.5D0+PYR(0))
10974 ZMIN=2D0*PMQ(JT)/SHPR
10975 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10976 & (SHPR*(SHPR-PMQ(3-JT)))
10977 ZMAX=MIN(1D0-XH,ZMAX)
10978 IF(ZMIN.GE.ZMAX) GOTO 370
10979 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10980 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10981 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10982 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10983 IF(SQC1.LT.1D-8) GOTO 370
10984 C1=SQRT(SQC1)
10985 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10986 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10987 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10988 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10989 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10990 IF(SQC1.LT.1D-8) GOTO 370
10991 C1=SQRT(SQC1)
10992 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10993 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10994 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10995 PHIR=PARU(2)*PYR(0)
10996 CPHI=COS(PHIR)
10997 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10998 & SQRT(1D0-CTHE(2)**2)*CPHI
10999 Z1=2D0-Z(JT)
11000 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11001 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11002 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11003 & PMQ(3-JT)**2/SHP))
11004 ZMIN=2D0*PMQ(3-JT)/SHPR
11005 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11006 ZMAX=MIN(1D0-XH,ZMAX)
11007 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11008 KCC=22
11009
11010 ELSEIF(ISUB.EQ.78) THEN
11011C...W+/- + h0 -> W+/- + h0
11012
11013 ELSEIF(ISUB.EQ.79) THEN
11014C...h0 + h0 -> h0 + h0
11015
11016 ELSEIF(ISUB.EQ.80) THEN
11017C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11018 IF(MINT(15).EQ.22) JS=2
11019 I=MINT(14+JS)
11020 IA=IABS(I)
11021 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11022 IB=3-IA
11023 MINT(20+JS)=ISIGN(IB,I)
11024 KCC=22
11025 ENDIF
11026
11027 ELSEIF(ISUB.LE.90) THEN
11028 IF(ISUB.EQ.81) THEN
11029C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11030 MINT(21)=ISIGN(MINT(55),MINT(15))
11031 MINT(22)=-MINT(21)
11032 KCC=4
11033
11034 ELSEIF(ISUB.EQ.82) THEN
11035C...g + g -> Q + Qbar; th arbitrary
11036 KCS=(-1)**INT(1.5D0+PYR(0))
11037 MINT(21)=ISIGN(MINT(55),KCS)
11038 MINT(22)=-MINT(21)
11039 KCC=MINT(2)+10
11040
11041 ELSEIF(ISUB.EQ.83) THEN
11042C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11043 KFOLD=MINT(16)
11044 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11045 KFAOLD=IABS(KFOLD)
11046 IF(KFAOLD.GT.10) THEN
11047 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11048 ELSE
11049 RCKM=VINT(180+KFOLD)*PYR(0)
11050 IPM=(5-ISIGN(1,KFOLD))/2
11051 KFANEW=-MOD(KFAOLD+1,2)
11052 410 KFANEW=KFANEW+2
11053 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11054 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11055 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11056 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11057 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11058 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11059 ENDIF
11060 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11061 ENDIF
11062 IF(MINT(2).EQ.1) THEN
11063 MINT(21)=ISIGN(MINT(55),MINT(15))
11064 MINT(22)=ISIGN(KFANEW,MINT(16))
11065 ELSE
11066 MINT(21)=ISIGN(KFANEW,MINT(15))
11067 MINT(22)=ISIGN(MINT(55),MINT(16))
11068 JS=2
11069 ENDIF
11070 KCC=22
11071
11072 ELSEIF(ISUB.EQ.84) THEN
11073C...g + gamma -> Q + Qbar; th arbitary
11074 KCS=(-1)**INT(1.5D0+PYR(0))
11075 MINT(21)=ISIGN(MINT(55),KCS)
11076 MINT(22)=-MINT(21)
11077 KCC=27
11078 IF(MINT(16).EQ.21) KCC=28
11079
11080 ELSEIF(ISUB.EQ.85) THEN
11081C...gamma + gamma -> F + Fbar; th arbitary
11082 KCS=(-1)**INT(1.5D0+PYR(0))
11083 MINT(21)=ISIGN(MINT(56),KCS)
11084 MINT(22)=-MINT(21)
11085 KCC=21
11086
11087 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11088C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11089 MINT(21)=KFPR(ISUB,1)
11090 MINT(22)=KFPR(ISUB,2)
11091 KCC=24
11092 KCS=(-1)**INT(1.5D0+PYR(0))
11093 ENDIF
11094
11095 ELSEIF(ISUB.LE.100) THEN
11096 IF(ISUB.EQ.95) THEN
11097C...Low-pT ( = energyless g + g -> g + g)
11098 KCC=MINT(2)+12
11099 KCS=(-1)**INT(1.5D0+PYR(0))
11100
11101 ELSEIF(ISUB.EQ.96) THEN
11102C...Multiple interactions (should be reassigned to QCD process)
11103 ENDIF
11104
11105 ELSEIF(ISUB.LE.110) THEN
11106 IF(ISUB.EQ.101) THEN
11107C...g + g -> gamma*/Z0
11108 KCC=21
11109 KFRES=22
11110
11111 ELSEIF(ISUB.EQ.102) THEN
11112C...g + g -> h0 (or H0, or A0)
11113 KCC=21
11114 KFRES=KFHIGG
11115
11116 ELSEIF(ISUB.EQ.103) THEN
11117C...gamma + gamma -> h0 (or H0, or A0)
11118 KCC=21
11119 KFRES=KFHIGG
11120
11121 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11122C...g + g -> chi_0c or chi_2c.
11123 KCC=21
11124 KFRES=KFPR(ISUB,1)
11125
11126 ELSEIF(ISUB.EQ.106) THEN
11127C...g + g -> J/Psi + gamma
11128 MINT(21)=KFPR(ISUB,1)
11129 MINT(22)=KFPR(ISUB,2)
11130 KCC=21
11131
11132 ELSEIF(ISUB.EQ.107) THEN
11133C...g + gamma -> J/Psi + g
11134 MINT(21)=KFPR(ISUB,1)
11135 MINT(22)=KFPR(ISUB,2)
11136 KCC=22
11137 IF(MINT(16).EQ.22) KCC=33
11138
11139 ELSEIF(ISUB.EQ.108) THEN
11140C...gamma + gamma -> J/Psi + gamma
11141 MINT(21)=KFPR(ISUB,1)
11142 MINT(22)=KFPR(ISUB,2)
11143
11144 ELSEIF(ISUB.EQ.110) THEN
11145C...f + fbar -> gamma + h0; th arbitrary
11146 IF(PYR(0).GT.0.5D0) JS=2
11147 MINT(20+JS)=22
11148 MINT(23-JS)=KFHIGG
11149 ENDIF
11150
11151 ELSEIF(ISUB.LE.120) THEN
11152 IF(ISUB.EQ.111) THEN
11153C...f + fbar -> g + h0; th arbitrary
11154 IF(PYR(0).GT.0.5D0) JS=2
11155 MINT(20+JS)=21
11156 MINT(23-JS)=KFHIGG
11157 KCC=17+JS
11158
11159 ELSEIF(ISUB.EQ.112) THEN
11160C...f + g -> f + h0; th = (p(f) - p(f))**2
11161 IF(MINT(15).EQ.21) JS=2
11162 MINT(23-JS)=KFHIGG
11163 KCC=15+JS
11164 KCS=ISIGN(1,MINT(14+JS))
11165
11166 ELSEIF(ISUB.EQ.113) THEN
11167C...g + g -> g + h0; th arbitrary
11168 IF(PYR(0).GT.0.5D0) JS=2
11169 MINT(23-JS)=KFHIGG
11170 KCC=22+JS
11171 KCS=(-1)**INT(1.5D0+PYR(0))
11172
11173 ELSEIF(ISUB.EQ.114) THEN
11174C...g + g -> gamma + gamma; th arbitrary
11175 IF(PYR(0).GT.0.5D0) JS=2
11176 MINT(21)=22
11177 MINT(22)=22
11178 KCC=21
11179
11180 ELSEIF(ISUB.EQ.115) THEN
11181C...g + g -> g + gamma; th arbitrary
11182 IF(PYR(0).GT.0.5D0) JS=2
11183 MINT(23-JS)=22
11184 KCC=22+JS
11185 KCS=(-1)**INT(1.5D0+PYR(0))
11186
11187 ELSEIF(ISUB.EQ.116) THEN
11188C...g + g -> gamma + Z0
11189
11190 ELSEIF(ISUB.EQ.117) THEN
11191C...g + g -> Z0 + Z0
11192
11193 ELSEIF(ISUB.EQ.118) THEN
11194C...g + g -> W+ + W-
11195 ENDIF
11196
11197 ELSEIF(ISUB.LE.140) THEN
11198 IF(ISUB.EQ.121) THEN
11199C...g + g -> Q + Qbar + h0
11200 KCS=(-1)**INT(1.5D0+PYR(0))
11201 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11202 MINT(22)=-MINT(21)
11203 KCC=11+INT(0.5D0+PYR(0))
11204 KFRES=KFHIGG
11205
11206 ELSEIF(ISUB.EQ.122) THEN
11207C...q + qbar -> Q + Qbar + h0
11208 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11209 MINT(22)=-MINT(21)
11210 KCC=4
11211 KFRES=KFHIGG
11212
11213 ELSEIF(ISUB.EQ.123) THEN
11214C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11215C...inner process)
11216 KCC=22
11217 KFRES=KFHIGG
11218
11219 ELSEIF(ISUB.EQ.124) THEN
11220C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11221C...inner process)
11222 DO 430 JT=1,2
11223 I=MINT(14+JT)
11224 IA=IABS(I)
11225 IF(IA.LE.10) THEN
11226 RVCKM=VINT(180+I)*PYR(0)
11227 DO 420 J=1,MSTP(1)
11228 IB=2*J-1+MOD(IA,2)
11229 IPM=(5-ISIGN(1,I))/2
11230 IDC=J+MDCY(IA,2)+2
11231 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11232 MINT(20+JT)=ISIGN(IB,I)
11233 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11234 IF(RVCKM.LE.0D0) GOTO 430
11235 420 CONTINUE
11236 ELSE
11237 IB=2*((IA+1)/2)-1+MOD(IA,2)
11238 MINT(20+JT)=ISIGN(IB,I)
11239 ENDIF
11240 430 CONTINUE
11241 KCC=22
11242 KFRES=KFHIGG
11243
11244 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11245C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11246 IF(MINT(15).EQ.22) JS=2
11247 MINT(23-JS)=21
11248 KCC=24+JS
11249 KCS=ISIGN(1,MINT(14+JS))
11250
11251 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11252C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11253 IF(MINT(15).EQ.22) JS=2
11254 KCC=22
11255 KCS=ISIGN(1,MINT(14+JS))
11256
11257 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11258C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11259 KCS=(-1)**INT(1.5D0+PYR(0))
11260 MINT(21)=ISIGN(KFLF,KCS)
11261 MINT(22)=-MINT(21)
11262 KCC=27
11263 IF(MINT(16).EQ.21) KCC=28
11264
11265 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11266C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11267 KCS=(-1)**INT(1.5D0+PYR(0))
11268 MINT(21)=ISIGN(KFLF,KCS)
11269 MINT(22)=-MINT(21)
11270 KCC=21
11271
11272 ENDIF
11273
11274 ELSEIF(ISUB.LE.160) THEN
11275 IF(ISUB.EQ.141) THEN
11276C...f + fbar -> gamma*/Z0/Z'0
11277 KFRES=32
11278
11279 ELSEIF(ISUB.EQ.142) THEN
11280C...f + fbar' -> W'+/-
11281 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11282 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11283 KFRES=ISIGN(34,KCH1+KCH2)
11284
11285 ELSEIF(ISUB.EQ.143) THEN
11286C...f + fbar' -> H+/-
11287 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11288 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11289 KFRES=ISIGN(37,KCH1+KCH2)
11290
11291 ELSEIF(ISUB.EQ.144) THEN
11292C...f + fbar' -> R
11293 KFRES=ISIGN(41,MINT(15)+MINT(16))
11294
11295 ELSEIF(ISUB.EQ.145) THEN
11296C...q + l -> LQ (leptoquark)
11297 IF(IABS(MINT(16)).LE.8) JS=2
11298 KFRES=ISIGN(42,MINT(14+JS))
11299 KCC=28+JS
11300 KCS=ISIGN(1,MINT(14+JS))
11301
11302 ELSEIF(ISUB.EQ.146) THEN
11303C...e + gamma -> e* (excited lepton)
11304 IF(MINT(15).EQ.22) JS=2
11305 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11306 KCC=22
11307
11308 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11309C...q + g -> q* (excited quark)
11310 IF(MINT(15).EQ.21) JS=2
11311 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11312 KCC=30+JS
11313 KCS=ISIGN(1,MINT(14+JS))
11314
11315 ELSEIF(ISUB.EQ.149) THEN
11316C...g + g -> eta_tc
11317 KFRES=KTECHN+331
11318 KCC=23
11319 KCS=(-1)**INT(1.5D0+PYR(0))
11320 ENDIF
11321
11322 ELSEIF(ISUB.LE.200) THEN
11323 IF(ISUB.EQ.161) THEN
11324C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11325 IF(MINT(15).EQ.21) JS=2
11326 I=MINT(14+JS)
11327 IA=IABS(I)
11328 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11329 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11330 MINT(20+JS)=ISIGN(IB,I)
11331 KCC=15+JS
11332 KCS=ISIGN(1,MINT(14+JS))
11333
11334 ELSEIF(ISUB.EQ.162) THEN
11335C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11336 IF(MINT(15).EQ.21) JS=2
11337 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11338 KFLQL=KFDP(MDCY(42,2),2)
11339 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11340 KCC=15+JS
11341 KCS=ISIGN(1,MINT(14+JS))
11342
11343 ELSEIF(ISUB.EQ.163) THEN
11344C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11345 KCS=(-1)**INT(1.5D0+PYR(0))
11346 MINT(21)=ISIGN(42,KCS)
11347 MINT(22)=-MINT(21)
11348 KCC=MINT(2)+10
11349
11350 ELSEIF(ISUB.EQ.164) THEN
11351C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11352 MINT(21)=ISIGN(42,MINT(15))
11353 MINT(22)=-MINT(21)
11354 KCC=4
11355
11356 ELSEIF(ISUB.EQ.165) THEN
11357C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11358 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11359 MINT(22)=-MINT(21)
11360
11361 ELSEIF(ISUB.EQ.166) THEN
11362C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11363 IF(MOD(MINT(15),2).EQ.0) THEN
11364 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11365 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11366 ELSE
11367 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11368 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11369 ENDIF
11370
11371 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11372C...q + q' -> q" + q* (excited quark)
11373 KFQSTR=KFPR(ISUB,2)
11374 KFQEXC=MOD(KFQSTR,KEXCIT)
11375 JS=MINT(2)
11376 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11377 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11378 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11379 KCC=22
11380 JS=3-JS
11381
11382 ELSEIF(ISUB.EQ.169) THEN
11383C...q + qbar -> e + e* (excited lepton)
11384 KFQSTR=KFPR(ISUB,2)
11385 KFQEXC=MOD(KFQSTR,KEXCIT)
11386 JS=MINT(2)
11387 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11388 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11389 JS=3-JS
11390
11391 ELSEIF(ISUB.EQ.191) THEN
11392C...f + fbar -> rho_tc0.
11393 KFRES=KTECHN+113
11394
11395 ELSEIF(ISUB.EQ.192) THEN
11396C...f + fbar' -> rho_tc+/-
11397 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11398 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11399 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11400
11401 ELSEIF(ISUB.EQ.193) THEN
11402C...f + fbar -> omega_tc0.
11403 KFRES=KTECHN+223
11404
11405 ELSEIF(ISUB.EQ.194) THEN
11406C...f + fbar -> f' + fbar' via mixture of s-channel
11407C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11408 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11409 MINT(22)=-MINT(21)
11410
11411 ELSEIF(ISUB.EQ.195) THEN
11412C...f + fbar' -> f'' + fbar''' via s-channel
11413C...rho_tc+ th=(p(f)-p(f'))**2
11414C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11415 IF(MOD(MINT(15),2).EQ.0) THEN
11416 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11417 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11418 ELSE
11419 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11420 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11421 ENDIF
11422 ENDIF
11423
11424CMRENNA++
11425 ELSEIF(ISUB.LE.215) THEN
11426 IF(ISUB.EQ.201) THEN
11427C...f + fbar -> ~e_L + ~e_Lbar
11428 MINT(21)=ISIGN(KSUSY1+11,KCS)
11429 MINT(22)=-MINT(21)
11430
11431 ELSEIF(ISUB.EQ.202) THEN
11432C...f + fbar -> ~e_R + ~e_Rbar
11433 MINT(21)=ISIGN(KSUSY2+11,KCS)
11434 MINT(22)=-MINT(21)
11435
11436 ELSEIF(ISUB.EQ.203) THEN
11437C...f + fbar -> ~e_L + ~e_Rbar
11438 IF(MINT(15).LT.0) JS=2
11439 IF(MINT(2).EQ.1) THEN
11440 MINT(20+JS)=KFPR(ISUB,1)
11441 MINT(23-JS)=-KFPR(ISUB,2)
11442 ELSE
11443 MINT(20+JS)=-KFPR(ISUB,1)
11444 MINT(23-JS)=KFPR(ISUB,2)
11445 ENDIF
11446
11447 ELSEIF(ISUB.EQ.204) THEN
11448C...f + fbar -> ~mu_L + ~mu_Lbar
11449 MINT(21)=ISIGN(KSUSY1+13,KCS)
11450 MINT(22)=-MINT(21)
11451
11452 ELSEIF(ISUB.EQ.205) THEN
11453C...f + fbar -> ~mu_R + ~mu_Rbar
11454 MINT(21)=ISIGN(KSUSY2+13,KCS)
11455 MINT(22)=-MINT(21)
11456
11457 ELSEIF(ISUB.EQ.206) THEN
11458C...f + fbar -> ~mu_L + ~mu_Rbar
11459 IF(MINT(15).LT.0) JS=2
11460 IF(MINT(2).EQ.1) THEN
11461 MINT(20+JS)=KFPR(ISUB,1)
11462 MINT(23-JS)=-KFPR(ISUB,2)
11463 ELSE
11464 MINT(20+JS)=-KFPR(ISUB,1)
11465 MINT(23-JS)=KFPR(ISUB,2)
11466 ENDIF
11467
11468 ELSEIF(ISUB.EQ.207) THEN
11469C...f + fbar -> ~tau_1 + ~tau_1bar
11470 MINT(21)=ISIGN(KSUSY1+15,KCS)
11471 MINT(22)=-MINT(21)
11472
11473 ELSEIF(ISUB.EQ.208) THEN
11474C...f + fbar -> ~tau_2 + ~tau_2bar
11475 MINT(21)=ISIGN(KSUSY2+15,KCS)
11476 MINT(22)=-MINT(21)
11477
11478 ELSEIF(ISUB.EQ.209) THEN
11479C...f + fbar -> ~tau_1 + ~tau_2bar
11480 IF(MINT(15).LT.0) JS=2
11481 IF(MINT(2).EQ.1) THEN
11482 MINT(20+JS)=KFPR(ISUB,1)
11483 MINT(23-JS)=-KFPR(ISUB,2)
11484 ELSE
11485 MINT(20+JS)=-KFPR(ISUB,1)
11486 MINT(23-JS)=KFPR(ISUB,2)
11487 ENDIF
11488
11489 ELSEIF(ISUB.EQ.210) THEN
11490C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11491 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11492 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11493 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11494 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11495
11496 ELSEIF(ISUB.EQ.211) THEN
11497C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11498 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11499 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11500 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11501 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11502
11503 ELSEIF(ISUB.EQ.212) THEN
11504C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11505 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11506 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11507 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11508 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11509
11510 ELSEIF(ISUB.EQ.213) THEN
11511C...f + fbar -> ~nul + ~nulbar
11512 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11513 MINT(22)=-MINT(21)
11514
11515 ELSEIF(ISUB.EQ.214) THEN
11516C...f + fbar -> ~nutau + ~nutaubar
11517 MINT(21)=ISIGN(KSUSY1+16,KCS)
11518 MINT(22)=-MINT(21)
11519 ENDIF
11520
11521 ELSEIF(ISUB.LE.225) THEN
11522 IF(ISUB.EQ.216) THEN
11523C...f + fbar -> ~chi01 + ~chi01
11524 MINT(21)=KSUSY1+22
11525 MINT(22)=KSUSY1+22
11526
11527 ELSEIF(ISUB.EQ.217) THEN
11528C...f + fbar -> ~chi02 + ~chi02
11529 MINT(21)=KSUSY1+23
11530 MINT(22)=KSUSY1+23
11531
11532 ELSEIF(ISUB.EQ.218 ) THEN
11533C...f + fbar -> ~chi03 + ~chi03
11534 MINT(21)=KSUSY1+25
11535 MINT(22)=KSUSY1+25
11536
11537 ELSEIF(ISUB.EQ.219 ) THEN
11538C...f + fbar -> ~chi04 + ~chi04
11539 MINT(21)=KSUSY1+35
11540 MINT(22)=KSUSY1+35
11541
11542 ELSEIF(ISUB.EQ.220 ) THEN
11543C...f + fbar -> ~chi01 + ~chi02
11544 IF(MINT(15).LT.0) JS=2
11545C IF(PYR(0).GT.0.5D0) JS=2
11546 MINT(20+JS)=KSUSY1+22
11547 MINT(23-JS)=KSUSY1+23
11548
11549 ELSEIF(ISUB.EQ.221 ) THEN
11550C...f + fbar -> ~chi01 + ~chi03
11551 IF(MINT(15).LT.0) JS=2
11552C IF(PYR(0).GT.0.5D0) JS=2
11553 MINT(20+JS)=KSUSY1+22
11554 MINT(23-JS)=KSUSY1+25
11555
11556 ELSEIF(ISUB.EQ.222) THEN
11557C...f + fbar -> ~chi01 + ~chi04
11558 IF(MINT(15).LT.0) JS=2
11559C IF(PYR(0).GT.0.5D0) JS=2
11560 MINT(20+JS)=KSUSY1+22
11561 MINT(23-JS)=KSUSY1+35
11562
11563 ELSEIF(ISUB.EQ.223) THEN
11564C...f + fbar -> ~chi02 + ~chi03
11565 IF(MINT(15).LT.0) JS=2
11566C IF(PYR(0).GT.0.5D0) JS=2
11567 MINT(20+JS)=KSUSY1+23
11568 MINT(23-JS)=KSUSY1+25
11569
11570 ELSEIF(ISUB.EQ.224) THEN
11571C...f + fbar -> ~chi02 + ~chi04
11572 IF(MINT(15).LT.0) JS=2
11573C IF(PYR(0).GT.0.5D0) JS=2
11574 MINT(20+JS)=KSUSY1+23
11575 MINT(23-JS)=KSUSY1+35
11576
11577 ELSEIF(ISUB.EQ.225) THEN
11578C...f + fbar -> ~chi03 + ~chi04
11579 IF(MINT(15).LT.0) JS=2
11580C IF(PYR(0).GT.0.5D0) JS=2
11581 MINT(20+JS)=KSUSY1+25
11582 MINT(23-JS)=KSUSY1+35
11583 ENDIF
11584
11585 ELSEIF(ISUB.LE.236) THEN
11586 IF(ISUB.EQ.226) THEN
11587C...f + fbar -> ~chi+-1 + ~chi-+1
11588C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11589 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11590 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11591 MINT(22)=-MINT(21)
11592
11593 ELSEIF(ISUB.EQ.227) THEN
11594C...f + fbar -> ~chi+-2 + ~chi-+2
11595 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11596 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11597 MINT(22)=-MINT(21)
11598
11599 ELSEIF(ISUB.EQ.228) THEN
11600C...f + fbar -> ~chi+-1 + ~chi-+2
11601C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11602C...js=1 if pyr<.5, js=2 if pyr>.5
11603C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11604C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11605C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11606C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11607 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11608 KCH2=INT(1-KCH1)/2
11609 IF(MINT(2).EQ.1) THEN
11610 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11611 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11612c IF(KCH2.EQ.0) JS=2
11613 ELSE
11614 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11615 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11616 JS=2
11617c IF(KCH2.EQ.1) JS=2
11618 ENDIF
11619
11620 ELSEIF(ISUB.EQ.229) THEN
11621C...q + qbar' -> ~chi01 + ~chi+-1
11622C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11623 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11624 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11625C...CHECK THIS
11626 IF(MOD(MINT(15),2).EQ.0) JS=2
11627 MINT(20+JS)=KSUSY1+22
11628 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11629
11630 ELSEIF(ISUB.EQ.230) THEN
11631C...q + qbar' -> ~chi02 + ~chi+-1
11632 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11633 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11634 IF(MOD(MINT(15),2).EQ.0) JS=2
11635 MINT(20+JS)=KSUSY1+23
11636 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11637
11638 ELSEIF(ISUB.EQ.231) THEN
11639C...q + qbar' -> ~chi03 + ~chi+-1
11640 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11641 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11642 IF(MOD(MINT(15),2).EQ.0) JS=2
11643 MINT(20+JS)=KSUSY1+25
11644 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11645
11646 ELSEIF(ISUB.EQ.232) THEN
11647C...q + qbar' -> ~chi04 + ~chi+-1
11648 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11649 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11650 IF(MOD(MINT(15),2).EQ.0) JS=2
11651 MINT(20+JS)=KSUSY1+35
11652 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11653
11654 ELSEIF(ISUB.EQ.233) THEN
11655C...q + qbar' -> ~chi01 + ~chi+-2
11656 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11657 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11658 IF(MOD(MINT(15),2).EQ.0) JS=2
11659 MINT(20+JS)=KSUSY1+22
11660 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11661
11662 ELSEIF(ISUB.EQ.234) THEN
11663C...q + qbar' -> ~chi02 + ~chi+-2
11664 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11665 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11666 IF(MOD(MINT(15),2).EQ.0) JS=2
11667 MINT(20+JS)=KSUSY1+23
11668 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11669
11670 ELSEIF(ISUB.EQ.235) THEN
11671C...q + qbar' -> ~chi03 + ~chi+-2
11672 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11673 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11674 IF(MOD(MINT(15),2).EQ.0) JS=2
11675 MINT(20+JS)=KSUSY1+25
11676 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11677
11678 ELSEIF(ISUB.EQ.236) THEN
11679C...q + qbar' -> ~chi04 + ~chi+-2
11680 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11681 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11682 IF(MOD(MINT(15),2).EQ.0) JS=2
11683 MINT(20+JS)=KSUSY1+35
11684 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11685 ENDIF
11686
11687 ELSEIF(ISUB.LE.245) THEN
11688 IF(ISUB.EQ.237) THEN
11689C...q + qbar -> ~chi01 + ~g
11690C...th arbitrary
11691 IF(PYR(0).GT.0.5D0) JS=2
11692 MINT(20+JS)=KSUSY1+21
11693 MINT(23-JS)=KSUSY1+22
11694 KCC=17+JS
11695
11696 ELSEIF(ISUB.EQ.238) THEN
11697C...q + qbar -> ~chi02 + ~g
11698C...th arbitrary
11699 IF(PYR(0).GT.0.5D0) JS=2
11700 MINT(20+JS)=KSUSY1+21
11701 MINT(23-JS)=KSUSY1+23
11702 KCC=17+JS
11703
11704 ELSEIF(ISUB.EQ.239) THEN
11705C...q + qbar -> ~chi03 + ~g
11706C...th arbitrary
11707 IF(PYR(0).GT.0.5D0) JS=2
11708 MINT(20+JS)=KSUSY1+21
11709 MINT(23-JS)=KSUSY1+25
11710 KCC=17+JS
11711
11712 ELSEIF(ISUB.EQ.240) THEN
11713C...q + qbar -> ~chi04 + ~g
11714C...th arbitrary
11715 IF(PYR(0).GT.0.5D0) JS=2
11716 MINT(20+JS)=KSUSY1+21
11717 MINT(23-JS)=KSUSY1+35
11718 KCC=17+JS
11719
11720 ELSEIF(ISUB.EQ.241) THEN
11721C...q + qbar' -> ~chi+-1 + ~g
11722C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11723C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11724C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11725C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11726C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11727 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11728 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11729 JS=1
11730 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11731 MINT(20+JS)=KSUSY1+21
11732 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11733 KCC=17+JS
11734
11735 ELSEIF(ISUB.EQ.242) THEN
11736C...q + qbar' -> ~chi+-2 + ~g
11737C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11738C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11739C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11740C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11741C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11742 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11743 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11744 JS=1
11745 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11746 MINT(20+JS)=KSUSY1+21
11747 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11748 KCC=17+JS
11749
11750 ELSEIF(ISUB.EQ.243) THEN
11751C...q + qbar -> ~g + ~g ; th arbitrary
11752 MINT(21)=KSUSY1+21
11753 MINT(22)=KSUSY1+21
11754 KCC=MINT(2)+4
11755
11756 ELSEIF(ISUB.EQ.244) THEN
11757C...g + g -> ~g + ~g ; th arbitrary
11758 KCC=MINT(2)+12
11759 KCS=(-1)**INT(1.5D0+PYR(0))
11760 MINT(21)=KSUSY1+21
11761 MINT(22)=KSUSY1+21
11762 ENDIF
11763
11764 ELSEIF(ISUB.LE.260) THEN
11765 IF(ISUB.EQ.246) THEN
11766C...qj + g -> ~qj_L + ~chi01
11767 IF(MINT(15).EQ.21) JS=2
11768 I=MINT(14+JS)
11769 IA=IABS(I)
11770 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11771 MINT(23-JS)=KSUSY1+22
11772 KCC=15+JS
11773 KCS=ISIGN(1,MINT(14+JS))
11774
11775 ELSEIF(ISUB.EQ.247) THEN
11776C...qj + g -> ~qj_R + ~chi01
11777 IF(MINT(15).EQ.21) JS=2
11778 I=MINT(14+JS)
11779 IA=IABS(I)
11780 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11781 MINT(23-JS)=KSUSY1+22
11782 KCC=15+JS
11783 KCS=ISIGN(1,MINT(14+JS))
11784
11785 ELSEIF(ISUB.EQ.248) THEN
11786C...qj + g -> ~qj_L + ~chi02
11787 IF(MINT(15).EQ.21) JS=2
11788 I=MINT(14+JS)
11789 IA=IABS(I)
11790 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11791 MINT(23-JS)=KSUSY1+23
11792 KCC=15+JS
11793 KCS=ISIGN(1,MINT(14+JS))
11794
11795 ELSEIF(ISUB.EQ.249) THEN
11796C...qj + g -> ~qj_R + ~chi02
11797 IF(MINT(15).EQ.21) JS=2
11798 I=MINT(14+JS)
11799 IA=IABS(I)
11800 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11801 MINT(23-JS)=KSUSY1+23
11802 KCC=15+JS
11803 KCS=ISIGN(1,MINT(14+JS))
11804
11805 ELSEIF(ISUB.EQ.250) THEN
11806C...qj + g -> ~qj_L + ~chi03
11807 IF(MINT(15).EQ.21) JS=2
11808 I=MINT(14+JS)
11809 IA=IABS(I)
11810 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11811 MINT(23-JS)=KSUSY1+25
11812 KCC=15+JS
11813 KCS=ISIGN(1,MINT(14+JS))
11814
11815 ELSEIF(ISUB.EQ.251) THEN
11816C...qj + g -> ~qj_R + ~chi03
11817 IF(MINT(15).EQ.21) JS=2
11818 I=MINT(14+JS)
11819 IA=IABS(I)
11820 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11821 MINT(23-JS)=KSUSY1+25
11822 KCC=15+JS
11823 KCS=ISIGN(1,MINT(14+JS))
11824
11825 ELSEIF(ISUB.EQ.252) THEN
11826C...qj + g -> ~qj_L + ~chi04
11827 IF(MINT(15).EQ.21) JS=2
11828 I=MINT(14+JS)
11829 IA=IABS(I)
11830 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11831 MINT(23-JS)=KSUSY1+35
11832 KCC=15+JS
11833 KCS=ISIGN(1,MINT(14+JS))
11834
11835 ELSEIF(ISUB.EQ.253) THEN
11836C...qj + g -> ~qj_R + ~chi04
11837 IF(MINT(15).EQ.21) JS=2
11838 I=MINT(14+JS)
11839 IA=IABS(I)
11840 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11841 MINT(23-JS)=KSUSY1+35
11842 KCC=15+JS
11843 KCS=ISIGN(1,MINT(14+JS))
11844
11845 ELSEIF(ISUB.EQ.254) THEN
11846C...qj + g -> ~qk_L + ~chi+-1
11847 IF(MINT(15).EQ.21) JS=2
11848 I=MINT(14+JS)
11849 IA=IABS(I)
11850 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11851 IB=-IA+INT((IA+1)/2)*4-1
11852 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11853 KCC=15+JS
11854 KCS=ISIGN(1,MINT(14+JS))
11855
11856 ELSEIF(ISUB.EQ.255) THEN
11857C...qj + g -> ~qk_L + ~chi+-1
11858 IF(MINT(15).EQ.21) JS=2
11859 I=MINT(14+JS)
11860 IA=IABS(I)
11861 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11862 IB=-IA+INT((IA+1)/2)*4-1
11863 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11864 KCC=15+JS
11865 KCS=ISIGN(1,MINT(14+JS))
11866
11867 ELSEIF(ISUB.EQ.256) THEN
11868C...qj + g -> ~qk_L + ~chi+-2
11869 IF(MINT(15).EQ.21) JS=2
11870 I=MINT(14+JS)
11871 IA=IABS(I)
11872 IB=-IA+INT((IA+1)/2)*4-1
11873 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11874 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11875 KCC=15+JS
11876 KCS=ISIGN(1,MINT(14+JS))
11877
11878 ELSEIF(ISUB.EQ.257) THEN
11879C...qj + g -> ~qk_R + ~chi+-2
11880 IF(MINT(15).EQ.21) JS=2
11881 I=MINT(14+JS)
11882 IA=IABS(I)
11883 IB=-IA+INT((IA+1)/2)*4-1
11884 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11885 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11886 KCC=15+JS
11887 KCS=ISIGN(1,MINT(14+JS))
11888
11889 ELSEIF(ISUB.EQ.258) THEN
11890C...qj + g -> ~qj_L + ~g
11891 IF(MINT(15).EQ.21) JS=2
11892 I=MINT(14+JS)
11893 IA=IABS(I)
11894 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11895 MINT(23-JS)=KSUSY1+21
11896 KCC=MINT(2)+6
11897 IF(JS.EQ.2) KCC=KCC+2
11898 KCS=ISIGN(1,I)
11899
11900 ELSEIF(ISUB.EQ.259) THEN
11901C...qj + g -> ~qj_R + ~g
11902 IF(MINT(15).EQ.21) JS=2
11903 I=MINT(14+JS)
11904 IA=IABS(I)
11905 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11906 MINT(23-JS)=KSUSY1+21
11907 KCC=MINT(2)+6
11908 IF(JS.EQ.2) KCC=KCC+2
11909 KCS=ISIGN(1,I)
11910 ENDIF
11911
11912 ELSEIF(ISUB.LE.270) THEN
11913 IF(ISUB.EQ.261) THEN
11914C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11915 ISGN=1
11916 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11917 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11918 MINT(22)=-MINT(21)
11919C...Correct color combination
11920 IF(MINT(43).EQ.4) KCC=4
11921
11922 ELSEIF(ISUB.EQ.262) THEN
11923C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11924 ISGN=1
11925 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11926 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11927 MINT(22)=-MINT(21)
11928C...Correct color combination
11929 IF(MINT(43).EQ.4) KCC=4
11930
11931 ELSEIF(ISUB.EQ.263) THEN
11932C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11933 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11934 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11935 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11936 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11937 ELSE
11938 JS=2
11939 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11940 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11941 ENDIF
11942C...Correct color combination
11943 IF(MINT(43).EQ.4) KCC=4
11944
11945 ELSEIF(ISUB.EQ.264) THEN
11946C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11947 KCS=(-1)**INT(1.5D0+PYR(0))
11948 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11949 MINT(22)=-MINT(21)
11950 KCC=MINT(2)+10
11951
11952 ELSEIF(ISUB.EQ.265) THEN
11953C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11954 KCS=(-1)**INT(1.5D0+PYR(0))
11955 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11956 MINT(22)=-MINT(21)
11957 KCC=MINT(2)+10
11958 ENDIF
11959
11960 ELSEIF(ISUB.LE.296) THEN
11961 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11962C...qi + qj -> ~qi_L + ~qj_L
11963 KCC=MINT(2)
11964 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11965 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11966 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11967
11968 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11969C...qi + qj -> ~qi_R + ~qj_R
11970 KCC=MINT(2)
11971 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11972 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11973 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11974
11975 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11976C...qi + qj -> ~qi_L + ~qj_R
11977 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11978 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11979 KCC=MINT(2)
11980 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11981
11982 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11983C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11984 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11985 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11986 KCC=MINT(2)
11987 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11988
11989 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11990C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11991 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11992 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11993 KCC=MINT(2)
11994 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11995
11996 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
11997C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11998 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11999 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12000 KCC=MINT(2)
12001 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12002
12003 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12004C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12005 ISGN=1
12006 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12007 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12008 MINT(22)=-MINT(21)
12009 IF(MINT(43).EQ.4) KCC=4
12010
12011 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12012C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12013 ISGN=1
12014 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12015 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12016 MINT(22)=-MINT(21)
12017 IF(MINT(43).EQ.4) KCC=4
12018
12019 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12020C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12021C...pure LL + RR
12022 KCS=(-1)**INT(1.5D0+PYR(0))
12023 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12024 MINT(22)=-MINT(21)
12025 KCC=MINT(2)+10
12026
12027 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12028C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12029 KCS=(-1)**INT(1.5D0+PYR(0))
12030 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12031 MINT(22)=-MINT(21)
12032 KCC=MINT(2)+10
12033
12034 ELSEIF(ISUB.EQ.294) THEN
12035C...qj + g -> ~qj_L + ~g
12036 IF(MINT(15).EQ.21) JS=2
12037 I=MINT(14+JS)
12038 IA=IABS(I)
12039 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12040 MINT(23-JS)=KSUSY1+21
12041 KCC=MINT(2)+6
12042 IF(JS.EQ.2) KCC=KCC+2
12043 KCS=ISIGN(1,I)
12044
12045 ELSEIF(ISUB.EQ.295) THEN
12046C...qj + g -> ~qj_R + ~g
12047 IF(MINT(15).EQ.21) JS=2
12048 I=MINT(14+JS)
12049 IA=IABS(I)
12050 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12051 MINT(23-JS)=KSUSY1+21
12052 KCC=MINT(2)+6
12053 IF(JS.EQ.2) KCC=KCC+2
12054 KCS=ISIGN(1,I)
12055 ENDIF
12056
12057 ELSEIF(ISUB.LE.340) THEN
12058
12059 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12060C...q + qbar' -> H+ + H0
12061 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12062 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12063 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12064 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12065 MINT(23-JS)=KFPR(ISUB,2)
12066 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12067C...f + fbar -> A0 + H0; th arbitrary
12068 IF(PYR(0).GT.0.5D0) JS=2
12069 MINT(20+JS)=KFPR(ISUB,1)
12070 MINT(23-JS)=KFPR(ISUB,2)
12071 ELSEIF(ISUB.EQ.301) THEN
12072C...f + fbar -> H+ H-
12073 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12074 MINT(22)=-MINT(21)
12075 ENDIF
12076CMRENNA--
12077
12078 ELSEIF(ISUB.LE.360) THEN
12079
12080 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12081C...l + l -> H_L++/--, H_R++/--
12082 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12083 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12084 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12085
12086 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12087C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12088 IF(MINT(15).EQ.22) JS=2
12089 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12090 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12091 KCC=22
12092
12093 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12094C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12095 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12096 MINT(22)=-MINT(21)
12097
12098 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12099C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12100C...as inner process).
12101 DO 450 JT=1,2
12102 I=MINT(14+JT)
12103 IA=IABS(I)
12104 IF(IA.LE.10) THEN
12105 RVCKM=VINT(180+I)*PYR(0)
12106 DO 440 J=1,MSTP(1)
12107 IB=2*J-1+MOD(IA,2)
12108 IPM=(5-ISIGN(1,I))/2
12109 IDC=J+MDCY(IA,2)+2
12110 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12111 MINT(20+JT)=ISIGN(IB,I)
12112 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12113 IF(RVCKM.LE.0D0) GOTO 450
12114 440 CONTINUE
12115 ELSE
12116 IB=2*((IA+1)/2)-1+MOD(IA,2)
12117 MINT(20+JT)=ISIGN(IB,I)
12118 ENDIF
12119 450 CONTINUE
12120 KCC=22
12121 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12122 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12123
12124 ELSEIF(ISUB.EQ.353) THEN
12125C...f + fbar -> Z_R0
12126 KFRES=KFPR(ISUB,1)
12127
12128 ELSEIF(ISUB.EQ.354) THEN
12129C...f + fbar' -> W+/-
12130 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12131 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12132 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12133
12134 ENDIF
12135
12136 ELSEIF(ISUB.LE.380) THEN
12137
12138 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12139C...f + fbar -> charged+ charged- technicolor
12140 KSW=(-1)**INT(1.5D0+PYR(0))
12141 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12142 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12143
12144 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12145C...f + fbar -> neutral neutral technicolor
12146 MINT(21)=KFPR(ISUB,1)
12147 MINT(22)=KFPR(ISUB,2)
12148
12149 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12150C...f + fbar' -> neutral charged technicolor
12151 IN=1
12152 IC=2
12153 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12154 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12155 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12156 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12157 MINT(20+JS)=KFPR(ISUB,IN)
12158
12159 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12160C...f + fbar' -> charged neutral technicolor
12161 IN=2
12162 IC=1
12163 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12164 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12165 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12166 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12167 MINT(23-JS)=KFPR(ISUB,IN)
12168 ENDIF
12169
12170 ELSEIF(ISUB.LE.400) THEN
12171 IF(ISUB.EQ.381) THEN
12172C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12173 KCC=MINT(2)
12174 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12175
12176 ELSEIF(ISUB.EQ.382) THEN
12177C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12178 MINT(21)=ISIGN(KFLF,MINT(15))
12179 MINT(22)=-MINT(21)
12180 KCC=4
12181
12182 ELSEIF(ISUB.EQ.383) THEN
12183C...f + fbar -> g + g; th arbitrary, TC extensions
12184 MINT(21)=21
12185 MINT(22)=21
12186 KCC=MINT(2)+4
12187
12188 ELSEIF(ISUB.EQ.384) THEN
12189C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12190 IF(MINT(15).EQ.21) JS=2
12191 KCC=MINT(2)+6
12192 IF(MINT(15).EQ.21) KCC=KCC+2
12193 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12194 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12195
12196 ELSEIF(ISUB.EQ.385) THEN
12197C...g + g -> f + fbar; th arbitrary, TC extensions
12198 KCS=(-1)**INT(1.5D0+PYR(0))
12199 MINT(21)=ISIGN(KFLF,KCS)
12200 MINT(22)=-MINT(21)
12201 KCC=MINT(2)+10
12202
12203 ELSEIF(ISUB.EQ.386) THEN
12204C...g + g -> g + g; th arbitrary, TC extensions
12205 KCC=MINT(2)+12
12206 KCS=(-1)**INT(1.5D0+PYR(0))
12207
12208 ELSEIF(ISUB.EQ.387) THEN
12209C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12210 MINT(21)=ISIGN(MINT(55),MINT(15))
12211 MINT(22)=-MINT(21)
12212 KCC=4
12213
12214 ELSEIF(ISUB.EQ.388) THEN
12215C...g + g -> Q + Qbar; th arbitrary, TC extensions
12216 KCS=(-1)**INT(1.5D0+PYR(0))
12217 MINT(21)=ISIGN(MINT(55),KCS)
12218 MINT(22)=-MINT(21)
12219 KCC=MINT(2)+10
12220
12221 ELSEIF(ISUB.EQ.391) THEN
12222C...f + fbar -> G*.
12223 KFRES=KFPR(ISUB,1)
12224
12225 ELSEIF(ISUB.EQ.392) THEN
12226C...g + g -> G*.
12227 KCC=21
12228 KFRES=KFPR(ISUB,1)
12229
12230 ELSEIF(ISUB.EQ.393) THEN
12231C...q + qbar -> g + G*; th arbitrary.
12232 IF(PYR(0).GT.0.5D0) JS=2
12233 MINT(20+JS)=KFPR(ISUB,1)
12234 MINT(23-JS)=KFPR(ISUB,2)
12235 KCC=17+JS
12236
12237 ELSEIF(ISUB.EQ.394) THEN
12238C...q + g -> q + G*; th = (p(f) - p(f))**2
12239 IF(MINT(15).EQ.21) JS=2
12240 MINT(23-JS)=KFPR(ISUB,2)
12241 KCC=15+JS
12242 KCS=ISIGN(1,MINT(14+JS))
12243
12244 ELSEIF(ISUB.EQ.395) THEN
12245C...g + g -> G* + g; th arbitrary.
12246 IF(PYR(0).GT.0.5D0) JS=2
12247 MINT(23-JS)=KFPR(ISUB,2)
12248 KCC=22+JS
12249 ENDIF
12250
12251 ELSEIF(ISUB.LE.420) THEN
12252 IF(ISUB.EQ.401) THEN
12253C...g + g -> t + b + H+/-
12254 KCS=(-1)**INT(1.5D0+PYR(0))
12255 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12256 MINT(22)=ISIGN(5,-KCS)
12257 KCC=11+INT(0.5D0+PYR(0))
12258 KFRES=ISIGN(KFHIGG,-KCS)
12259
12260 ELSEIF(ISUB.EQ.402) THEN
12261C...q + qbar -> t + b + H+/-
12262 KFL=(-1)**INT(1.5D0+PYR(0))
12263 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12264 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12265 KCC=4
12266 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12267 ENDIF
12268
12269C...QUARKONIA+++
12270C...Additional code by Stefan Wolf
12271 ELSEIF(ISUB.LE.430) THEN
12272 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12273C...g + g -> QQ~[n] + g
12274C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12275C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12276C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12277C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12278C...or from ISUB.EQ.68 (for ISUB.NE.421)
12279C...[g + g -> g + g; th arbitrary]
12280 MINT(21)=KFPR(ISUBSV,1)
12281 MINT(22)=KFPR(ISUBSV,2)
12282 IF(ISUB.EQ.421) THEN
12283 KCC=24
12284 KCS=(-1)**INT(1.5D0+PYR(0))
12285 ELSE
12286 KCC=MINT(2)+12
12287 KCS=(-1)**INT(1.5D0+PYR(0))
12288 ENDIF
12289
12290 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12291C...q + g -> q + QQ~[n]
12292C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12293C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12294C...KCC copied from ISUB.EQ.28
12295C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12296 IF(MINT(15).EQ.21) JS=2
12297 MINT(23-JS)=KFPR(ISUBSV,2)
12298 KCC=MINT(2)+6
12299 IF(MINT(15).EQ.21) KCC=KCC+2
12300 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12301 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12302
12303 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12304C...q + q~ -> g + QQ~[n]
12305C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12306C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12307C...KCC copied from ISUB.EQ.13
12308C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12309 IF(PYR(0).GT.0.5) JS=2
12310 MINT(20+JS)=21
12311 MINT(23-JS)=KFPR(ISUBSV,2)
12312 KCC=MINT(2)+4
12313 ENDIF
12314
12315 ELSEIF(ISUB.LE.440) THEN
12316 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12317C...g + g -> QQ~[n] + g
12318C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12319C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12320C...KCC and KCS copied from ISUB.EQ.86-89
12321C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12322 MINT(21)=KFPR(ISUBSV,1)
12323 MINT(22)=KFPR(ISUBSV,2)
12324 KCC=24
12325 KCS=(-1)**INT(1.5D0+PYR(0))
12326
12327 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12328C...q + g -> q + QQ~[n]
12329C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12330C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12331C...KCC and KCS copied from ISUB.EQ.112
12332C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12333 IF(MINT(15).EQ.21) JS=2
12334 MINT(23-JS)=KFPR(ISUBSV,2)
12335 KCC=15+JS
12336 KCS=ISIGN(1,MINT(14+JS))
12337
12338 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12339C...q + q~ -> g + QQ~[n]
12340C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12341C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12342C...KCC copied from ISUB.EQ.111
12343C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12344 IF(PYR(0).GT.0.5) JS=2
12345 MINT(20+JS)=21
12346 MINT(23-JS)=KFPR(ISUBSV,2)
12347 KCC=17+JS
12348 ENDIF
12349C...QUARKONIA---
12350
12351 ENDIF
12352
12353 IF(ISET(ISUB).EQ.11) THEN
12354C...Store documentation for user-defined processes
12355 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12356 KUPPO(1)=MINT(83)+5
12357 KUPPO(2)=MINT(83)+6
12358 I=MINT(83)+6
12359 DO 470 IUP=3,NUP
12360 KUPPO(IUP)=0
12361 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12362 IDOC=IDOC-1
12363 MINT(4)=MINT(4)-1
12364 GOTO 470
12365 ENDIF
12366 I=I+1
12367 KUPPO(IUP)=I
12368 K(I,1)=21
12369 K(I,2)=IDUP(IUP)
12370 IF(IDUP(IUP).EQ.0) K(I,2)=90
12371 K(I,3)=0
12372 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12373 K(I,4)=0
12374 K(I,5)=0
12375 DO 460 J=1,5
12376 P(I,J)=PUP(J,IUP)
12377 460 CONTINUE
12378 V(I,5)=VTIMUP(IUP)
12379 470 CONTINUE
12380 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12381 & -BEZUP)
12382
12383C...Store final state partons for user-defined processes
12384 N=IPU2
12385 DO 490 IUP=3,NUP
12386 N=N+1
12387 K(N,1)=1
12388 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12389 K(N,2)=IDUP(IUP)
12390 IF(IDUP(IUP).EQ.0) K(N,2)=90
12391 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12392 K(N,3)=KUPPO(IUP)
12393 ELSE
12394 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12395 ENDIF
12396 K(N,4)=0
12397 K(N,5)=0
12398C...Search for daughters of intermediate colourless particles.
12399 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12400 DO 475 IUPDAU=IUP+1,NUP
12401 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12402 & N+IUPDAU-IUP
12403 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12404 475 CONTINUE
12405 ENDIF
12406 DO 480 J=1,5
12407 P(N,J)=PUP(J,IUP)
12408 480 CONTINUE
12409 V(N,5)=VTIMUP(IUP)
12410 490 CONTINUE
12411 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12412
12413C...Arrange colour flow for user-defined processes
12414 NLBL=0
12415 DO 540 IUP1=1,NUP
12416 I1=MINT(84)+IUP1
12417 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12418 IF(K(I1,1).EQ.1) K(I1,1)=3
12419 IF(K(I1,1).EQ.11) K(I1,1)=14
12420C...Find a not yet considered colour/anticolour line.
12421 DO 530 ISDE1=1,2
12422 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12423 NMAT=0
12424 DO 500 ILBL=1,NLBL
12425 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12426 500 CONTINUE
12427 IF(NMAT.EQ.0) THEN
12428 NLBL=NLBL+1
12429 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12430C...Find all others belonging to same line.
12431 I3=I1
12432 I4=0
12433 DO 520 IUP2=IUP1+1,NUP
12434 I2=MINT(84)+IUP2
12435 DO 510 ISDE2=1,2
12436 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12437 IF(ISDE2.EQ.ISDE1) THEN
12438 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12439 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12440 I3=I2
12441 ELSEIF(I4.NE.0) THEN
12442 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12443 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12444 I4=I2
12445 ELSEIF(IUP2.LE.2) THEN
12446 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12447 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12448 I4=I2
12449 ELSE
12450 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12451 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12452 I4=I2
12453 ENDIF
12454 ENDIF
12455 510 CONTINUE
12456 520 CONTINUE
12457 ENDIF
12458 530 CONTINUE
12459 540 CONTINUE
12460
12461 ELSEIF(IDOC.EQ.7) THEN
12462C...Resonance not decaying; store kinematics
12463 I=MINT(83)+7
12464 K(IPU3,1)=1
12465 K(IPU3,2)=KFRES
12466 K(IPU3,3)=I
12467 P(IPU3,4)=SHUSER
12468 P(IPU3,5)=SHUSER
12469 K(I,1)=21
12470 K(I,2)=KFRES
12471 P(I,4)=SHUSER
12472 P(I,5)=SHUSER
12473 N=IPU3
12474 MINT(21)=KFRES
12475 MINT(22)=0
12476
12477C...Special cases: colour flow in coloured resonances
12478 KCRES=PYCOMP(KFRES)
12479 IF(KCHG(KCRES,2).NE.0) THEN
12480 K(IPU3,1)=3
12481 DO 550 J=1,2
12482 JC=J
12483 IF(KCS.EQ.-1) JC=3-J
12484 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12485 & MINT(84)+ICOL(KCC,1,JC)
12486 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12487 & MINT(84)+ICOL(KCC,2,JC)
12488 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12489 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12490 550 CONTINUE
12491 ELSE
12492 K(IPU1,4)=IPU2
12493 K(IPU1,5)=IPU2
12494 K(IPU2,4)=IPU1
12495 K(IPU2,5)=IPU1
12496 ENDIF
12497
12498 ELSEIF(IDOC.EQ.8) THEN
12499C...2 -> 2 processes: store outgoing partons in their CM-frame
12500 DO 560 JT=1,2
12501 I=MINT(84)+2+JT
12502 KCA=PYCOMP(MINT(20+JT))
12503 K(I,1)=1
12504 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12505 K(I,2)=MINT(20+JT)
12506 K(I,3)=MINT(83)+IDOC+JT-2
12507 KFAA=IABS(K(I,2))
12508 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12509 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12510 ELSE
12511 P(I,5)=PYMASS(K(I,2))
12512 ENDIF
12513 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12514 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12515 560 CONTINUE
12516 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12517 KFA1=IABS(MINT(21))
12518 KFA2=IABS(MINT(22))
12519 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12520 & THEN
12521 MINT(51)=1
12522 RETURN
12523 ENDIF
12524 P(IPU3,5)=0D0
12525 P(IPU4,5)=0D0
12526 ENDIF
12527 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12528 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12529 P(IPU4,4)=SHR-P(IPU3,4)
12530 P(IPU4,3)=-P(IPU3,3)
12531 N=IPU4
12532 MINT(7)=MINT(83)+7
12533 MINT(8)=MINT(83)+8
12534
12535C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12536 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12537
12538 ELSEIF(IDOC.EQ.9) THEN
12539C...2 -> 3 processes: store outgoing partons in their CM frame
12540 DO 570 JT=1,2
12541 I=MINT(84)+2+JT
12542 KCA=PYCOMP(MINT(20+JT))
12543 K(I,1)=1
12544 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12545 K(I,2)=MINT(20+JT)
12546 K(I,3)=MINT(83)+IDOC+JT-3
12547 JTA=JT
12548C...t and b in opposide order in event list as compared to
12549C...matrix element?
12550 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12551 IF(IABS(K(I,2)).LE.22) THEN
12552 P(I,5)=PYMASS(K(I,2))
12553 ELSE
12554 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12555 ENDIF
12556 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12557 P(I,1)=PT*COS(VINT(198+5*JTA))
12558 P(I,2)=PT*SIN(VINT(198+5*JTA))
12559 570 CONTINUE
12560 K(IPU5,1)=1
12561 K(IPU5,2)=KFRES
12562 K(IPU5,3)=MINT(83)+IDOC
12563 P(IPU5,5)=SHR
12564 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12565 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12566 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12567 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12568 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12569 PMT3=SQRT(PMS3)
12570 P(IPU5,3)=PMT3*SINH(VINT(211))
12571 P(IPU5,4)=PMT3*COSH(VINT(211))
12572 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12573 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12574 IF(SQL12.LE.0D0) THEN
12575 MINT(51)=1
12576 RETURN
12577 ENDIF
12578 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12579 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12580 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12581 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12582C...t and b in opposide order in event list as compared to
12583C...matrix element
12584 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12585 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12586 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12587 END IF
12588 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12589 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12590 MINT(23)=KFRES
12591 N=IPU5
12592 MINT(7)=MINT(83)+7
12593 MINT(8)=MINT(83)+8
12594
12595 ELSEIF(IDOC.EQ.11) THEN
12596C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12597 PHI(1)=PARU(2)*PYR(0)
12598 PHI(2)=PHI(1)-PHIR
12599 DO 580 JT=1,2
12600 I=MINT(84)+2+JT
12601 K(I,1)=1
12602 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12603 K(I,2)=MINT(20+JT)
12604 K(I,3)=MINT(83)+IDOC+JT-2
12605 P(I,5)=PYMASS(K(I,2))
12606 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12607 MINT(51)=1
12608 RETURN
12609 ENDIF
12610 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12611 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12612 P(I,1)=PTABS*COS(PHI(JT))
12613 P(I,2)=PTABS*SIN(PHI(JT))
12614 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12615 P(I,4)=0.5D0*SHPR*Z(JT)
12616 IZW=MINT(83)+6+JT
12617 K(IZW,1)=21
12618 K(IZW,2)=23
12619 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12620 K(IZW,3)=IZW-2
12621 P(IZW,1)=-P(I,1)
12622 P(IZW,2)=-P(I,2)
12623 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12624 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12625 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12626 580 CONTINUE
12627 I=MINT(83)+9
12628 K(IPU5,1)=1
12629 K(IPU5,2)=KFRES
12630 K(IPU5,3)=I
12631 P(IPU5,5)=SHR
12632 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12633 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12634 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12635 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12636 K(I,1)=21
12637 K(I,2)=KFRES
12638 DO 590 J=1,5
12639 P(I,J)=P(IPU5,J)
12640 590 CONTINUE
12641 N=IPU5
12642 MINT(23)=KFRES
12643
12644 ELSEIF(IDOC.EQ.12) THEN
12645C...Z0 and W+/- scattering: store bosons and outgoing partons
12646 PHI(1)=PARU(2)*PYR(0)
12647 PHI(2)=PHI(1)-PHIR
12648 JTRAN=INT(1.5D0+PYR(0))
12649 DO 600 JT=1,2
12650 I=MINT(84)+2+JT
12651 K(I,1)=1
12652 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12653 K(I,2)=MINT(20+JT)
12654 K(I,3)=MINT(83)+IDOC+JT-2
12655 P(I,5)=PYMASS(K(I,2))
12656 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12657 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12658 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12659 P(I,1)=PTABS*COS(PHI(JT))
12660 P(I,2)=PTABS*SIN(PHI(JT))
12661 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12662 P(I,4)=0.5D0*SHPR*Z(JT)
12663 IZW=MINT(83)+6+JT
12664 K(IZW,1)=21
12665 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12666 K(IZW,2)=23
12667 ELSE
12668 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12669 ENDIF
12670 K(IZW,3)=IZW-2
12671 P(IZW,1)=-P(I,1)
12672 P(IZW,2)=-P(I,2)
12673 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12674 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12675 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12676 IPU=MINT(84)+4+JT
12677 K(IPU,1)=3
12678 K(IPU,2)=KFPR(ISUB,JT)
12679 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12680 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12681 K(IPU,3)=MINT(83)+8+JT
12682 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12683 P(IPU,5)=PYMASS(K(IPU,2))
12684 ELSE
12685 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12686 ENDIF
12687 MINT(22+JT)=K(IPU,2)
12688 600 CONTINUE
12689C...Find rotation and boost for hard scattering subsystem
12690 I1=MINT(83)+7
12691 I2=MINT(83)+8
12692 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12693 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12694 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12695 GAMCM=(P(I1,4)+P(I2,4))/SHR
12696 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12697 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12698 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12699 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12700 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12701 PHICM=PYANGL(PX,PY)
12702C...Store hard scattering subsystem. Rotate and boost it
12703 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12704 & P(IPU6,5)**2
12705 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12706 CTHWZ=VINT(23)
12707 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12708 PHIWZ=VINT(24)-PHICM
12709 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12710 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12711 P(IPU5,3)=PABS*CTHWZ
12712 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12713 P(IPU6,1)=-P(IPU5,1)
12714 P(IPU6,2)=-P(IPU5,2)
12715 P(IPU6,3)=-P(IPU5,3)
12716 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12717 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12718 DO 620 JT=1,2
12719 I1=MINT(83)+8+JT
12720 I2=MINT(84)+4+JT
12721 K(I1,1)=21
12722 K(I1,2)=K(I2,2)
12723 DO 610 J=1,5
12724 P(I1,J)=P(I2,J)
12725 610 CONTINUE
12726 620 CONTINUE
12727 N=IPU6
12728 MINT(7)=MINT(83)+9
12729 MINT(8)=MINT(83)+10
12730 ENDIF
12731
12732 IF(ISET(ISUB).EQ.11) THEN
12733 ELSEIF(IDOC.GE.8) THEN
12734C...Store colour connection indices
12735 DO 630 J=1,2
12736 JC=J
12737 IF(KCS.EQ.-1) JC=3-J
12738 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12739 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12740 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12741 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12742 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12743 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12744 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12745 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12746 630 CONTINUE
12747
12748C...Copy outgoing partons to documentation lines
12749 IMAX=2
12750 IF(IDOC.EQ.9) IMAX=3
12751 DO 650 I=1,IMAX
12752 I1=MINT(83)+IDOC-IMAX+I
12753 I2=MINT(84)+2+I
12754 K(I1,1)=21
12755 K(I1,2)=K(I2,2)
12756 IF(IDOC.LE.9) K(I1,3)=0
12757 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12758 DO 640 J=1,5
12759 P(I1,J)=P(I2,J)
12760 640 CONTINUE
12761 650 CONTINUE
12762
12763 ELSEIF(IDOC.EQ.9) THEN
12764C...Store colour connection indices
12765 DO 660 J=1,2
12766 JC=J
12767 IF(KCS.EQ.-1) JC=3-J
12768 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12769 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12770 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12771 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12772 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12773 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12774 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12775 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12776 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12777 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12778 660 CONTINUE
12779
12780C...Copy outgoing partons to documentation lines
12781 DO 680 I=1,3
12782 I1=MINT(83)+IDOC-3+I
12783 I2=MINT(84)+2+I
12784 K(I1,1)=21
12785 K(I1,2)=K(I2,2)
12786 K(I1,3)=0
12787 DO 670 J=1,5
12788 P(I1,J)=P(I2,J)
12789 670 CONTINUE
12790 680 CONTINUE
12791 ENDIF
12792
12793C...Copy outgoing partons to list of allowed radiators.
12794 NPART=0
12795 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12796 DO 690 I=MINT(84)+3,N
12797 NPART=NPART+1
12798 IPART(NPART)=I
12799 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12800 690 CONTINUE
12801 ENDIF
12802
12803C...Low-pT events: remove gluons used for string drawing purposes
12804 IF(ISUB.EQ.95) THEN
12805 IF(MINT(35).LE.1) THEN
12806 K(IPU3,1)=K(IPU3,1)+10
12807 K(IPU4,1)=K(IPU4,1)+10
12808 ENDIF
12809 DO 700 J=41,66
12810 VINTSV(J)=VINT(J)
12811 VINT(J)=0D0
12812 700 CONTINUE
12813 DO 720 I=MINT(83)+5,MINT(83)+8
12814 DO 710 J=1,5
12815 P(I,J)=0D0
12816 710 CONTINUE
12817 720 CONTINUE
12818 ENDIF
12819
12820 RETURN
12821 END
12822
12823C***********************************************************************
12824
12825C...PYEVOL
12826C...Handles intertwined pT-ordered spacelike initial-state parton
12827C...and multiple interactions.
12828
12829 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12830C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12831C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12832C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12833
12834C...Double precision and integer declarations.
12835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12836 IMPLICIT INTEGER(I-N)
12837 INTEGER PYK,PYCHGE,PYCOMP
12838C...External
12839 EXTERNAL PYALPS
12840 DOUBLE PRECISION PYALPS
12841C...Parameter statement for maximum size of showers.
12842 PARAMETER (MAXNUR=1000)
12843C...Commonblocks.
12844 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12845 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12846 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12847 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12848 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12849 COMMON/PYINT1/MINT(400),VINT(400)
12850 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12851 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12852 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12853 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12854 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12855 COMMON/PYCTAG/NCT,MCT(4000,2)
12856 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12857 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12858 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12859C...Local arrays and saved variables.
12860 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12861 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12862 & ,PSAV,KSAV,VSAV
12863
12864 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12865 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12866
12867C----------------------------------------------------------------------
12868C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12869C...done only once per event, while MODE=0 is repeated each time the
12870C...evolution needs to be restarted.
12871 IF (MODE.EQ.-1) THEN
12872 ISUBHD=MINT(1)
12873 NSAV=N
12874 NPARTS=NPART
12875C...Store hard scattering variables
12876 M15SV=MINT(15)
12877 M16SV=MINT(16)
12878 M21SV=MINT(21)
12879 M22SV=MINT(22)
12880 DO 100 J=11,80
12881 VINTSV(J)=VINT(J)
12882 100 CONTINUE
12883 DO 120 J=1,5
12884 DO 110 IS=1,4
12885 I=IS+MINT(84)
12886 PSAV(IS,J)=P(I,J)
12887 KSAV(IS,J)=K(I,J)
12888 VSAV(IS,J)=V(I,J)
12889 110 CONTINUE
12890 120 CONTINUE
12891
12892C...Set shat for hardest scattering
12893 SHAT(1)=VINT(44)
12894 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12895 & *VINT(2)
12896
12897C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12898 RMC=PMAS(4,1)
12899 RMB=PMAS(5,1)
12900 ALAM4=PARP(61)
12901 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12902 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12903 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12904
12905C----------------------------------------------------------------------
12906C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12907C...interaction initiators, with no previous evolution. Check the input
12908C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12909C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12910C...smaller than the CM energy / 2.)
12911 ELSEIF (MODE.EQ.0) THEN
12912C...Reset counters and switches
12913 N=NSAV
12914 NPART=NPARTS
12915 MINT(30)=0
12916 MINT(31)=1
12917 MINT(36)=1
12918C...Reset hard scattering variables
12919 MINT(1)=ISUBHD
12920 DO 130 J=11,80
12921 VINT(J)=VINTSV(J)
12922 130 CONTINUE
12923 DO 150 J=1,5
12924 DO 140 IS=1,4
12925 I=IS+MINT(84)
12926 P(I,J)=PSAV(IS,J)
12927 K(I,J)=KSAV(IS,J)
12928 V(I,J)=VSAV(IS,J)
12929 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12930 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12931 140 CONTINUE
12932 150 CONTINUE
12933C...Reset statistics on activity in event.
12934 DO 160 J=351,359
12935 MINT(J)=0
12936 VINT(J)=0D0
12937 160 CONTINUE
12938C...Reset extra companion reweighting factor
12939 VINT(140)=1D0
12940
12941C...We do not generate MI for soft process (ISUB=95), but the
12942C...initialization must be done regardless, for later purposes.
12943 MINT(36)=1
12944
12945C...Initialize multiple interactions.
12946 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12947 IF(MINT(51).NE.0) RETURN
12948
12949C...Decide whether quarks in hard scattering were valence or sea
12950 PT2HD=VINT(54)
12951 DO 170 JS=1,2
12952 MINT(30)=JS
12953 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12954 IF(MINT(51).NE.0) RETURN
12955 170 CONTINUE
12956
12957C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12958 VINT(18)=0D0
12959 IF(MSTP(70).EQ.0) THEN
12960 PT20=PARP(62)**2
12961 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12962 ELSEIF(MSTP(70).EQ.1) THEN
12963 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12964 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12965 ELSE
12966 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12967 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12968 ENDIF
12969C...Also store PT2MIN in VINT(17).
12970 180 VINT(17)=PT2MIN
12971
12972C...Set FS masses zero now.
12973 VINT(63)=0D0
12974 VINT(64)=0D0
12975
12976C...Initialize IS showers with VINT(56) as max scale.
12977 PT2ISR=VINT(56)
12978 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12979 IF(MINT(51).NE.0) RETURN
12980
12981 RETURN
12982
12983C----------------------------------------------------------------------
12984C...MODE= 1: Evolve event from PTMAX to PTMIN.
12985 ELSEIF (MODE.EQ.1) THEN
12986
12987C...Skip if no phase space.
12988 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12989
12990C...Starting pT2 max scale (to be udpated successively).
12991 PT2CMX=PT2MAX
12992
12993C...Evolve two sides of the event to find which branches at highest pT.
12994 200 JSMX=-1
12995 MIMX=0
12996 PT2MX=0D0
12997
12998C...Loop over current shower initiators.
12999 IF (MSTP(61).GE.1) THEN
13000 DO 230 MI=1,MINT(31)
13001 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13002 ISUB=96
13003 IF (MI.EQ.1) ISUB=ISUBHD
13004 MINT(1)=ISUB
13005 MINT(36)=MI
13006C...Set up shat, initiator x values, and x remaining in BR.
13007 VINT(44)=SHAT(MI)
13008 VINT(141)=XMI(1,MI)
13009 VINT(142)=XMI(2,MI)
13010 VINT(143)=1D0
13011 VINT(144)=1D0
13012 DO 210 JI=1,MINT(31)
13013 IF (JI.EQ.MINT(36)) GOTO 210
13014 VINT(143)=VINT(143)-XMI(1,JI)
13015 VINT(144)=VINT(144)-XMI(2,JI)
13016 210 CONTINUE
13017C...Loop over sides.
13018C...Generate trial branchings for this interaction. The hardest
13019C...branching so far is automatically updated if necessary in /PYISMX/.
13020 DO 220 JS=1,2
13021 MINT(30)=JS
13022 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13023 IF (MINT(51).NE.0) RETURN
13024 220 CONTINUE
13025 230 CONTINUE
13026 ENDIF
13027
13028C...Generate trial additional interaction.
13029 MINT(36)=MINT(31)+1
13030 240 IF (MOD(MSTP(81),10).GE.1) THEN
13031 MINT(1)=96
13032C...Set up X remaining in BR.
13033 VINT(143)=1D0
13034 VINT(144)=1D0
13035 DO 250 JI=1,MINT(31)
13036 VINT(143)=VINT(143)-XMI(1,JI)
13037 VINT(144)=VINT(144)-XMI(2,JI)
13038 250 CONTINUE
13039C...Generate trial interaction
13040 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13041 IF (MINT(51).EQ.1) RETURN
13042 ENDIF
13043
13044C...And the winner is:
13045 IF (PT2MX.LT.PT2MIN) THEN
13046 GOTO 330
13047 ELSEIF (JSMX.EQ.0) THEN
13048C...Accept additional interaction (may still fail).
13049 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13050 IF(MINT(51).NE.0) RETURN
13051 IF (IFAIL.EQ.0) THEN
13052 SHAT(MINT(36))=VINT(44)
13053C...Decide on flavours (valence/sea/companion).
13054 DO 270 JS=1,2
13055 MINT(30)=JS
13056 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13057 IF(MINT(51).NE.0) RETURN
13058 270 CONTINUE
13059 ENDIF
13060 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13061C...Reconstruct kinematics of acceptable ISR branching.
13062C...Set up shat, initiator x values, and x remaining in BR.
13063 MINT(30)=JSMX
13064 MINT(36)=MIMX
13065 VINT(44)=SHAT(MINT(36))
13066 VINT(141)=XMI(1,MINT(36))
13067 VINT(142)=XMI(2,MINT(36))
13068 VINT(143)=1D0
13069 VINT(144)=1D0
13070 DO 280 JI=1,MINT(31)
13071 IF (JI.EQ.MINT(36)) GOTO 280
13072 VINT(143)=VINT(143)-XMI(1,JI)
13073 VINT(144)=VINT(144)-XMI(2,JI)
13074 280 CONTINUE
13075 PT2NEW=PT2MX
13076 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13077 IF (MINT(51).EQ.1) RETURN
13078 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13079C...Bookeep joining. Cannot (yet) be constructed kinematically.
13080 MINT(354)=MINT(354)+1
13081 VINT(354)=VINT(354)+SQRT(PT2MX)
13082 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13083 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13084 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13085 ENDIF
13086
13087C...Update PT2 iteration scale.
13088 PT2CMX=PT2MX
13089
13090C...Loop back to continue evolution.
13091 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13092 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13093 ELSE
13094 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13095 ENDIF
13096
13097C----------------------------------------------------------------------
13098C...MODE= 2: (Re-)store user information on hardest interaction etc.
13099 ELSEIF (MODE.EQ.2) THEN
13100
13101C...Revert to "ordinary" meanings of some parameters.
13102 290 DO 310 JS=1,2
13103 MINT(12+JS)=K(IMI(JS,1,1),2)
13104 VINT(140+JS)=XMI(JS,1)
13105 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13106 VINT(142+JS)=1D0
13107 DO 300 MI=1,MINT(31)
13108 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13109 300 CONTINUE
13110 310 CONTINUE
13111
13112C...Restore saved quantities for hardest interaction.
13113 MINT(1)=ISUBHD
13114 MINT(15)=M15SV
13115 MINT(16)=M16SV
13116 MINT(21)=M21SV
13117 MINT(22)=M22SV
13118 DO 320 J=11,80
13119 VINT(J)=VINTSV(J)
13120 320 CONTINUE
13121
13122 ENDIF
13123
13124 330 RETURN
13125 END
13126
13127C*********************************************************************
13128
13129C...PYSSPA
13130C...Generates spacelike parton showers.
13131
13132 SUBROUTINE PYSSPA(IPU1,IPU2)
13133
13134C...Double precision and integer declarations.
13135 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13136 IMPLICIT INTEGER(I-N)
13137 INTEGER PYK,PYCHGE,PYCOMP
13138C...Commonblocks.
13139 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13142 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13143 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13144 COMMON/PYINT1/MINT(400),VINT(400)
13145 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13146 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13147 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13148 &/PYINT2/,/PYINT3/
13149C...Local arrays and data.
13150 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13151 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13152 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13153 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13154 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13155 DATA IS/2*0/
13156
13157C...Read out basic information; set global Q^2 scale.
13158 IPUS1=IPU1
13159 IPUS2=IPU2
13160 ISUB=MINT(1)
13161 Q2MX=VINT(56)
13162 VINT2R=VINT(2)*VINT(143)*VINT(144)
13163 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13164 &MIN(VINT2R,PARP(67)*VINT(56))
13165 FCQ2MX=1D0
13166
13167C...Define which processes ME corrections have been implemented for.
13168 MECOR=0
13169 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13170 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13171 & ISUB.EQ.144) MECOR=1
13172 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13173 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13174 ENDIF
13175
13176C...Initialize QCD evolution and check phase space.
13177 Q2MNC=PARP(62)**2
13178 Q2MNCS(1)=Q2MNC
13179 Q2MNCS(2)=Q2MNC
13180 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13181 Q0S=PARP(15)**2
13182 PS=VINT(3)**2
13183 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13184 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13185 Q2INT=SQRT(Q0S*Q2EFF)
13186 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13187 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13188 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13189 ENDIF
13190 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13191 Q0S=PARP(15)**2
13192 PS=VINT(4)**2
13193 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13194 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13195 Q2INT=SQRT(Q0S*Q2EFF)
13196 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13197 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13198 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13199 ENDIF
13200 MCEV=0
13201 ALAMS=PARU(112)
13202 PARU(112)=PARP(61)
13203 FQ2C=1D0
13204 TCMX=0D0
13205 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13206 MCEV=1
13207 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13208 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13209 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13210 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13211 & MCEV=0
13212 ENDIF
13213
13214C...Initialize QED evolution and check phase space.
13215 MEEV=0
13216 XEE=1D-10
13217 SPME=PMAS(11,1)**2
13218 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13219 &SPME=PMAS(13,1)**2
13220 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13221 &SPME=PMAS(15,1)**2
13222 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13223 TEMX=0D0
13224 FWTE=10D0
13225 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13226 MEEV=1
13227 TEMX=LOG(Q2MX/SPME)
13228 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13229 ENDIF
13230 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13231 MEEV=2
13232 TEMX=TCMX
13233 FWTE=1D0
13234 ENDIF
13235 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13236
13237C...Loopback point in case of failure to reconstruct kinematics.
13238 NS=N
13239 LOOP=0
13240 MNT352=MINT(352)
13241 MNT353=MINT(353)
13242 VNT352=VINT(352)
13243 VNT353=VINT(353)
13244 100 LOOP=LOOP+1
13245 IF(LOOP.GT.100) THEN
13246 MINT(51)=1
13247 RETURN
13248 ENDIF
13249 N=NS
13250 MINT(352)=MNT352
13251 MINT(353)=MNT353
13252 VINT(352)=VNT352
13253 VINT(353)=VNT353
13254
13255C...Initial values: flavours, momenta, virtualities.
13256 DO 120 JT=1,2
13257 MORE(JT)=1
13258 KFBEAM(JT)=MINT(10+JT)
13259 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13260 KFLS(JT)=MINT(14+JT)
13261 KFLS(JT+2)=KFLS(JT)
13262 XS(JT)=VINT(40+JT)
13263 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13264 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13265 ZS(JT)=1D0
13266 Q2S(JT)=FCQ2MX*Q2MX
13267 DQ2(JT)=0D0
13268 TEVCSV(JT)=TCMX
13269 ALAM(JT)=PARP(61)
13270 THE2(JT)=1D0
13271 TEVESV(JT)=TEMX
13272 MCESV(JT)=0
13273C...Calculate initial parton distribution weights.
13274 MINT(105)=MINT(102+JT)
13275 MINT(109)=MINT(106+JT)
13276 VINT(120)=VINT(2+JT)
13277C.... ALICE
13278C.... Store side in MINT(124)
13279 MINT(124) = JT
13280C....
13281 IF(XS(JT).LT.1D0-XEE) THEN
13282 IF(MINT(31).GE.2) MINT(30)=JT
13283 IF(MSTP(57).LE.1) THEN
13284 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13285 ELSE
13286 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13287 ENDIF
13288 ENDIF
13289 DO 110 KFL=-25,25
13290 XFS(JT,KFL)=XFB(KFL)
13291 110 CONTINUE
13292C...Special kinematics check for c/b quarks (that g -> c cbar or
13293C...b bbar kinematically possible).
13294 KFLCB=IABS(KFLS(JT))
13295 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13296 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13297 MINT(51)=1
13298 RETURN
13299 ENDIF
13300 ENDIF
13301 120 CONTINUE
13302 DSH=VINT(44)
13303 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13304
13305C...Find if interference with final state partons.
13306 MFIS=0
13307 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13308 IF(MFIS.NE.0) THEN
13309 DO 140 I=1,2
13310 KCFI(I)=0
13311 KCA=PYCOMP(IABS(KFLS(I)))
13312 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13313 NFIS(I)=0
13314 IF(KCFI(I).NE.0) THEN
13315 IF(I.EQ.1) IPFS=IPUS1
13316 IF(I.EQ.2) IPFS=IPUS2
13317 DO 130 J=1,2
13318 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13319 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13320 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13321 NFIS(I)=NFIS(I)+1
13322 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13323 & P(ICSI,2)**2))
13324 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13325 ENDIF
13326 130 CONTINUE
13327 ENDIF
13328 140 CONTINUE
13329 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13330 ENDIF
13331
13332C...Pick up leg with highest virtuality.
13333 JTOLD=1
13334 150 N=N+1
13335 JT=1
13336 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13337 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13338 IF(MORE(JT).EQ.0) JT=3-JT
13339 JTOLD=JT
13340 KFLB=KFLS(JT)
13341 XB=XS(JT)
13342 DO 160 KFL=-25,25
13343 XFB(KFL)=XFS(JT,KFL)
13344 160 CONTINUE
13345 DSHR=2D0*SQRT(DSH)
13346 DSHZ=DSH/ZS(JT)
13347
13348C...Check if allowed to branch.
13349 MCEV=0
13350 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13351 MCEV=1
13352 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13353 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13354 ENDIF
13355 MEEV=0
13356 IF(MINT(44+JT).EQ.3) THEN
13357 MEEV=1
13358 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13359 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13360 & MEEV=0
13361C***Currently kill QED shower for resolved photoproduction.
13362 IF(MINT(18+JT).EQ.1) MEEV=0
13363C***Currently kill shower for W inside electron.
13364 IF(IABS(KFLB).EQ.24) THEN
13365 MCEV=0
13366 MEEV=0
13367 ENDIF
13368 ENDIF
13369 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13370 &MEEV=2
13371 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13372 Q2B=0D0
13373 GOTO 260
13374 ENDIF
13375
13376C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13377 Q2B=Q2S(JT)
13378 TEVCB=TEVCSV(JT)
13379 TEVEB=TEVESV(JT)
13380 IF(MSTP(62).LE.1) THEN
13381 IF(ZS(JT).GT.0.99999D0) THEN
13382 Q2B=Q2S(JT)
13383 ELSE
13384 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13385 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13386 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13387 ENDIF
13388 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13389 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13390 ENDIF
13391 IF(MCEV.EQ.1) THEN
13392 ALSDUM=PYALPS(FQ2C*Q2B)
13393 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13394 ALAM(JT)=PARU(117)
13395 B0=(33D0-2D0*MSTU(118))/6D0
13396 ENDIF
13397 IF(MEEV.EQ.2) TEVEB=TEVCB
13398 TEVCBS=TEVCB
13399 TEVEBS=TEVEB
13400
13401C...Select side for interference with final state partons.
13402 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13403 IFI=N-NS
13404 ISFI(IFI)=0
13405 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13406 ISFI(IFI)=1
13407 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13408 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13409 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13410 ISFI(IFI)=1
13411 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13412 ENDIF
13413 ENDIF
13414
13415C...Calculate preweighting factor for ME-corrected processes.
13416 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13417
13418C...Calculate Altarelli-Parisi weights.
13419 DO 170 KFL=-25,25
13420 WTAPC(KFL)=0D0
13421 WTAPE(KFL)=0D0
13422 WTSF(KFL)=0D0
13423 170 CONTINUE
13424C...q -> q (g or gamma emission), g -> q.
13425 IF(IABS(KFLB).LE.10) THEN
13426 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13427 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13428 EQ2=1D0/9D0
13429 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13430 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13431 & (XEC*(1D0-XEC)))
13432 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13433 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13434 WTAPC(21)=WTGF*WTAPC(21)
13435 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13436 ENDIF
13437C...f -> f, gamma -> f.
13438 ELSEIF(IABS(KFLB).LE.20) THEN
13439 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13440 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13441 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13442 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13443 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13444 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13445 WTAPE(22)=WTGF*WTAPE(22)
13446 ENDIF
13447C...f -> g, g -> g.
13448 ELSEIF(KFLB.EQ.21) THEN
13449 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13450 DO 180 KFL=1,MSTP(58)
13451 WTAPC(KFL)=WTAPQ
13452 WTAPC(-KFL)=WTAPQ
13453 180 CONTINUE
13454 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13455 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13456 DO 190 KFL=1,MSTP(58)
13457 WTAPC(KFL)=WTFG*WTAPC(KFL)
13458 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13459 190 CONTINUE
13460 WTAPC(21)=WTGG*WTAPC(21)
13461 ENDIF
13462C...f -> gamma, W+, W-.
13463 ELSEIF(KFLB.EQ.22) THEN
13464 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13465 WTAPE(11)=WTAPF
13466 WTAPE(-11)=WTAPF
13467 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13468 WTAPE(11)=WTFG*WTAPE(11)
13469 WTAPE(-11)=WTFG*WTAPE(-11)
13470 ENDIF
13471 ELSEIF(KFLB.EQ.24) THEN
13472 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13473 & (XEE*(XB+XEE)))/XB
13474 ELSEIF(KFLB.EQ.-24) THEN
13475 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13476 & (XEE*(XB+XEE)))/XB
13477 ENDIF
13478
13479C...Calculate parton distribution weights and sum.
13480 NTRY=0
13481 200 NTRY=NTRY+1
13482 IF(NTRY.GT.500) THEN
13483 MINT(51)=1
13484 RETURN
13485 ENDIF
13486 WTSUMC=0D0
13487 WTSUME=0D0
13488 XFBO=MAX(1D-10,XFB(KFLB))
13489 DO 210 KFL=-25,25
13490 WTSF(KFL)=XFB(KFL)/XFBO
13491 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13492 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13493 210 CONTINUE
13494 WTSUMC=MAX(0.0001D0,WTSUMC)
13495 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13496
13497C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13498 NTRY2=0
13499 220 NTRY2=NTRY2+1
13500 IF(NTRY2.GT.500) THEN
13501 MINT(51)=1
13502 RETURN
13503 ENDIF
13504 IF(MCEV.EQ.1) THEN
13505 IF(MSTP(64).LE.0) THEN
13506 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13507 ELSEIF(MSTP(64).EQ.1) THEN
13508 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13509 ELSE
13510 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13511 ENDIF
13512 ENDIF
13513 IF(MEEV.EQ.1) THEN
13514 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13515 & (PARU(101)*FWTE*WTSUME*TEMX)))
13516 ELSEIF(MEEV.EQ.2) THEN
13517 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13518 ENDIF
13519
13520C...Translate t into Q2 scale; choose between QCD and QED evolution.
13521 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13522 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13523 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13524C...Ensure that Q2 is above threshold for charm/bottom.
13525 KFLCB=IABS(KFLB)
13526 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13527 &MCEV.EQ.1) THEN
13528 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13529 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13530 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13531 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13532 ENDIF
13533 ENDIF
13534 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13535 &MEEV.EQ.2) THEN
13536 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13537 ENDIF
13538 MCE=0
13539 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13540 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13541 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13542 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13543 IF(Q2EB.GT.Q2MNE) MCE=2
13544 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13545 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13546 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13547 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13548 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13549 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13550 MCE=1
13551 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13552 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13553 ELSE
13554 MCE=2
13555 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13556 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13557 ENDIF
13558
13559C...Evolution possibly ended. Update t values.
13560 IF(MCE.EQ.0) THEN
13561 Q2B=0D0
13562 GOTO 260
13563 ELSEIF(MCE.EQ.1) THEN
13564 Q2B=Q2CB
13565 Q2REF=FQ2C*Q2B
13566 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13567 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13568 ELSE
13569 Q2B=Q2EB
13570 Q2REF=Q2B
13571 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13572 ENDIF
13573
13574C...Select flavour for branching parton.
13575 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13576 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13577 KFLA=-25
13578 240 KFLA=KFLA+1
13579 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13580 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13581 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13582 IF(KFLA.EQ.25) THEN
13583 Q2B=0D0
13584 GOTO 260
13585 ENDIF
13586
13587C...Choose z value and corrective weight.
13588 WTZ=0D0
13589C...q -> q + g or q -> q + gamma.
13590 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13591 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13592 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13593 WTZ=0.5D0*(1D0+Z**2)
13594C...q -> g + q.
13595 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13596 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13597 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13598C...f -> f + gamma.
13599 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13600 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13601 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13602 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13603 ELSE
13604 Z=XB+XB*(XEE/(1D0-XEE))*
13605 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13606 ENDIF
13607 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13608C...f -> gamma + f.
13609 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
13610 Z=XB+XB*(XEE/(1D0-XEE))*
13611 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13612 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
13613C...f -> W+- + f.
13614 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13615 Z=XB+XB*(XEE/(1D0-XEE))*
13616 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13617 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13618 & (Q2B/(Q2B+PMAS(24,1)**2))
13619C...g -> q + qbar.
13620 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13621 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13622 WTZ=1D0-2D0*Z*(1D0-Z)
13623C...g -> g + g.
13624 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13625 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13626 WTZ=(1D0-Z*(1D0-Z))**2
13627C...gamma -> f + fbar.
13628 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13629 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13630 WTZ=1D0-2D0*Z*(1D0-Z)
13631 ENDIF
13632 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13633
13634C...Option with resummation of soft gluon emission as effective z shift.
13635 IF(MCE.EQ.1) THEN
13636 IF(MSTP(65).GE.1) THEN
13637 RSOFT=6D0
13638 IF(KFLB.NE.21) RSOFT=8D0/3D0
13639 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13640 IF(Z.LE.XB) GOTO 220
13641 ENDIF
13642
13643C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13644 IF(MSTP(64).GE.2) THEN
13645 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13646 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13647 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13648 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13649 ENDIF
13650 ENDIF
13651
13652C...Remove kinematically impossible branchings.
13653 UHAT=Q2B-DSH*(1D0-Z)/Z
13654 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13655
13656C...Select phi angle of branching at random.
13657 PHIBR=PARU(2)*PYR(0)
13658
13659C...Matrix-element corrections for some processes.
13660 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13661 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13662 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13663 WTZ=WTZ*WTME/WTFF
13664 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13665 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13666 WTZ=WTZ*WTME/WTGF
13667 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13668 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13669 WTZ=WTZ*WTME/WTFG
13670 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13671 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13672 WTZ=WTZ*WTME/WTGG
13673 ENDIF
13674 ENDIF
13675
13676C...Impose angular constraint in first branching from interference
13677C...with final state partons.
13678 IF(MCE.EQ.1) THEN
13679 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13680 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13681 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13682 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13683 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13684 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13685 ENDIF
13686 ENDIF
13687
13688C...Option with angular ordering requirement.
13689 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13690 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13691 IF(THE2T.GT.THE2(JT)) GOTO 220
13692 ENDIF
13693 ENDIF
13694
13695C...Weighting with new parton distributions.
13696 MINT(105)=MINT(102+JT)
13697 MINT(109)=MINT(106+JT)
13698 VINT(120)=VINT(2+JT)
13699C.... ALICE
13700C.... Store side in MINT(124)
13701 MINT(124)=JT
13702C....
13703 IF(MINT(31).GE.2) MINT(30)=JT
13704 IF(MSTP(57).LE.1) THEN
13705 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13706 ELSE
13707 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13708 ENDIF
13709 XFBN=XFN(KFLB)
13710 IF(XFBN.LT.1D-20) THEN
13711 IF(KFLA.EQ.KFLB) THEN
13712 TEVCB=TEVCBS
13713 TEVEB=TEVEBS
13714 WTAPC(KFLB)=0D0
13715 WTAPE(KFLB)=0D0
13716 GOTO 200
13717 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13718 TEVCB=0.5D0*(TEVCBS+TEVCB)
13719 GOTO 230
13720 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13721 TEVEB=0.5D0*(TEVEBS+TEVEB)
13722 GOTO 230
13723 ELSE
13724 XFBN=1D-10
13725 XFN(KFLB)=XFBN
13726 ENDIF
13727 ENDIF
13728 DO 250 KFL=-25,25
13729 XFB(KFL)=XFN(KFL)
13730 250 CONTINUE
13731 XA=XB/Z
13732C.... ALICE
13733C.... Store side in MINT(124)
13734 MINT(124) = JT
13735C....
13736 IF(MINT(31).GE.2) MINT(30)=JT
13737 IF(MSTP(57).LE.1) THEN
13738 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13739 ELSE
13740 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13741 ENDIF
13742 XFAN=XFA(KFLA)
13743 IF(XFAN.LT.1D-20) GOTO 200
13744 WTSFA=WTSF(KFLA)
13745 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13746
13747C...Define two hard scatterers in their CM-frame.
13748 260 IF(N.EQ.NS+2) THEN
13749 DQ2(JT)=Q2B
13750 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13751 DO 280 JR=1,2
13752 I=NS+JR
13753 IF(JR.EQ.1) IPO=IPUS1
13754 IF(JR.EQ.2) IPO=IPUS2
13755 DO 270 J=1,5
13756 K(I,J)=0
13757 P(I,J)=0D0
13758 V(I,J)=0D0
13759 270 CONTINUE
13760 K(I,1)=14
13761 K(I,2)=KFLS(JR+2)
13762 K(I,4)=IPO
13763 K(I,5)=IPO
13764 P(I,3)=DPLCM*(-1)**(JR+1)
13765 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13766 P(I,5)=-SQRT(DQ2(JR))
13767 K(IPO,1)=14
13768 K(IPO,3)=I
13769 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13770 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13771 280 CONTINUE
13772
13773C...Find maximum allowed mass of timelike parton.
13774 ELSEIF(N.GT.NS+2) THEN
13775 JR=3-JT
13776 DQ2(3)=Q2B
13777 DPC(1)=P(IS(1),4)
13778 DPC(2)=P(IS(2),4)
13779 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13780 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13781 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13782 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13783 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13784 IKIN=0
13785 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13786 & 1D-10*DPD(1)) IKIN=1
13787 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13788 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13789 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13790 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13791
13792C...Generate timelike parton shower (if required).
13793 IT=N
13794 DO 290 J=1,5
13795 K(IT,J)=0
13796 P(IT,J)=0D0
13797 V(IT,J)=0D0
13798 290 CONTINUE
13799C...f -> f + g (gamma).
13800 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13801 K(IT,2)=21
13802 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13803C...f -> g (gamma, W+-) + f.
13804 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13805 K(IT,2)=KFLB
13806 IF(KFLS(JT+2).EQ.24) THEN
13807 K(IT,2)=-12
13808 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13809 K(IT,2)=12
13810 ENDIF
13811C...g (gamma) -> f + fbar, g + g.
13812 ELSE
13813 K(IT,2)=-KFLS(JT+2)
13814 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13815 ENDIF
13816 K(IT,1)=3
13817 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13818 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13819 P(IT,5)=PYMASS(K(IT,2))
13820 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13821 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13822 MSTJ48=MSTJ(48)
13823 PARJ85=PARJ(85)
13824 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13825 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13826 IF(MSTP(63).EQ.1) THEN
13827 Q2TIM=DMSMA
13828 ELSEIF(MSTP(63).EQ.2) THEN
13829 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13830 ELSE
13831 Q2TIM=DMSMA
13832 MSTJ(48)=1
13833 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13834 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13835 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13836 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13837 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13838 ENDIF
13839 CALL PYSHOW(IT,0,SQRT(Q2TIM))
13840 MSTJ(48)=MSTJ48
13841 PARJ(85)=PARJ85
13842 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13843 ENDIF
13844
13845C...Reconstruct kinematics of branching: timelike parton shower.
13846 DMS=P(IT,5)**2
13847 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13848 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13849 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13850 & (4D0*DSH*DPC(3)**2)
13851 IF(DPT2.LT.0D0) GOTO 100
13852 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13853 & DSHR)/DPC(3)-DPC(3)
13854 P(IT,1)=SQRT(DPT2)
13855 P(IT,3)=DPB(1)*(-1)**(JT+1)
13856 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13857 IF(N.GE.IT+1) THEN
13858 DPB(1)=SQRT(DPB(1)**2+DPT2)
13859 DPB(2)=SQRT(DPB(1)**2+DMS)
13860 DPB(3)=P(IT+1,3)
13861 DPB(4)=SQRT(DPB(3)**2+DMS)
13862 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13863 & DPB(1))
13864 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13865 THE=PYANGL(P(IT,3),P(IT,1))
13866 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13867 ENDIF
13868
13869C...Reconstruct kinematics of branching: spacelike parton.
13870 DO 300 J=1,5
13871 K(N+1,J)=0
13872 P(N+1,J)=0D0
13873 V(N+1,J)=0D0
13874 300 CONTINUE
13875 K(N+1,1)=14
13876 K(N+1,2)=KFLB
13877 P(N+1,1)=P(IT,1)
13878 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13879 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13880 P(N+1,5)=-SQRT(DQ2(3))
13881
13882C...Define colour flow of branching.
13883 K(IS(JT),3)=N+1
13884 K(IT,3)=N+1
13885 IM1=N+1
13886 IM2=N+1
13887C...f -> f + gamma (Z, W).
13888 IF(IABS(K(IT,2)).GE.22) THEN
13889 K(IT,1)=1
13890 ID1=IS(JT)
13891 ID2=IS(JT)
13892C...f -> gamma (Z, W) + f.
13893 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13894 ID1=IT
13895 ID2=IT
13896C...gamma -> q + qbar, g + g.
13897 ELSEIF(K(N+1,2).EQ.22) THEN
13898 ID1=IS(JT)
13899 ID2=IT
13900 IM1=ID2
13901 IM2=ID1
13902C...q -> q + g.
13903 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13904 ID1=IT
13905 ID2=IS(JT)
13906C...q -> g + q.
13907 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13908 ID1=IS(JT)
13909 ID2=IT
13910C...qbar -> qbar + g.
13911 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13912 ID1=IS(JT)
13913 ID2=IT
13914C...qbar -> g + qbar.
13915 ELSEIF(K(N+1,2).LT.0) THEN
13916 ID1=IT
13917 ID2=IS(JT)
13918C...g -> g + g; g -> q + qbar.
13919 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13920 ID1=IS(JT)
13921 ID2=IT
13922 ELSE
13923 ID1=IT
13924 ID2=IS(JT)
13925 ENDIF
13926 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13927 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13928 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13929 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13930 IF(ID1.NE.ID2) THEN
13931 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13932 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13933 ENDIF
13934 N=N+1
13935 IF(K(IT,1).EQ.1) THEN
13936 K(IT,4)=0
13937 K(IT,5)=0
13938 ENDIF
13939
13940C...Boost to new CM-frame.
13941 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13942 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13943 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13944 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13945 IR=N+(JT-1)*(IS(1)-N)
13946 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13947 & 0D0,0D0,0D0)
13948
13949C...Global statistics.
13950 MINT(352)=MINT(352)+1
13951 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13952 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13953 ENDIF
13954
13955C...Update kinematics variables.
13956 IS(JT)=N
13957 DQ2(JT)=Q2B
13958 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
13959 DSH=DSHZ
13960
13961C...Save quantities; loop back.
13962 Q2S(JT)=Q2B
13963 DPHI(JT)=PHIBR
13964 MCESV(JT)=MCE
13965 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13966 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13967 KFLS(JT+2)=KFLS(JT)
13968 KFLS(JT)=KFLA
13969 XS(JT)=XA
13970 ZS(JT)=Z
13971 DO 310 KFL=-25,25
13972 XFS(JT,KFL)=XFA(KFL)
13973 310 CONTINUE
13974 TEVCSV(JT)=TEVCB
13975 TEVESV(JT)=TEVEB
13976 ELSE
13977 MORE(JT)=0
13978 IF(JT.EQ.1) IPU1=N
13979 IF(JT.EQ.2) IPU2=N
13980 ENDIF
13981 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13982 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13983 IF(MSTU(21).GE.1) N=NS
13984 IF(MSTU(21).GE.1) RETURN
13985 ENDIF
13986 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13987
13988C...Boost hard scattering partons to frame of shower initiators.
13989 DO 320 J=1,3
13990 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13991 320 CONTINUE
13992 K(N+2,1)=1
13993 DO 330 J=1,5
13994 P(N+2,J)=P(NS+1,J)
13995 330 CONTINUE
13996 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
13997 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
13998 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
13999 IMIN=MINT(83)+5
14000 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14001 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14002 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14003
14004C...Store user information. Reset Lambda value.
14005 IF(MINT(31).LE.1) THEN
14006 K(IPU1,3)=MINT(83)+3
14007 K(IPU2,3)=MINT(83)+4
14008 ELSE
14009 K(IPU1,3)=MINT(83)+1
14010 K(IPU2,3)=MINT(83)+2
14011 ENDIF
14012 DO 340 JT=1,2
14013 MINT(12+JT)=KFLS(JT)
14014 VINT(140+JT)=XS(JT)
14015 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14016 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14017 340 CONTINUE
14018 PARU(112)=ALAMS
14019
14020 RETURN
14021 END
14022C*********************************************************************
14023
14024C...PYPTIS
14025C...Generates pT-ordered spacelike initial-state parton showers and
14026C...trial joinings.
14027C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14028C... interaction initiators at PT2NOW.
14029C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14030C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14031C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14032C... is below PT2CUT.
14033C... (Also generate test joinings if MSTP(96)=1.)
14034C...MODE= 1: Accept stored shower branching. Update event record etc.
14035C...PT2NOW : Starting (max) PT2 scale for evolution.
14036C...PT2CUT : Lower limit for evolution.
14037C...PT2 : Result of evolution. Generated PT2 for trial emission.
14038C...IFAIL : Status return code. IFAIL=0 when all is well.
14039
14040 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14041
14042C...Double precision and integer declarations.
14043 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14044 IMPLICIT INTEGER(I-N)
14045 INTEGER PYK,PYCHGE,PYCOMP
14046C...Parameter statement for maximum size of showers.
14047 PARAMETER (MAXNUR=1000)
14048C...Commonblocks.
14049 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14050 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14051 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14052 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14053 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14054 COMMON/PYINT1/MINT(400),VINT(400)
14055 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14056 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14057 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14058 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14059 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14060 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14061 COMMON/PYCTAG/NCT,MCT(4000,2)
14062 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14063 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14064 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14065C...Local variables
14066 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14067 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14068 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14069 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14070 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14071 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14072C...For check on excessive weights.
14073 CHARACTER CHWT*12
14074
14075C...Only give errors for very large weights, otherwise just warnings
14076 DATA WTEMAX /1.5D0/
14077C...Only give errors for large pT, otherwise just warnings
14078 DATA PTEMAX /5D0/
14079
14080 IFAIL=-1
14081
14082C----------------------------------------------------------------------
14083C...MODE=-1: Initialize initial state showers from scratch, i.e.
14084C...starting from the hardest interaction initiators.
14085 IF (MODE.EQ.-1) THEN
14086C...Set hard scattering SHAT.
14087 SHTNOW(1)=VINT(44)
14088C...Mass thresholds and Lambda for QCD evolution.
14089 AEM2PI=PARU(101)/PARU(2)
14090 RMB=PMAS(5,1)
14091 RMC=PMAS(4,1)
14092 ALAM4=PARP(61)
14093 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14094 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14095 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14096 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14097 RMB2=RMB**2
14098 RMC2=RMC**2
14099C...Massive quark forced creation threshold (in M**2).
14100 TMIN=1.01D0
14101C...Set upper limit for X (ensures some X left for beam remnant).
14102 XMXC=1D0-2D0*PARP(111)/VINT(1)
14103
14104 IF (MSTP(61).GE.1) THEN
14105C...Initial values: flavours, momenta, virtualities.
14106 DO 100 JS=1,2
14107 NISGEN(JS,1)=0
14108
14109C...Special kinematics check for c/b quarks (that g -> c cbar or
14110C...b bbar kinematically possible).
14111 KFLB=K(IMI(JS,1,1),2)
14112 KFLCB=IABS(KFLB)
14113 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14114C...Check PT2MAX > mQ^2
14115 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14116 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14117 & 'No Q creation possible.')
14118 MINT(51)=1
14119 RETURN
14120 ELSE
14121C...Check for physical z values (m == MQ / sqrt(s))
14122C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14123 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14124 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14125 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14126 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14127 & 'Q creation.')
14128 MINT(51)=1
14129 RETURN
14130 ENDIF
14131 ENDIF
14132 ENDIF
14133 100 CONTINUE
14134 ENDIF
14135
14136 MINT(354)=0
14137C...Zero joining array
14138 DO 110 MJ=1,240
14139 MJOIND(1,MJ)=0
14140 MJOIND(2,MJ)=0
14141 110 CONTINUE
14142
14143C----------------------------------------------------------------------
14144C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14145C...MINT(30). Store if emission PT2 scale is largest so far.
14146C...Also generate test joinings if MSTP(96)=1.
14147 ELSEIF(MODE.EQ.0) THEN
14148 IFAIL=-1
14149 MECOR=0
14150 ISUB=MINT(1)
14151 JS=MINT(30)
14152C...No shower for structureless beam
14153 IF (MINT(44+JS).EQ.1) RETURN
14154 MI=MINT(36)
14155 SHAT=VINT(44)
14156C...Absolute shower max scale = VINT(56)
14157 PT2=MIN(PT2NOW,VINT(56))
14158 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14159C...Define for which processes ME corrections have been implemented.
14160 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14161 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14162 & .142.OR.ISUB.EQ.144) MECOR=1
14163 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14164 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14165C...Calculate preweighting factor for ME-corrected processes.
14166 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14167 ENDIF
14168C...Basic info on daughter for which to find mother.
14169 KFLB=K(IMI(JS,MI,1),2)
14170 KFLBA=IABS(KFLB)
14171C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14172C...second companion.
14173 KSVCB=MAX(-1,IMI(JS,MI,2))
14174C...Treat "first" companion of a pair like an ordinary sea quark
14175C...(except that creation diagram is not allowed)
14176 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14177C...X (rescaled to [0,1])
14178 XB=XMI(JS,MI)/VINT(142+JS)
14179C...Massive quarks (use physical masses.)
14180 RMQ2=0D0
14181 MQMASS=0
14182 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14183 RMQ2=RMC2
14184 IF (KFLBA.EQ.5) RMQ2=RMB2
14185C...Special threshold treatment for non-photon beams
14186 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14187 ENDIF
14188
14189C...Flags for parton distribution calls.
14190 MINT(105)=MINT(102+JS)
14191 MINT(109)=MINT(106+JS)
14192 VINT(120)=VINT(2+JS)
14193
14194C...Calculate initial parton distribution weights.
14195 IF(XB.GE.XMXC) THEN
14196 RETURN
14197 ELSEIF(MQMASS.EQ.0) THEN
14198 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14199 ELSE
14200C...Initialize massive quark PT2 dependent pdf underestimate.
14201 PT20=PT2
14202 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14203C.!.Tentative treatment of massive valence quarks.
14204 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14205 XG0=XFB(21)
14206 TPM0=LOG(PT20/RMQ2)
14207 WPDF0=TPM0*XG0/XQ0
14208 ENDIF
14209 IF (KFLBA.LE.6) THEN
14210C...For quarks, only include respective sea, val, or cmp part.
14211 IF (KSVCB.LE.0) THEN
14212 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14213 ELSE
14214C...Find companion's companion
14215 MISEA=0
14216 120 MISEA=MISEA+1
14217 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14218 XS=XMI(JS,MISEA)
14219 XREM=VINT(142+JS)
14220 YS=XS/(XREM+XS)
14221C...Momentum fraction of the companion quark.
14222C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14223 YB=XB*(1D0-YS)
14224 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14225 ENDIF
14226 ENDIF
14227
14228C...Determine overestimated z range: switch at c and b masses.
14229 130 IF (PT2.GT.TMIN*RMB2) THEN
14230 IZRG=3
14231 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14232 B0=23D0/6D0
14233 ALAM2=ALAM5**2
14234 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14235 IZRG=2
14236 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14237 B0=25D0/6D0
14238 ALAM2=ALAM4**2
14239 ELSE
14240 IZRG=1
14241 PT2MNE=PT2CUT
14242 B0=27D0/6D0
14243 ALAM2=ALAM3**2
14244 ENDIF
14245C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14246 ALAM2=ALAM2/PARP(64)
14247C...Overestimated ZMAX:
14248 IF (MQMASS.EQ.0) THEN
14249C...Massless
14250 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14251 & /PT2MNE)-1D0)
14252 ELSE
14253C...Massive (limit for bremsstrahlung diagram > creation)
14254 FMQ=SQRT(RMQ2/SHTNOW(MI))
14255 ZMAX=1D0/(1D0+FMQ)
14256 ENDIF
14257 ZMIN=XB/XMXC
14258
14259C...If kinematically impossible then do not evolve.
14260 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14261
14262C...Reset Altarelli-Parisi and PDF weights.
14263 DO 140 KFL=-5,5
14264 WTAP(KFL)=0D0
14265 WTPDF(KFL)=0D0
14266 140 CONTINUE
14267 WTAP(21)=0D0
14268 WTPDF(21)=0D0
14269C...Zero joining weights and compute X(partner) and X(mother) values.
14270 IF (MSTP(96).NE.0) THEN
14271 NJN=0
14272 DO 150 MJ=1,MINT(31)
14273 WTAPJ(MJ)=0D0
14274 WTPDFJ(MJ)=0D0
14275 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14276 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14277 & +XMI(JS,MI))
14278 150 CONTINUE
14279 ENDIF
14280
14281C...Approximate Altarelli-Parisi weights (integrated AP dz).
14282C...q -> q, g -> q or q -> q + gamma (already set which).
14283 IF(KFLBA.LE.5) THEN
14284C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14285 IF (KSVCB.LT.0) THEN
14286 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14287 ELSE
14288 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14289 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14290 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14291 ENDIF
14292 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14293 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14294 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14295 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14296 WTAP(KFLB)=WTFF*WTAP(KFLB)
14297 WTAP(21)=WTGF*WTAP(21)
14298 WTAPE=WTFF*WTAPE
14299 ENDIF
14300 IF (KSVCB.GE.1) THEN
14301C...Kill normal creation but add joining diagrams for cmp quark.
14302 WTAP(21)=0D0
14303 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14304 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14305 & " quark here. Not handled yet, giving up!")
14306 PT2=0D0
14307 MINT(51)=1
14308 RETURN
14309 ENDIF
14310C...Check for possible joinings
14311 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14312C...Find companion's companion.
14313 MJ=0
14314 160 MJ=MJ+1
14315 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14316 IF (MJOIND(JS,MJ).EQ.0) THEN
14317 Y(MI)=YB+YS
14318 Z=YB/Y(MI)
14319 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14320 IF (WTAPJ(MJ).GT.1D-6) THEN
14321 NJN=1
14322 ELSE
14323 WTAPJ(MJ)=0D0
14324 ENDIF
14325 ENDIF
14326C...Add trial gluon joinings.
14327 DO 170 MJ=1,MINT(31)
14328 KFLC=K(IMI(JS,MJ,1),2)
14329 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14330 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14331 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14332 IF (WTAPJ(MJ).GT.1D-6) THEN
14333 NJN=NJN+1
14334 ELSE
14335 WTAPJ(MJ)=0D0
14336 ENDIF
14337 170 CONTINUE
14338 ENDIF
14339 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14340C...Kill creation diagram for val quarks and sea quarks with companions.
14341 WTAP(21)=0D0
14342 ELSEIF (MQMASS.EQ.0) THEN
14343C...Extra safety factor for massless sea quark creation.
14344 WTAP(21)=WTAP(21)*1.25D0
14345 ENDIF
14346
14347C... q -> g, g -> g.
14348 ELSEIF(KFLB.EQ.21) THEN
14349C...Here we decide later whether a quark picked up is valence or
14350C...sea, so we maintain the extra factor sqrt(z) since we deal
14351C...with the *sum* of sea and valence in this context.
14352 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14353C...new: do not allow backwards evol to pick up heavy flavour.
14354 DO 180 KFL=1,MIN(3,MSTP(58))
14355 WTAP(KFL)=WTAPQ
14356 WTAP(-KFL)=WTAPQ
14357 180 CONTINUE
14358 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14359 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14360 WTAPQ=WTFG*WTAPQ
14361 WTAP(21)=WTGG*WTAP(21)
14362 ENDIF
14363C...Check for possible joinings (companions handled separately above)
14364 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14365 & THEN
14366 DO 190 MJ=1,MINT(31)
14367 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14368 KSVCC=IMI(JS,MJ,2)
14369 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14370 IF (KSVCC.GE.1) GOTO 190
14371 KFLC=K(IMI(JS,MJ,1),2)
14372C...Only try g -> g + g once.
14373 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14374 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14375 IF (KFLC.EQ.21) THEN
14376 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14377 ELSE
14378 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14379 ENDIF
14380 IF (WTAPJ(MJ).GT.1D-6) THEN
14381 NJN=NJN+1
14382 ELSE
14383 WTAPJ(MJ)=0D0
14384 ENDIF
14385 190 CONTINUE
14386 ENDIF
14387 ENDIF
14388
14389C...Initialize massive quark evolution
14390 IF (MQMASS.NE.0) THEN
14391 RML=(RMQ2+VINT(18))/ALAM2
14392 TML=LOG(RML)
14393 TPL=LOG((PT2+VINT(18))/ALAM2)
14394 TPM=LOG((PT2+VINT(18))/RMQ2)
14395 WN=WTAP(21)*WPDF0/B0
14396 ENDIF
14397
14398
14399C...Loopback point for iteration
14400 NTRY=0
14401 NTHRES=0
14402 200 NTRY=NTRY+1
14403 IF(NTRY.GT.500) THEN
14404 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14405 MINT(51)=1
14406 RETURN
14407 ENDIF
14408
14409C... Calculate PDF weights and sum for evolution rate.
14410 WTSUM=0D0
14411 XFBO=MAX(1D-10,XFB(KFLB))
14412 DO 210 KFL=-5,5
14413 WTPDF(KFL)=XFB(KFL)/XFBO
14414 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14415 210 CONTINUE
14416C...Only add gluon mother diagram for massless KFLB.
14417 IF(MQMASS.EQ.0) THEN
14418 WTPDF(21)=XFB(21)/XFBO
14419 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14420 ENDIF
14421 WTSUM=MAX(0.0001D0,WTSUM)
14422 WTSUMS=WTSUM
14423C...Add joining diagrams where applicable.
14424 WTJOIN=0D0
14425 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14426 DO 220 MJ=1,MINT(31)
14427 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14428 WTPDFJ(MJ)=1D0/XFBO
14429C...x and x*pdf (+ sea/val) for parton C.
14430 KFLC=K(IMI(JS,MJ,1),2)
14431 KFLCA=IABS(KFLC)
14432 KSVCC=MAX(-1,IMI(JS,MJ,2))
14433 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14434 MINT(30)=JS
14435 MINT(36)=MJ
14436 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14437 MINT(36)=MI
14438 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14439 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14440 ELSEIF (KSVCC.GE.1) THEN
14441 print*, 'error! parton C is companion!'
14442 ENDIF
14443 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14444C...x and x*pdf (+ sea/val) for parton A.
14445 KFLA=21
14446 KSVCA=0
14447 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14448 KFLA=KFLB
14449 KSVCA=KSVCB
14450 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14451 KFLA=KFLC
14452 KSVCA=KSVCC
14453 ENDIF
14454 MINT(30)=JS
14455 IF (KSVCA.LE.0) THEN
14456C...Consider C the "evolved" parton if B is gluon. Val/sea
14457C...counting will then be done correctly in PYPDFU.
14458 IF (KFLBA.EQ.21) MINT(36)=MJ
14459 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14460 MINT(36)=MI
14461 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14462 ELSE
14463C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14464 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14465 ENDIF
14466 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14467 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14468 220 CONTINUE
14469 ENDIF
14470
14471C...Pick normal pT2 (in overestimated z range).
14472 230 PT2OLD=PT2
14473 WTSUM=WTSUMS
14474 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14475 KFLC=21
14476
14477C...Evolve q -> q gamma separately, pick it if larger pT.
14478 IF(KFLBA.LE.5) THEN
14479 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14480 IF(PT2QED.GT.PT2) THEN
14481 PT2=PT2QED
14482 KFLC=22
14483 KFLA=KFLB
14484 ENDIF
14485 ENDIF
14486
14487C... Evolve massive quark creation separately.
14488 MCRQQ=0
14489 IF (MQMASS.NE.0) THEN
14490 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14491 & -VINT(18)
14492C... Ensure mininimum PT2CR and force creation near threshold.
14493 IF (PT2CR.LT.TMIN*RMQ2) THEN
14494 NTHRES=NTHRES+1
14495 IF (NTHRES.GT.50) THEN
14496 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14497 & 'massive quark creation. Gave up trying.')
14498 MINT(51)=1
14499 RETURN
14500 ENDIF
14501 PT2=0D0
14502 PT2CR=TMIN*RMQ2
14503 MCRQQ=2
14504 ENDIF
14505C... Select largest PT2 (brems or creation):
14506 IF (PT2CR.GT.PT2) THEN
14507 MCRQQ=MAX(MCRQQ,1)
14508 WTSUM=0D0
14509 PT2=PT2CR
14510 KFLA=21
14511 ELSE
14512 MCRQQ=0
14513 KFLA=KFLB
14514 ENDIF
14515C... Compute logarithms for this PT2
14516 TPL=LOG((PT2+VINT(18))/ALAM2)
14517 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14518 WTCRQQ=TPM/LOG(PT2/RMQ2)
14519 ENDIF
14520
14521C...Evolve joining separately
14522 MJOIN=0
14523 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14524 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14525 & -VINT(18)
14526 IF (PT2JN.GE.PT2) THEN
14527 MJOIN=1
14528 PT2=PT2JN
14529 ENDIF
14530 ENDIF
14531
14532C...Loopback if crossed c/b mass thresholds.
14533 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14534 PT2=RMB2
14535 GOTO 130
14536 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14537 PT2=RMC2
14538 GOTO 130
14539 ENDIF
14540
14541C...Speed up shower. Skip if higher-PT acceptable branching
14542C...already found somewhere else.
14543C...Also finish if below lower cutoff.
14544
14545 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14546
14547C...Select parton A flavour (massive Q handled above.)
14548 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14549 WTRAN=PYR(0)*WTSUM
14550 KFLA=-6
14551 240 KFLA=KFLA+1
14552 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14553 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14554 IF(KFLA.EQ.6) KFLA=21
14555 ELSEIF (MJOIN.EQ.1) THEN
14556C...Tentative joining accept/reject.
14557 WTRAN=PYR(0)*WTJOIN
14558 MJ=0
14559 250 MJ=MJ+1
14560 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14561 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14562 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14563 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14564 & ' Rejected.')
14565 GOTO 230
14566 ENDIF
14567C...x*pdf (+ sea/val) at new pT2 for parton B.
14568 IF (KSVCB.LE.0) THEN
14569 MINT(30)=JS
14570 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14571 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14572 ELSE
14573C...Companion distributions do not evolve.
14574 XFB(KFLB)=XFBO
14575 ENDIF
14576 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14577 KFLC=K(IMI(JS,MJ,1),2)
14578 KFLCA=IABS(KFLC)
14579 KSVCC=MAX(-1,IMI(JS,MJ,2))
14580 IF (KSVCB.GE.1) KSVCC=-1
14581C...x*pdf (+ sea/val) at new pT2 for parton C.
14582 MINT(30)=JS
14583 MINT(36)=MJ
14584 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14585 MINT(36)=MI
14586 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14587 WTVETO=WTVETO/XFJ(KFLC)
14588C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14589 KFLA=21
14590 KSVCA=0
14591 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14592 KFLA=KFLB
14593 KSVCA=KSVCB
14594 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14595 KFLA=KFLC
14596 KSVCA=KSVCC
14597 ENDIF
14598 IF (KSVCA.LE.0) THEN
14599 MINT(30)=JS
14600 IF (KFLB.EQ.21) MINT(36)=MJ
14601 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14602 MINT(36)=MI
14603 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14604 ELSE
14605 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14606 ENDIF
14607 WTVETO=WTVETO*XFJ(KFLA)
14608C...Monte Carlo veto.
14609 IF (WTVETO.LT.PYR(0)) GOTO 200
14610C...If accept, save PT2 of this joining.
14611 IF (PT2.GT.PT2MX) THEN
14612 PT2MX=PT2
14613 JSMX=2+JS
14614 MJN1MX=MJ
14615 MJN2MX=MI
14616 WTAPJ(MJ)=0D0
14617 NJN=0
14618 ENDIF
14619C...Exit and continue evolution.
14620 GOTO 380
14621 ENDIF
14622 KFLAA=IABS(KFLA)
14623
14624C...Choose z value (still in overestimated range) and corrective weight.
14625C...Unphysical z will be rejected below when Q2 has is computed.
14626 WTZ=0D0
14627
14628C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14629C...q -> q + g or q -> q + gamma (already set which).
14630 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14631 IF (KSVCB.LT.0) THEN
14632 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14633 ELSE
14634 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14635 Z=((1-ZFAC)/(1+ZFAC))**2
14636 ENDIF
14637 WTZ=0.5D0*(1D0+Z**2)
14638C...Massive weight correction.
14639 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14640C...Valence quark weight correction (extra sqrt)
14641 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14642
14643C...q -> g + q.
14644C...NB: MQ>0 not yet implemented. Forced absent above.
14645 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14646 KFLC=KFLA
14647 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14648 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14649
14650C...g -> q + qbar.
14651 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14652 KFLC=-KFLB
14653 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14654 WTZ=Z**2+(1D0-Z)**2
14655C...Massive correction
14656 IF (MQMASS.NE.0) THEN
14657 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14658C...Extra safety margin for light sea quark creation
14659 ELSEIF (KSVCB.LT.0) THEN
14660 WTZ=WTZ/1.25D0
14661 ENDIF
14662
14663C...g -> g + g.
14664 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14665 KFLC=21
14666 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14667 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14668 WTZ=(1D0-Z*(1D0-Z))**2
14669 ENDIF
14670
14671C...Derive Q2 from pT2.
14672 Q2B=PT2/(1D0-Z)
14673 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14674
14675C...Loopback if outside allowed z range for given pT2.
14676 RM2C=PYMASS(KFLC)**2
14677 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14678 IF (PT2ADJ.LT.1D-6) GOTO 230
14679
14680C...Loopback if nonordered in angle/rapidity.
14681 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14682 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14683 & GOTO 230
14684 ENDIF
14685
14686C...Select phi angle of branching at random.
14687 PHI=PARU(2)*PYR(0)
14688
14689C...Matrix-element corrections for some processes.
14690 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14691 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14692 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14693 WTZ=WTZ*WTME/WTFF
14694 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14695 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14696 WTZ=WTZ*WTME/WTGF
14697 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14698 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14699 WTZ=WTZ*WTME/WTFG
14700 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14701 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14702 WTZ=WTZ*WTME/WTGG
14703 ENDIF
14704 ENDIF
14705
14706C...Parton distributions at new pT2 but old x.
14707 MINT(30)=JS
14708 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14709C...Treat val and cmp separately
14710 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14711 IF (KSVCB.GE.1)
14712 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14713 XFBN=XFN(KFLB)
14714 IF(XFBN.LT.1D-20) THEN
14715 IF(KFLA.EQ.KFLB) THEN
14716 WTAP(KFLB)=0D0
14717 GOTO 200
14718 ELSE
14719 XFBN=1D-10
14720 XFN(KFLB)=XFBN
14721 ENDIF
14722 ENDIF
14723 DO 260 KFL=-5,5
14724 XFB(KFL)=XFN(KFL)
14725 260 CONTINUE
14726 XFB(21)=XFN(21)
14727
14728C...Parton distributions at new pT2 and new x.
14729 XA=XB/Z
14730 MINT(30)=JS
14731 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14732 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14733C...q -> q + g: only consider respective sea, val, or cmp content.
14734 IF (KSVCB.LE.0) THEN
14735 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14736 ELSE
14737 YA=XA*(1D0-YS)
14738 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14739 ENDIF
14740 ENDIF
14741 XFAN=XFA(KFLA)
14742 IF(XFAN.LT.1D-20) THEN
14743 GOTO 200
14744 ENDIF
14745
14746C...If weighting fails continue evolution.
14747 WTTOT=0D0
14748 IF (MCRQQ.EQ.0) THEN
14749 WTPDFA=1D0/WTPDF(KFLA)
14750 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14751 ELSEIF(MCRQQ.EQ.1) THEN
14752 WTPDFA=TPM/WPDF0
14753 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14754 XBEST=TPM/TPM0*XQ0
14755 ELSEIF(MCRQQ.EQ.2) THEN
14756C...Force massive quark creation.
14757 WTTOT=1D0
14758 ENDIF
14759
14760C...Loop back if trial emission fails.
14761 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14762 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14763 IF(WTTOT.LT.0D0) THEN
14764 WRITE(CHWT,'(1P,E12.4)') WTTOT
14765 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14766 ELSEIF(WTTOT.GT.WTACC) THEN
14767 WRITE(CHWT,'(1P,E12.4)') WTTOT
14768 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14769C...Too high weight: write out as error, but do not update error counter.
14770 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14771 CALL PYERRM(19,
14772 & '(PYPTIS:) Weight '//CHWT//' above unity')
14773 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14774 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14775 ELSE
14776 CALL PYERRM(9,
14777 & '(PYPTIS:) Weight '//CHWT//' above unity')
14778 ENDIF
14779C...Useful for debugging but commented out for distribution:
14780C print*, 'JS, MI',JS, MI
14781C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14782C print*, 'A -> B C',KFLA, KFLB, KFLC
14783C XFAO=XFBO/WTPDFA
14784C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14785 ENDIF
14786
14787C...Save acceptable branching.
14788 IF(PT2.GT.PT2MX) THEN
14789 MIMX=MINT(36)
14790 JSMX=JS
14791 PT2MX=PT2
14792 KFLAMX=KFLA
14793 KFLCMX=KFLC
14794 RM2CMX=RM2C
14795 Q2BMX=Q2B
14796 ZMX=Z
14797 PT2AMX=PT2ADJ
14798 PHIMX=PHI
14799 ENDIF
14800
14801C----------------------------------------------------------------------
14802C...MODE= 1: Accept stored shower branching. Update event record etc.
14803 ELSEIF (MODE.EQ.1) THEN
14804 MI=MIMX
14805 JS=JSMX
14806 SHAT=SHTNOW(MI)
14807 SIDE=3D0-2D0*JS
14808C...Shift down rest of event record to make room for insertion.
14809 IT=IMISEP(MI)+1
14810 IM=IT+1
14811 IS=IMI(JS,MI,1)
14812 DO 280 I=N,IT,-1
14813 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14814 KT1=K(I,4)/MSTU(5)**2
14815 KT2=K(I,5)/MSTU(5)**2
14816 ID1=MOD(K(I,4),MSTU(5))
14817 ID2=MOD(K(I,5),MSTU(5))
14818 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14819 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14820 IF (ID1.GE.IT) ID1=ID1+2
14821 IF (ID2.GE.IT) ID2=ID2+2
14822 IF (IM1.GE.IT) IM1=IM1+2
14823 IF (IM2.GE.IT) IM2=IM2+2
14824 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14825 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14826 DO 270 IX=1,5
14827 K(I+2,IX)=K(I,IX)
14828 P(I+2,IX)=P(I,IX)
14829 V(I+2,IX)=V(I,IX)
14830 270 CONTINUE
14831 MCT(I+2,1)=MCT(I,1)
14832 MCT(I+2,2)=MCT(I,2)
14833 280 CONTINUE
14834 N=N+2
14835C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14836 DO 290 JI=1,MINT(31)
14837 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14838 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14839 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14840 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14841 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14842C...Also update companion pointers to the present mother.
14843 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14844 290 CONTINUE
14845 DO 300 IFS=1,NPART
14846 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14847 300 CONTINUE
14848C...Zero entries dedicated for new timelike and mother partons.
14849 DO 320 I=IT,IT+1
14850 DO 310 J=1,5
14851 K(I,J)=0
14852 P(I,J)=0D0
14853 V(I,J)=0D0
14854 310 CONTINUE
14855 MCT(I,1)=0
14856 MCT(I,2)=0
14857 320 CONTINUE
14858
14859C...Define timelike and new mother partons. History.
14860 K(IT,1)=3
14861 K(IT,2)=KFLCMX
14862 K(IM,1)=14
14863 K(IM,2)=KFLAMX
14864 K(IS,3)=IM
14865 K(IT,3)=IM
14866C...Set mother origin = side.
14867 K(IM,3)=MINT(83)+JS+2
14868 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14869
14870C...Define colour flow of branching.
14871 IM1=IM
14872 IM2=IM
14873C...q -> q + gamma.
14874 IF(K(IT,2).EQ.22) THEN
14875 K(IT,1)=1
14876 ID1=IS
14877 ID2=IS
14878C...q -> q + g.
14879 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14880 ID1=IT
14881 ID2=IS
14882C...q -> g + q.
14883 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14884 ID1=IS
14885 ID2=IT
14886C...qbar -> qbar + g.
14887 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14888 ID1=IS
14889 ID2=IT
14890C...qbar -> g + qbar.
14891 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14892 ID1=IT
14893 ID2=IS
14894C...g -> g + g; g -> q + qbar..
14895 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14896 ID1=IS
14897 ID2=IT
14898 ELSE
14899 ID1=IT
14900 ID2=IS
14901 ENDIF
14902 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14903 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14904 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14905 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14906 IF(ID1.NE.ID2) THEN
14907 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14908 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14909 ENDIF
14910 IF(K(IT,1).EQ.1) THEN
14911 K(IT,4)=0
14912 K(IT,5)=0
14913 ENDIF
14914C...Update IMI and colour tag arrays.
14915 IMI(JS,MI,1)=IM
14916 DO 330 MC=1,2
14917 MCT(IT,MC)=0
14918 MCT(IM,MC)=0
14919 330 CONTINUE
14920 DO 340 JCS=4,5
14921 KCS=JCS
14922C...If mother flag not yet set for spacelike parton, trace it.
14923 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14924 IF(MINT(51).NE.0) RETURN
14925 340 CONTINUE
14926 DO 350 JCS=4,5
14927 KCS=JCS
14928C...If mother flag not yet set for timelike parton, trace it.
14929 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14930 IF(MINT(51).NE.0) RETURN
14931 350 CONTINUE
14932
14933C...Boost recoiling parton to compensate for Q2 scale.
14934 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14935 & (1D0+(1D0+Q2BMX/SHAT)**2)
14936 IR=IMI(3-JS,MI,1)
14937 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14938
14939C...Define system to be rotated and boosted
14940C...(not including the 2 just added partons)
14941C...(but including the docu lines for first interaction)
14942 IMIN=IMISEP(MI-1)+1
14943 IF (MI.EQ.1) IMIN=MINT(83)+5
14944 IMAX=IMISEP(MI)-2
14945
14946C...Rotate back system in phi to compensate for subsequent rotation.
14947 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14948
14949C...Define kinematics of new partons in old frame.
14950 IMAX=IMISEP(MI)
14951 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14952 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14953 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14954 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14955 P(IT,1)=P(IM,1)
14956 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14957 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14958 P(IT,5)=SQRT(RM2CMX)
14959
14960C...Update internal line, now spacelike
14961 P(IS,1)=P(IM,1)-P(IT,1)
14962 P(IS,2)=P(IM,2)-P(IT,2)
14963 P(IS,3)=P(IM,3)-P(IT,3)
14964 P(IS,4)=P(IM,4)-P(IT,4)
14965 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
14966C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
14967 IF (P(IS,5).LT.0D0) THEN
14968 P(IS,5)=-SQRT(ABS(P(IS,5)))
14969 ELSE
14970 P(IS,5)=SQRT(P(IS,5))
14971 ENDIF
14972
14973C...Boost entire system and rotate to new frame.
14974C...(including docu lines)
14975 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14976 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14977 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14978 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14979 MINT(51)=1
14980 IFAIL=-1
14981 RETURN
14982 ENDIF
14983 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14984 I1=IMI(1,MI,1)
14985 THETA=PYANGL(P(I1,3),P(I1,1))
14986 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14987
14988C...Global statistics.
14989 MINT(352)=MINT(352)+1
14990 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14991 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14992
14993C...Add parton with relevant pT scale for timelike shower.
14994 IF (K(IT,2).NE.22) THEN
14995 NPART=NPART+1
14996 IPART(NPART)=IT
14997 PTPART(NPART)=SQRT(PT2AMX)
14998 ENDIF
14999
15000C...Update saved variables.
15001 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15002 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15003 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15004 PT2SAV(JSMX,MIMX)=PT2MX
15005 ZSAV(JS,MIMX)=ZMX
15006
15007 KSA=IABS(K(IS,2))
15008 KMA=IABS(K(IM,2))
15009 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15010C...Gluon reconstructs to quark.
15011C...Decide whether newly created quark is valence or sea:
15012 MINT(30)=JS
15013 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15014 IF(MINT(51).NE.0) RETURN
15015 ENDIF
15016 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15017C...Quark reconstructs to gluon.
15018C...Now some guy may have lost his companion. Check.
15019 ICMP=IMI(JS,MI,2)
15020 IF (ICMP.GT.0) THEN
15021 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15022 & //' away. Cannot handle that yet. Giving up.')
15023 MINT(51)=1
15024 RETURN
15025 ELSEIF(ICMP.LT.0) THEN
15026C...A sea quark with companion still in BR was reconstructed to a gluon.
15027C...Companion should now be removed from the beam remnant.
15028C...(Momentum integral is automatically updated in next call to PYPDFU.)
15029 ICMP=-ICMP
15030 IFL=-K(IS,2)
15031 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
15032 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15033 DO 360 JI=1,MINT(31)
15034 KMI=-IMI(JS,JI,2)
15035 JFL=-K(IMI(JS,JI,1),2)
15036 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15037 & ,2)+1
15038 360 CONTINUE
15039 370 CONTINUE
15040 NVC(JS,IFL)=NVC(JS,IFL)-1
15041 ENDIF
15042C...Set gluon IMI(JS,MI,2) = 0.
15043 IMI(JS,MI,2)=0
15044 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15045C...Quark reconstructing to quark. If sea with companion still in BR
15046C...then update associated x value.
15047C...(Momentum integral is automatically updated in next call to PYPDFU.)
15048 IF (IMI(JS,MI,2).LT.0) THEN
15049 ICMP=-IMI(JS,MI,2)
15050 IFL=-K(IS,2)
15051 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15052 ENDIF
15053 ENDIF
15054
15055 ENDIF
15056
15057C...If reached this point, normal exit.
15058 380 IFAIL=0
15059
15060 RETURN
15061 END
15062
15063C*********************************************************************
15064
15065C...PYMEMX
15066C...Generates maximum ME weight in some initial-state showers.
15067C...Inparameter MECOR: kind of hard scattering process
15068C...Outparameter WTFF: maximum weight for fermion -> fermion
15069C... WTGF: maximum weight for gluon/photon -> fermion
15070C... WTFG: maximum weight for fermion -> gluon/photon
15071C... WTGG: maximum weight for gluon -> gluon
15072
15073 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15074
15075C...Double precision and integer declarations.
15076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15077 IMPLICIT INTEGER(I-N)
15078 INTEGER PYK,PYCHGE,PYCOMP
15079C...Commonblocks.
15080 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15081 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15082 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15083 COMMON/PYINT1/MINT(400),VINT(400)
15084 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15085 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15086
15087C...Default maximum weight.
15088 WTFF=1D0
15089 WTGF=1D0
15090 WTFG=1D0
15091 WTGG=1D0
15092
15093C...Select maximum weight by process.
15094 IF(MECOR.EQ.1) THEN
15095 WTFF=1D0
15096 WTGF=3D0
15097 ELSEIF(MECOR.EQ.2) THEN
15098 WTFG=1D0
15099 WTGG=1D0
15100 ENDIF
15101
15102 RETURN
15103 END
15104
15105C*********************************************************************
15106
15107C...PYMEWT
15108C...Calculates actual ME weight in some initial-state showers.
15109C...Inparameter MECOR: kind of hard scattering process
15110C... IFLCB: flavour combination of branching,
15111C... 1 for fermion -> fermion,
15112C... 2 for gluon/photon -> fermion
15113C... 3 for fermion -> gluon/photon,
15114C... 4 for gluon -> gluon
15115C... Q2: Q2 value of shower branching
15116C... Z: Z value of branching
15117C...In+outparameter PHIBR: azimuthal angle of branching
15118C...Outparameter WTME: actual ME weight
15119
15120 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15121
15122C...Double precision and integer declarations.
15123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15124 IMPLICIT INTEGER(I-N)
15125 INTEGER PYK,PYCHGE,PYCOMP
15126C...Commonblocks.
15127 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15128 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15129 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15130 COMMON/PYINT1/MINT(400),VINT(400)
15131 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15132 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15133
15134C...Default output.
15135 WTME=1D0
15136
15137C...Define kinematics of shower branching in Mandelstam variables.
15138 SQM=VINT(44)
15139 SH=SQM/Z
15140 TH=-Q2
15141 UH=Q2-SQM*(1D0-Z)/Z
15142
15143C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15144 IF(MECOR.EQ.1) THEN
15145 IF(IFLCB.EQ.1) THEN
15146 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15147 ELSEIF(IFLCB.EQ.2) THEN
15148 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15149 ENDIF
15150
15151C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15152 ELSEIF(MECOR.EQ.2) THEN
15153 IF(IFLCB.EQ.3) THEN
15154 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15155 ELSEIF(IFLCB.EQ.4) THEN
15156 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15157 ENDIF
15158
15159C...Matrix-element corrections for q + qbar -> Higgs (h0)
15160 ELSEIF(MECOR.EQ.3) THEN
15161 IF(IFLCB.EQ.2) THEN
15162 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15163 1 (SH**2+2D0*SQM*(SQM-SH))
15164 ENDIF
15165 ENDIF
15166
15167 RETURN
15168 END
15169
15170C*********************************************************************
15171
15172C...PYPTMI
15173C...Handles the generation of additional interactions in the new
15174C...multiple interactions framework.
15175C...MODE=-1 : Initalize MI from scratch.
15176C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15177C... Sudakov for PT2, abort if below PT2CUT.
15178C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15179C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15180C...PT2NOW : Starting (max) PT2 scale for evolution.
15181C...PT2CUT : Lower limit for evolution.
15182C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15183C...IFAIL : Status return code.
15184C... = 0: All is well.
15185C... < 0: Phase space exhausted, generation to be terminated.
15186C... > 0: Additional interaction vetoed, but continue evolution.
15187
15188 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15189C...Double precision and integer declarations.
15190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15191 IMPLICIT INTEGER(I-N)
15192 INTEGER PYK,PYCHGE,PYCOMP
15193C...Parameter statement for maximum size of showers.
15194 PARAMETER (MAXNUR=1000)
15195C...Commonblocks.
15196 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15197 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15199 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15200 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15201 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15202 COMMON/PYINT1/MINT(400),VINT(400)
15203 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15204 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15205 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15206 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15207 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15208 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15209 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15210 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15211 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15212 COMMON/PYCTAG/NCT,MCT(4000,2)
15213C...Local arrays and saved variables.
15214 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15215
15216 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15217 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15218 & /PYISMX/,/PYCTAG/
15219 SAVE XT2FAC,SIGS
15220
15221 IFAIL=0
15222C...Set MI subprocess = QCD 2 -> 2.
15223 ISUB=96
15224
15225C----------------------------------------------------------------------
15226C...MODE=-1: Initialize from scratch
15227 IF (MODE.EQ.-1) THEN
15228C...Initialize PT2 array.
15229 PT2MI(1)=VINT(54)
15230C...Initialize list of incoming beams and partons from two sides.
15231 DO 110 JS=1,2
15232 DO 100 MI=1,240
15233 IMI(JS,MI,1)=0
15234 IMI(JS,MI,2)=0
15235 100 CONTINUE
15236 NMI(JS)=1
15237 IMI(JS,1,1)=MINT(84)+JS
15238 IMI(JS,1,2)=0
15239 XMI(JS,1)=VINT(40+JS)
15240C...Rescale x values to fractions of photon energy.
15241 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15242C...Hard reset: hard interaction initiators motherless by definition.
15243 K(MINT(84)+JS,3)=2+JS
15244 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15245 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15246 110 CONTINUE
15247 IMISEP(0)=MINT(84)
15248 IMISEP(1)=N
15249 IF (MOD(MSTP(81),10).GE.1) THEN
15250 IF(MSTP(82).LE.1) THEN
15251 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15252 & ,5))
15253 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15254 & VINT(317)/(VINT(318)*VINT(320))
15255 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15256 ELSE
15257 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15258 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15259 ENDIF
15260 ENDIF
15261C...Zero entries relating to scatterings beyond the first.
15262 DO 120 MI=2,240
15263 IMI(1,MI,1)=0
15264 IMI(2,MI,1)=0
15265 IMI(1,MI,2)=0
15266 IMI(2,MI,2)=0
15267 IMISEP(MI)=IMISEP(1)
15268 PT2MI(MI)=0D0
15269 XMI(1,MI)=0D0
15270 XMI(2,MI)=0D0
15271 120 CONTINUE
15272C...Initialize factors for PDF reshaping.
15273 DO 140 JS=1,2
15274 KFBEAM(JS)=MINT(10+JS)
15275 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15276 KFABM=IABS(KFBEAM(JS))
15277 KFSBM=ISIGN(1,KFBEAM(JS))
15278
15279C...Zero flavour content of incoming beam particle.
15280 KFIVAL(JS,1)=0
15281 KFIVAL(JS,2)=0
15282 KFIVAL(JS,3)=0
15283C... Flavour content of baryon.
15284 IF(KFABM.GT.1000) THEN
15285 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15286 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15287 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15288C... Flavour content of pi+-, K+-.
15289 ELSEIF(KFABM.EQ.211) THEN
15290 KFIVAL(JS,1)=KFSBM*2
15291 KFIVAL(JS,2)=-KFSBM
15292 ELSEIF(KFABM.EQ.321) THEN
15293 KFIVAL(JS,1)=-KFSBM*3
15294 KFIVAL(JS,2)=KFSBM*2
15295C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15296 ENDIF
15297
15298C...Zero initial valence and companion content.
15299 DO 130 IFL=-6,6
15300 NVC(JS,IFL)=0
15301 130 CONTINUE
15302 140 CONTINUE
15303C...Set up colour line tags starting from hard interaction initiators.
15304 NCT=0
15305C...Reset colour tag array and colour processing flags.
15306 DO 150 I=IMISEP(0)+1,N
15307 MCT(I,1)=0
15308 MCT(I,2)=0
15309 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15310 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15311 150 CONTINUE
15312C... Consider each side in turn.
15313 DO 170 JS=1,2
15314 I1=IMI(JS,1,1)
15315 I2=IMI(3-JS,1,1)
15316 DO 160 JCS=4,5
15317 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15318 & GOTO 160
15319 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15320 KCS=JCS
15321 CALL PYCTTR(I1,KCS,I2)
15322 IF(MINT(51).NE.0) RETURN
15323 160 CONTINUE
15324 170 CONTINUE
15325
15326C...Range checking for companion quark pdf large-x param.
15327 IF (MSTP(87).LT.0) THEN
15328 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15329 & ' MSTP(87)=0')
15330 MSTP(87)=0
15331 ELSEIF (MSTP(87).GT.4) THEN
15332 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15333 & ' MSTP(87)=4')
15334 MSTP(87)=4
15335 ENDIF
15336
15337C----------------------------------------------------------------------
15338C...MODE=0: Generate trial interaction. Return codes:
15339C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15340C...IFAIL = 0: Additional interaction generated at PT2.
15341C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15342 ELSEIF (MODE.EQ.0) THEN
15343C...Abolute MI max scale = VINT(62)
15344 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15345 180 IF(MSTP(82).LE.1) THEN
15346 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15347 IF(XT2.LT.VINT(149)) IFAIL=-2
15348 ELSE
15349 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15350 IFAIL=-3
15351 ELSE
15352 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15353 & LOG(PYR(0)))-VINT(149)
15354 ENDIF
15355 ENDIF
15356C...Also exit if below lower limit or if higher trial branching
15357C...already found.
15358 PT2=0.25D0*VINT(2)*XT2
15359 IF (PT2.LE.PT2CUT) IFAIL=-4
15360 IF (PT2.LE.PT2MX) IFAIL=-5
15361 IF (IFAIL.NE.0) THEN
15362 PT2=0D0
15363 RETURN
15364 ENDIF
15365 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15366 VINT(25)=4D0*PT2/VINT(2)
15367 XT2=VINT(25)
15368
15369C...Choose tau and y*. Calculate cos(theta-hat).
15370 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15371 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15372 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15373 ELSE
15374 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15375 ENDIF
15376 VINT(21)=TAU
15377C...New: require shat > 1.
15378 IF(TAU*VINT(2).LT.1D0) GOTO 180
15379 CALL PYKLIM(2)
15380 RYST=PYR(0)
15381 MYST=1
15382 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15383 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15384 CALL PYKMAP(2,MYST,PYR(0))
15385 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15386
15387C...Check that x not used up. Accept or reject kinematical variables.
15388 X1M=SQRT(TAU)*EXP(VINT(22))
15389 X2M=SQRT(TAU)*EXP(-VINT(22))
15390 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15391 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15392 CALL PYSIGH(NCHN,SIGS)
15393 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15394 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15395 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
15396
15397C...Save if highest PT so far.
15398 IF (PT2.GT.PT2MX) THEN
15399 JSMX=0
15400 MIMX=MINT(31)+1
15401 PT2MX=PT2
15402 ENDIF
15403
15404C----------------------------------------------------------------------
15405C...MODE=1: Generate and save accepted scattering.
15406 ELSEIF (MODE.EQ.1) THEN
15407 PT2=PT2NOW
15408C...Reset K, P, V, and MCT vectors.
15409 DO 200 I=N+1,N+4
15410 DO 190 J=1,5
15411 K(I,J)=0
15412 P(I,J)=0D0
15413 V(I,J)=0D0
15414 190 CONTINUE
15415 MCT(I,1)=0
15416 MCT(I,2)=0
15417 200 CONTINUE
15418
15419 NTRY=0
15420C...Choose flavour of reacting partons (and subprocess).
15421 210 NTRY=NTRY+1
15422 IF (NTRY.GT.50) THEN
15423 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15424 & //'interaction. Giving up!')
15425 MINT(51)=1
15426 RETURN
15427 ENDIF
15428 RSIGS=SIGS*PYR(0)
15429 DO 220 ICHN=1,NCHN
15430 KFL1=ISIG(ICHN,1)
15431 KFL2=ISIG(ICHN,2)
15432 ICONMI=ISIG(ICHN,3)
15433 RSIGS=RSIGS-SIGH(ICHN)
15434 IF(RSIGS.LE.0D0) GOTO 230
15435 220 CONTINUE
15436
15437C...Reassign to appropriate process codes.
15438 230 ISUBMI=ICONMI/10
15439 ICONMI=MOD(ICONMI,10)
15440
15441C...Choose new quark flavour for annihilation graphs
15442 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15443 SH=VINT(21)*VINT(2)
15444 CALL PYWIDT(21,SH,WDTP,WDTE)
15445 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15446 DO 250 I=1,MDCY(21,3)
15447 KFLF=KFDP(I+MDCY(21,2)-1,1)
15448 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15449 IF(RKFL.LE.0D0) GOTO 260
15450 250 CONTINUE
15451 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15452 IF(KFLF.GE.4) GOTO 240
15453 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15454 KFLF=4
15455 ICONMI=ICONMI-2
15456 ELSEIF(ISUBMI.EQ.53) THEN
15457 KFLF=5
15458 ICONMI=ICONMI-4
15459 ENDIF
15460 ENDIF
15461
15462C...Final state flavours and colour flow: default values
15463 JS=1
15464 KFL3=KFL1
15465 KFL4=KFL2
15466 KCC=20
15467 KCS=ISIGN(1,KFL1)
15468
15469 IF(ISUBMI.EQ.11) THEN
15470C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15471 KCC=ICONMI
15472 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15473
15474 ELSEIF(ISUBMI.EQ.12) THEN
15475C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15476 KFL3=ISIGN(KFLF,KFL1)
15477 KFL4=-KFL3
15478 KCC=4
15479
15480 ELSEIF(ISUBMI.EQ.13) THEN
15481C...f + fbar -> g + g; th arbitrary
15482 KFL3=21
15483 KFL4=21
15484 KCC=ICONMI+4
15485
15486 ELSEIF(ISUBMI.EQ.28) THEN
15487C...f + g -> f + g; th = (p(f)-p(f))**2
15488 IF(KFL1.EQ.21) JS=2
15489 KCC=ICONMI+6
15490 IF(KFL1.EQ.21) KCC=KCC+2
15491 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15492 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15493
15494 ELSEIF(ISUBMI.EQ.53) THEN
15495C...g + g -> f + fbar; th arbitrary
15496 KCS=(-1)**INT(1.5D0+PYR(0))
15497 KFL3=ISIGN(KFLF,KCS)
15498 KFL4=-KFL3
15499 KCC=ICONMI+10
15500
15501 ELSEIF(ISUBMI.EQ.68) THEN
15502C...g + g -> g + g; th arbitrary
15503 KCC=ICONMI+12
15504 KCS=(-1)**INT(1.5D0+PYR(0))
15505 ENDIF
15506
15507C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15508 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15509 & .OR.IABS(KFL4).EQ.5) THEN
15510 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15511 IF (PT2.LE.1.05*RMMAX2) THEN
15512 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15513 & //' created below threshold. Rejected.')
15514 GOTO 210
15515 ENDIF
15516 ENDIF
15517
15518C...Store flavours of scattering.
15519 MINT(13)=KFL1
15520 MINT(14)=KFL2
15521 MINT(15)=KFL1
15522 MINT(16)=KFL2
15523 MINT(21)=KFL3
15524 MINT(22)=KFL4
15525
15526C...Set flavours and mothers of scattering partons.
15527 K(N+1,1)=14
15528 K(N+2,1)=14
15529 K(N+3,1)=3
15530 K(N+4,1)=3
15531 K(N+1,2)=KFL1
15532 K(N+2,2)=KFL2
15533 K(N+3,2)=KFL3
15534 K(N+4,2)=KFL4
15535 K(N+1,3)=MINT(83)+1
15536 K(N+2,3)=MINT(83)+2
15537 K(N+3,3)=N+1
15538 K(N+4,3)=N+2
15539
15540C...Store colour connection indices.
15541 DO 270 J=1,2
15542 JC=J
15543 IF(KCS.EQ.-1) JC=3-J
15544 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15545 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15546 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15547 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15548 270 CONTINUE
15549
15550C...Store incoming and outgoing partons in their CM-frame.
15551 SHR=SQRT(VINT(21))*VINT(1)
15552 P(N+1,3)=0.5D0*SHR
15553 P(N+1,4)=0.5D0*SHR
15554 P(N+2,3)=-0.5D0*SHR
15555 P(N+2,4)=0.5D0*SHR
15556 P(N+3,5)=PYMASS(K(N+3,2))
15557 P(N+4,5)=PYMASS(K(N+4,2))
15558 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15559 IFAIL=1
15560 RETURN
15561 ENDIF
15562 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15563 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15564 P(N+4,4)=SHR-P(N+3,4)
15565 P(N+4,3)=-P(N+3,3)
15566
15567C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15568 PHI=PARU(2)*PYR(0)
15569 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15570
15571C...Global statistics.
15572 MINT(351)=MINT(351)+1
15573 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15574 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15575
15576C...Keep track of loose colour ends and information on scattering.
15577 MINT(31)=MINT(31)+1
15578 MINT(36)=MINT(31)
15579 PT2MI(MINT(36))=PT2
15580 IMISEP(MINT(31))=N+4
15581 DO 280 JS=1,2
15582 IMI(JS,MINT(31),1)=N+JS
15583 IMI(JS,MINT(31),2)=0
15584 XMI(JS,MINT(31))=VINT(40+JS)
15585 NMI(JS)=NMI(JS)+1
15586C...Update cumulative counters
15587 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15588 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15589 280 CONTINUE
15590
15591C...Add to list of final state partons
15592 IPART(NPART+1)=N+3
15593 IPART(NPART+2)=N+4
15594 PTPART(NPART+1)=SQRT(PT2)
15595 PTPART(NPART+2)=SQRT(PT2)
15596 NPART=NPART+2
15597
15598C...Initialize ISR
15599 NISGEN(1,MINT(31))=0
15600 NISGEN(2,MINT(31))=0
15601
15602C...Update ER
15603 N=N+4
15604 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15605 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15606 MINT(51)=1
15607 RETURN
15608 ENDIF
15609
15610C...Finally, assign colour tags to new partons
15611 DO 300 JS=1,2
15612 I1=IMI(JS,MINT(31),1)
15613 I2=IMI(3-JS,MINT(31),1)
15614 DO 290 JCS=4,5
15615 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15616 & GOTO 290
15617 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15618 KCS=JCS
15619 CALL PYCTTR(I1,KCS,I2)
15620 IF(MINT(51).NE.0) RETURN
15621 290 CONTINUE
15622 300 CONTINUE
15623
15624C----------------------------------------------------------------------
15625C...MODE=2: Decide whether quarks in last scattering were valence,
15626C...companion, or sea.
15627 ELSEIF (MODE.EQ.2) THEN
15628 JS=MINT(30)
15629 MI=MINT(36)
15630 PT2=PT2NOW
15631 KFSBM=ISIGN(1,MINT(10+JS))
15632 IFL=K(IMI(JS,MI,1),2)
15633 IMI(JS,MI,2)=0
15634 IF (IABS(IFL).GE.6) THEN
15635 IF (IABS(IFL).EQ.6) THEN
15636 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15637 ENDIF
15638 RETURN
15639 ENDIF
15640C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15641C...(Do not include the parton itself in the X rescaling.)
15642 X=XMI(JS,MI)
15643 XRSC=X/(VINT(142+JS)+X)
15644C...Note: XPSVC = x*pdf.
15645 MINT(30)=JS
15646 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15647 SEA=XPSVC(IFL,-1)
15648 VAL=XPSVC(IFL,0)
15649 CMP=0D0
15650 DO 310 IVC=1,NVC(JS,IFL)
15651 CMP=CMP+XPSVC(IFL,IVC)
15652 310 CONTINUE
15653
15654C...Decide (Extra factor x cancels in the dvision).
15655 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15656 IVNOW=1
15657 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15658C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15659 IVNOW=0
15660 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15661 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15662 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15663 IF(KFIVAL(JS,1).EQ.0) THEN
15664 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15665 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15666 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15667 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15668 ELSE
15669C...Count down valence remaining. Do not count current scattering.
15670 DO 340 I1=1,NMI(JS)
15671 IF (I1.EQ.MINT(36)) GOTO 340
15672 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15673 & IVNOW=IVNOW-1
15674 340 CONTINUE
15675 ENDIF
15676 IF(IVNOW.EQ.0) GOTO 330
15677C...Mark valence.
15678 IMI(JS,MI,2)=0
15679C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15680 IF(KFIVAL(JS,1).EQ.0) THEN
15681 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15682 KFIVAL(JS,1)=IFL
15683 KFIVAL(JS,2)=-IFL
15684 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15685 KFIVAL(JS,1)=IFL
15686 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15687 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15688 ENDIF
15689 ENDIF
15690
15691 ELSEIF (RVCS.LE.VAL+SEA) THEN
15692C...If sea, add opposite sign companion parton. Store X and I.
15693 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15694 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15695C...Set pointer to companion
15696 IMI(JS,MI,2)=-NVC(JS,-IFL)
15697
15698 ELSE
15699C...If companion, decide which one.
15700 IF (NVC(JS,IFL).EQ.0) THEN
15701 CMP=0D0
15702 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15703 GOTO 320
15704 ENDIF
15705 CMPSUM=VAL+SEA
15706 ISEL=0
15707 350 ISEL=ISEL+1
15708 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15709 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15710C...Find original sea (anti-)quark. Do not consider current scattering.
15711 IASSOC=0
15712 DO 360 I1=1,NMI(JS)
15713 IF (I1.EQ.MINT(36)) GOTO 360
15714 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15715 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15716 IMI(JS,MI,2)=IMI(JS,I1,1)
15717 IMI(JS,I1,2)=IMI(JS,MI,1)
15718 ENDIF
15719 360 CONTINUE
15720C...Mark companion "out-kicked".
15721 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15722 ENDIF
15723
15724 ENDIF
15725 RETURN
15726 END
15727
15728C*********************************************************************
15729
15730C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15731C...Giving the x*f pdf of a companion quark, with its partner at XS,
15732C...using an approximate gluon density like (1-X)^NPOW/X. The value
15733C...corresponds to an unrescaled range between 0 and 1-X.
15734
15735 FUNCTION PYFCMP(XC,XS,NPOW)
15736 IMPLICIT NONE
15737 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15738 INTEGER NPOW
15739
15740 PYFCMP=0D0
15741C...Parent gluon momentum fraction
15742 Y=XC+XS
15743 IF (Y.GE.1D0) RETURN
15744C...Common factor (includes factor XC, since PYFCMP=x*f)
15745 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15746C...Store normalized companion x*f distribution.
15747 IF (NPOW.LE.0) THEN
15748 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15749 ELSEIF (NPOW.EQ.1) THEN
15750 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15751 ELSEIF (NPOW.EQ.2) THEN
15752 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15753 & +3D0*XS*(1D0+XS)*LOG(XS)))
15754 ELSEIF (NPOW.EQ.3) THEN
15755 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15756 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15757 ELSEIF (NPOW.GE.4) THEN
15758 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15759 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15760 ENDIF
15761 RETURN
15762 END
15763
15764C*********************************************************************
15765
15766C...PYPCMP: Auxiliary to PYPDFU.
15767C...Giving the momentum integral of a companion quark, with its
15768C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15769C...The value corresponds to an unrescaled range between 0 and 1-XS.
15770
15771 FUNCTION PYPCMP(XS,NPOW)
15772 IMPLICIT NONE
15773 DOUBLE PRECISION XS, PYPCMP
15774 INTEGER NPOW
15775 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15776 PYPCMP=0D0
15777 ELSEIF (NPOW.LE.0) THEN
15778 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15779 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15780 ELSEIF (NPOW.EQ.1) THEN
15781 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15782 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15783 ELSEIF (NPOW.EQ.2) THEN
15784 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15785 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15786 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15787 & -3D0*XS*LOG(XS)*(1+XS)))
15788 ELSEIF (NPOW.EQ.3) THEN
15789 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15790 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15791 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15792 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15793 ELSE
15794 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15795 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15796 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15797 & -6D0*XS*LOG(XS)*(1D0+XS)))
15798 ENDIF
15799 RETURN
15800 END
15801
15802C*********************************************************************
15803
15804C...PYUPRE
15805C...Rearranges contents of the HEPEUP commonblock so that
15806C...mothers precede daughters and daughters of a decay are
15807C...listed consecutively.
15808
15809 SUBROUTINE PYUPRE
15810
15811C...Double precision and integer declarations.
15812 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15813 IMPLICIT INTEGER(I-N)
15814
15815C...User process event common block.
15816 INTEGER MAXNUP
15817 PARAMETER (MAXNUP=500)
15818 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15819 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15820 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15821 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15822 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15823 SAVE /HEPEUP/
15824
15825C...Local arrays.
15826 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15827 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15828 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15829
15830C...Check whether a rearrangement is required.
15831 NEED=0
15832 DO 100 IUP=1,NUP
15833 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15834 100 CONTINUE
15835 DO 110 IUP=2,NUP
15836 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15837 110 CONTINUE
15838
15839 IF(NEED.NE.0) THEN
15840C...Find the new order that particles should have.
15841 NEWPOS(0)=0
15842 NNEW=0
15843 INEW=-1
15844 120 INEW=INEW+1
15845 DO 130 IUP=1,NUP
15846 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15847 NNEW=NNEW+1
15848 NEWPOS(NNEW)=IUP
15849 ENDIF
15850 130 CONTINUE
15851 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15852 IF(NNEW.NE.NUP) THEN
15853 CALL PYERRM(2,
15854 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15855 RETURN
15856 ENDIF
15857
15858C...Copy old info into temporary storage.
15859 DO 150 I=1,NUP
15860 IDUPT(I)=IDUP(I)
15861 ISTUPT(I)=ISTUP(I)
15862 MOTUPT(1,I)=MOTHUP(1,I)
15863 MOTUPT(2,I)=MOTHUP(2,I)
15864 ICOUPT(1,I)=ICOLUP(1,I)
15865 ICOUPT(2,I)=ICOLUP(2,I)
15866 DO 140 J=1,5
15867 PUPT(J,I)=PUP(J,I)
15868 140 CONTINUE
15869 VTIUPT(I)=VTIMUP(I)
15870 SPIUPT(I)=SPINUP(I)
15871 150 CONTINUE
15872
15873C...Copy info back into HEPEUP in right order.
15874 DO 180 I=1,NUP
15875 IOLD=NEWPOS(I)
15876 IDUP(I)=IDUPT(IOLD)
15877 ISTUP(I)=ISTUPT(IOLD)
15878 MOTHUP(1,I)=0
15879 MOTHUP(2,I)=0
15880 DO 160 IMOT=1,I-1
15881 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15882 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15883 160 CONTINUE
15884 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15885 MOTHSW=MOTHUP(1,I)
15886 MOTHUP(1,I)=MOTHUP(2,I)
15887 MOTHUP(2,I)=MOTHSW
15888 ENDIF
15889 ICOLUP(1,I)=ICOUPT(1,IOLD)
15890 ICOLUP(2,I)=ICOUPT(2,IOLD)
15891 DO 170 J=1,5
15892 PUP(J,I)=PUPT(J,IOLD)
15893 170 CONTINUE
15894 VTIMUP(I)=VTIUPT(IOLD)
15895 SPINUP(I)=SPIUPT(IOLD)
15896 180 CONTINUE
15897 ENDIF
15898
15899c...If incoming particles are massive recalculate to put them massless.
15900 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15901 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15902 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15903 PUP(4,1)=0.5D0*PPLUS
15904 PUP(3,1)=PUP(4,1)
15905 PUP(5,1)=0D0
15906 PUP(4,2)=0.5D0*PMINUS
15907 PUP(3,2)=-PUP(4,2)
15908 PUP(5,2)=0D0
15909 ENDIF
15910
15911 RETURN
15912 END
15913
15914C*********************************************************************
15915
15916C...PYADSH
15917C...Administers the generation of successive final-state showers
15918C...in external processes.
15919
15920 SUBROUTINE PYADSH(NFIN)
15921
15922C...Double precision and integer declarations.
15923 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15924 IMPLICIT INTEGER(I-N)
15925 INTEGER PYK,PYCHGE,PYCOMP
15926C...Parameter statement for maximum size of showers.
15927 PARAMETER (MAXNUR=1000)
15928C...Commonblocks.
15929 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15930 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15931 COMMON/PYCTAG/NCT,MCT(4000,2)
15932 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15933 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15934 COMMON/PYINT1/MINT(400),VINT(400)
15935 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15936C...Local array.
15937 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15938
15939C...Set primary vertex.
15940 DO 100 J=1,5
15941 V(MINT(83)+5,J)=0D0
15942 V(MINT(83)+6,J)=0D0
15943 V(MINT(84)+1,J)=0D0
15944 V(MINT(84)+2,J)=0D0
15945 100 CONTINUE
15946
15947C...Isolate systems of particles with the same mother.
15948 NSYS=0
15949 IMS=-1
15950 DO 140 I=MINT(84)+3,NFIN
15951 IM=K(I,3)
15952 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15953 IF(IM.NE.IMS) THEN
15954 NSYS=NSYS+1
15955 IBEG(NSYS)=I
15956 IMS=IM
15957 ENDIF
15958
15959C...Set production vertices.
15960 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15961 & THEN
15962 DO 110 J=1,4
15963 V(I,J)=0D0
15964 110 CONTINUE
15965 ELSE
15966 DO 120 J=1,4
15967 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15968 120 CONTINUE
15969 ENDIF
15970 IF(MSTP(125).GE.1) THEN
15971 IDOC=I-MSTP(126)+4
15972 DO 130 J=1,5
15973 V(IDOC,J)=V(I,J)
15974 130 CONTINUE
15975 ENDIF
15976 140 CONTINUE
15977
15978C...End loop over systems. Return if no showers to be performed.
15979 IBEG(NSYS+1)=NFIN+1
15980 IF(MSTP(71).LE.0) RETURN
15981
15982C...Loop through systems of particles; check that sensible size.
15983 DO 270 ISYS=1,NSYS
15984 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15985 IF(MINT(35).LE.1) THEN
15986 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15987 GOTO 270
15988 ELSEIF(NSIZ.LE.1) THEN
15989 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15990 GOTO 270
15991 ELSEIF(NSIZ.GT.80) THEN
15992 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
15993 GOTO 270
15994 ENDIF
15995 ENDIF
15996
15997C...Save status codes and daughters of showering particles; reset them.
15998 DO 150 J=1,4
15999 PSUM(J)=0D0
16000 150 CONTINUE
16001 DO 170 II=1,NSIZ
16002 I=IBEG(ISYS)-1+II
16003 KSAV(II,1)=K(I,1)
16004 IF(K(I,1).GT.10) THEN
16005 K(I,1)=1
16006 IF(KSAV(II,1).EQ.14) K(I,1)=3
16007 ENDIF
16008 IF(KSAV(II,1).LE.10) THEN
16009 ELSEIF(K(I,1).EQ.1) THEN
16010 KSAV(II,4)=K(I,4)
16011 KSAV(II,5)=K(I,5)
16012 K(I,4)=0
16013 K(I,5)=0
16014 ELSE
16015 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16016 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16017 K(I,4)=K(I,4)-KSAV(II,4)
16018 K(I,5)=K(I,5)-KSAV(II,5)
16019 ENDIF
16020 DO 160 J=1,4
16021 PSUM(J)=PSUM(J)+P(I,J)
16022 160 CONTINUE
16023 170 CONTINUE
16024
16025C...Perform shower.
16026 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16027 & PSUM(3)**2))
16028 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16029 NSAV=N
16030 IF(MINT(35).LE.1) THEN
16031 IF(NSIZ.EQ.2) THEN
16032 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16033 ELSE
16034 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16035 ENDIF
16036
16037C...For external processes, first call, also ISR partons radiate.
16038C...Can use existing PYPART list, removing partons that radiate later.
16039 ELSEIF(ISYS.EQ.1) THEN
16040 NPARTN=0
16041 DO 175 II=1,NPART
16042 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16043 NPARTN=NPARTN+1
16044 IPART(NPARTN)=IPART(II)
16045 PTPART(NPARTN)=PTPART(II)
16046 ENDIF
16047 175 CONTINUE
16048 NPART=NPARTN
16049 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16050 ELSE
16051C...For subsequent calls use the systems excluded above.
16052 NPART=NSIZ
16053 NPARTD=0
16054 DO 180 II=1,NSIZ
16055 I=IBEG(ISYS)-1+II
16056 IPART(II)=I
16057 PTPART(II)=0.5D0*QMAX
16058 180 CONTINUE
16059 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16060 ENDIF
16061
16062C...Look up showered copies of original showering particles.
16063 DO 260 II=1,NSIZ
16064 I=IBEG(ISYS)-1+II
16065 IMV=I
16066C...Particles without daughters need not be studied.
16067 IF(KSAV(II,1).LE.10) GOTO 260
16068 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16069 ELSEIF(K(I,1).EQ.11) THEN
16070 190 IMV=MOD(K(IMV,4),MSTU(5))
16071 IF(K(IMV,1).EQ.11) GOTO 190
16072 ELSE
16073 KDA1=MOD(K(I,4),MSTU(5))
16074 IF(KDA1.GT.0) THEN
16075 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16076 ENDIF
16077 KDA2=MOD(K(I,5),MSTU(5))
16078 IF(KDA2.GT.0) THEN
16079 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16080 ENDIF
16081 DO 200 I3=I+1,N
16082 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16083 & THEN
16084 IMV=I3
16085 KDA1=MOD(K(I3,4),MSTU(5))
16086 IF(KDA1.GT.0) THEN
16087 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16088 ENDIF
16089 KDA2=MOD(K(I3,5),MSTU(5))
16090 IF(KDA2.GT.0) THEN
16091 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16092 ENDIF
16093 ENDIF
16094 200 CONTINUE
16095 ENDIF
16096
16097C...Restore daughter info of original partons to showered copies.
16098 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16099 IF(KSAV(II,1).LE.10) THEN
16100 ELSEIF(K(I,1).EQ.1) THEN
16101 K(IMV,4)=KSAV(II,4)
16102 K(IMV,5)=KSAV(II,5)
16103 ELSE
16104 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16105 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16106 ENDIF
16107
16108C...Reset mother info of existing daughters to showered copies.
16109 DO 210 I3=IBEG(ISYS+1),NFIN
16110 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16111 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16112 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16113 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16114 ENDIF
16115 210 CONTINUE
16116
16117C...Boost all original daughters to new frame of showered copy.
16118C...Also update their colour tags.
16119 IF(IMV.NE.I) THEN
16120 DO 220 J=1,3
16121 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16122 220 CONTINUE
16123 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16124 DO 230 J=1,3
16125 BETA(J)=FAC*BETA(J)
16126 230 CONTINUE
16127 DO 250 I3=IBEG(ISYS+1),NFIN
16128 IMO=I3
16129 240 IMO=K(IMO,3)
16130 IF(MSTP(128).LE.0) THEN
16131 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16132 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16133 & THEN
16134 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16135 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16136 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16137 ENDIF
16138 ELSE
16139 IF(IMO.EQ.IMV) THEN
16140 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16141 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16142 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16143 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16144 GOTO 240
16145 ENDIF
16146 ENDIF
16147 250 CONTINUE
16148 ENDIF
16149 260 CONTINUE
16150
16151C...End of loop over showering systems
16152 270 CONTINUE
16153
16154 RETURN
16155 END
16156
16157C*********************************************************************
16158
16159C...PYVETO
16160C...Interface to UPVETO, which allows user to veto event generation
16161C...on the parton level, after parton showers but before multiple
16162C...interactions, beam remnants and hadronization is added.
16163
16164 SUBROUTINE PYVETO(IVETO)
16165
16166C...All real arithmetic in double precision.
16167 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16168C...Three Pythia functions return integers, so need declaring.
16169 INTEGER PYK,PYCHGE,PYCOMP
16170
16171C...PYTHIA commonblocks.
16172 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16173 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16175 COMMON/PYINT1/MINT(400),VINT(400)
16176 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16177C...HEPEVT commonblock.
16178 PARAMETER (NMXHEP=4000)
16179 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16180 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16181 DOUBLE PRECISION PHEP,VHEP
16182 SAVE /HEPEVT/
16183C...Local array.
16184 DIMENSION IRESO(100)
16185
16186C...Define longitudinal boost from initiator rest frame to cm frame.
16187 IF(MINT(35).EQ.3) THEN
16188C...The last frame is different depending upon old and new shower
16189 GAMMA=1D0
16190 GABEZ=0D0
16191 ELSE
16192 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16193 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16194 ENDIF
16195
16196C... Reset counters.
16197 NEVHEP=0
16198 NHEP=0
16199 NRESO=0
16200
16201C...Oth pass: identify beam and incoming partons
16202 DO 140 I=MINT(83)+1,MINT(83)+6
16203 ISTORE=0
16204C IF(K(I,2).EQ.94.OR.K(I,2).EQ.0) THEN
16205 IF(K(I,2).EQ.94) THEN
16206
16207 ELSE
16208 ISTORE=1
16209 NHEP=NHEP+1
16210 II=NHEP
16211 NRESO=NRESO+1
16212 IRESO(NRESO)=I
16213 IMOTH=K(I,3)
16214 ENDIF
16215 IF(ISTORE.EQ.1) THEN
16216C...Copy parton info, boosting momenta along z axis to cm frame.
16217 ISTHEP(II)=2
16218 IDHEP(II)=K(I,2)
16219 PHEP(1,II)=P(I,1)
16220 PHEP(2,II)=P(I,2)
16221 IF(II.GT.2) THEN
16222 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16223 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16224 ELSE
16225 PHEP(3,II)=P(I,3)
16226 PHEP(4,II)=P(I,4)
16227 ENDIF
16228 PHEP(5,II)=P(I,5)
16229C...Store one mother. Rest of history and vertex info zeroed.
16230 JMOHEP(1,II)=IMOTH
16231 JMOHEP(2,II)=0
16232 JDAHEP(1,II)=0
16233 JDAHEP(2,II)=0
16234 VHEP(1,II)=0D0
16235 VHEP(2,II)=0D0
16236 VHEP(3,II)=0D0
16237 VHEP(4,II)=0D0
16238 ENDIF
16239 140 CONTINUE
16240
16241C...First pass: identify final locations of resonances
16242C...and of their daughters before showering.
16243 DO 150 I=MINT(84)+3,N
16244 ISTORE=0
16245 IMOTH=0
16246
16247C...Skip shower CM frame documentation lines.
16248 IF(K(I,2).EQ.94) THEN
16249
16250C... Store a new intermediate product, when mother in documentation.
16251 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16252 & K(I,3).LE.MINT(84)) THEN
16253 ISTORE=1
16254 NHEP=NHEP+1
16255 II=NHEP
16256 NRESO=NRESO+1
16257 IRESO(NRESO)=I
16258 IMOTH=K(K(I,3),3)
16259
16260C... Store a new intermediate product, when mother in main section.
16261 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16262 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16263 ISTORE=1
16264 NHEP=NHEP+1
16265 II=NHEP
16266 NRESO=NRESO+1
16267 IRESO(NRESO)=I
16268 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3))
16269 ENDIF
16270
16271 IF(ISTORE.EQ.1) THEN
16272C...Copy parton info, boosting momenta along z axis to cm frame.
16273 ISTHEP(II)=2
16274 IDHEP(II)=K(I,2)
16275 PHEP(1,II)=P(I,1)
16276 PHEP(2,II)=P(I,2)
16277 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16278 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16279 PHEP(5,II)=P(I,5)
16280C...Store one mother. Rest of history and vertex info zeroed.
16281 JMOHEP(1,II)=IMOTH
16282 JMOHEP(2,II)=0
16283 JDAHEP(1,II)=I
16284 JDAHEP(2,II)=0
16285 VHEP(1,II)=0D0
16286 VHEP(2,II)=0D0
16287 VHEP(3,II)=0D0
16288 VHEP(4,II)=0D0
16289 ENDIF
16290 150 CONTINUE
16291
16292C...Second pass: identify current set of "final" partons.
16293 DO 200 I=MINT(84)+3,N
16294 ISTORE=0
16295 IMOTH=0
16296
16297C...Store a final parton.
16298 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16299 ISTORE=1
16300 NHEP=NHEP+1
16301 II=NHEP
16302C..Trace it back through shower, to check if from documented particle.
16303 IHIST=I
16304 ISAVE=IHIST
16305 160 CONTINUE
16306 IF(IHIST.GT.MINT(84)) THEN
16307 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16308 DO 170 IRI=1,NRESO
16309 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16310 170 CONTINUE
16311 ISAVE=IHIST
16312 IHIST=K(IHIST,3)
16313 IF(IMOTH.EQ.0) GOTO 160
16314 ELSEIF(IHIST.LE.4) THEN
16315 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16316 ISTORE=0
16317 NHEP=NHEP-1
16318 ELSE
16319 IMOTH=IHIST
16320 ENDIF
16321 ENDIF
16322 ENDIF
16323
16324 IF(ISTORE.EQ.1) THEN
16325C...Copy parton info, boosting momenta along z axis to cm frame.
16326 ISTHEP(II)=1
16327 IDHEP(II)=K(I,2)
16328 PHEP(1,II)=P(I,1)
16329 PHEP(2,II)=P(I,2)
16330 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16331 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16332 PHEP(5,II)=P(I,5)
16333C...Store one mother. Rest of history and vertex info zeroed.
16334 JMOHEP(1,II)=IMOTH
16335 JMOHEP(2,II)=0
16336 JDAHEP(1,II)=0
16337 JDAHEP(2,II)=0
16338 VHEP(1,II)=0D0
16339 VHEP(2,II)=0D0
16340 VHEP(3,II)=0D0
16341 VHEP(4,II)=0D0
16342 ENDIF
16343 200 CONTINUE
16344
16345C...Call user-written routine to decide whether to keep events.
16346 CALL UPVETO(IVETO)
16347
16348 RETURN
16349 END
16350C*********************************************************************
16351
16352C...PYRESD
16353C...Allows resonances to decay (including parton showers for hadronic
16354C...channels).
16355
16356 SUBROUTINE PYRESD(IRES)
16357
16358C...Double precision and integer declarations.
16359 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16360 IMPLICIT INTEGER(I-N)
16361 INTEGER PYK,PYCHGE,PYCOMP
16362C...Parameter statement to help give large particle numbers.
16363 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16364 &KEXCIT=4000000,KDIMEN=5000000)
16365C...Parameter statement for maximum size of showers.
16366 PARAMETER (MAXNUR=1000)
16367C...Commonblocks.
16368 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16369 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16370 COMMON/PYCTAG/NCT,MCT(4000,2)
16371 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16372 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16373 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16374 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16375 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16376 COMMON/PYINT1/MINT(400),VINT(400)
16377 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16378 COMMON/PYINT4/MWID(500),WIDS(500,5)
16379 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16380 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
16381C...Local arrays and complex and character variables.
16382 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16383 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16384 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16385 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16386 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16387 COMPLEX FGK,HA(6,6),HC(6,6)
16388 REAL TIR,UIR
16389 CHARACTER CODE*9,MASS*9
16390
16391C...The F, Xi and Xj functions of Gunion and Kunszt
16392C...(Phys. Rev. D33, 665, plus errata from the authors).
16393 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16394 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16395 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16396 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16397 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16398 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16399 &2D0*(D34/D56+D56/D34))
16400
16401C...Some general constants.
16402 XW=PARU(102)
16403 XWV=XW
16404 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16405 XW1=1D0-XW
16406 SQMZ=PMAS(23,1)**2
16407
16408 GMMZ=PMAS(23,1)*PMAS(23,2)
16409 SQMW=PMAS(24,1)**2
16410 GMMW=PMAS(24,1)*PMAS(24,2)
16411 SH=VINT(44)
16412
16413C...Boost and rotate to rest frame of incoming partons,
16414C...to get proper amount of smearing of decay angles.
16415 IBST=0
16416 IF(IRES.EQ.0) THEN
16417 IBST=1
16418 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
16419 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
16420 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
16421 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
16422 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
16423 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
16424 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
16425 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
16426 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
16427 ENDIF
16428
16429C...Reset original resonance configuration.
16430 DO 100 JT=1,8
16431 IREF(1,JT)=0
16432 100 CONTINUE
16433
16434C...Define initial one, two or three objects for subprocess.
16435 IHDEC=0
16436 IF(IRES.EQ.0) THEN
16437 ISUB=MINT(1)
16438 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
16439 IREF(1,1)=MINT(84)+2+ISET(ISUB)
16440 IREF(1,4)=MINT(83)+6+ISET(ISUB)
16441 JTMAX=1
16442 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16443 IREF(1,1)=MINT(84)+1+ISET(ISUB)
16444 IREF(1,2)=MINT(84)+2+ISET(ISUB)
16445 IREF(1,4)=MINT(83)+5+ISET(ISUB)
16446 IREF(1,5)=MINT(83)+6+ISET(ISUB)
16447 JTMAX=2
16448 ELSEIF(ISET(ISUB).EQ.5) THEN
16449 IREF(1,1)=MINT(84)+3
16450 IREF(1,2)=MINT(84)+4
16451 IREF(1,3)=MINT(84)+5
16452 IREF(1,4)=MINT(83)+7
16453 IREF(1,5)=MINT(83)+8
16454 IREF(1,6)=MINT(83)+9
16455 JTMAX=3
16456 ENDIF
16457
16458C...Define original resonance for odd cases.
16459 ELSE
16460 ISUB=0
16461 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16462 & IHDEC=1
16463 IF(IHDEC.EQ.1) ISUB=3
16464 IREF(1,1)=IRES
16465 IREF(1,4)=K(IRES,3)
16466 IRESTM=IRES
16467 IF(IREF(1,4).GT.MINT(84)) THEN
16468 110 ITMPMO=IREF(1,4)
16469 IF(K(ITMPMO,2).EQ.94) THEN
16470 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16471 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16472 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16473 IRESTM=ITMPMO
16474C...Explicitly check that reference particle exists, otherwise stop recursion
16475 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
16476 IREF(1,4)=K(ITMPMO,3)
16477 GOTO 110
16478 ENDIF
16479 ENDIF
16480 ENDIF
16481 IF(IREF(1,4).GT.MINT(84)) THEN
16482 EMATCH=1D10
16483 IREF14=IREF(1,4)
16484 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16485 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16486 & EMATCH) THEN
16487 IREF(1,4)=II
16488 EMATCH=ABS(P(II,4)-P(IREF14,4))
16489 ENDIF
16490 120 CONTINUE
16491 ENDIF
16492 JTMAX=1
16493 ENDIF
16494
16495C...Check if initial resonance has been moved (in resonance + jet).
16496 DO 140 JT=1,3
16497 IF(IREF(1,JT).GT.0) THEN
16498 IF(K(IREF(1,JT),1).GT.10) THEN
16499 KFA=IABS(K(IREF(1,JT),2))
16500 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16501 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16502 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16503 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16504 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16505 ENDIF
16506 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16507 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16508 ENDIF
16509 DO 130 I=IREF(1,JT)+1,N
16510 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16511 & I.EQ.KDA2)) THEN
16512 IREF(1,JT)=I
16513 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16514 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16515 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16516 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16517 ENDIF
16518 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16519 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16520 ENDIF
16521 ENDIF
16522 130 CONTINUE
16523 ELSE
16524 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16525 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16526 ENDIF
16527 ENDIF
16528 ENDIF
16529 140 CONTINUE
16530
16531C...Set decay vertex for initial resonances
16532 DO 160 JT=1,JTMAX
16533 DO 150 I=1,4
16534 V(IREF(1,JT),I)=0D0
16535 150 CONTINUE
16536 160 CONTINUE
16537
16538C...Loop over decay history.
16539 NP=1
16540 IP=0
16541 170 IP=IP+1
16542 NINH=0
16543 JTMAX=2
16544 IF(IREF(IP,2).EQ.0) JTMAX=1
16545 IF(IREF(IP,3).NE.0) JTMAX=3
16546 IT4=0
16547 NSAV=N
16548
16549C...Check for Higgs which appears as decay product of user-process.
16550 IF(ISUB.EQ.0) THEN
16551 IHDEC=0
16552 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16553 & .EQ.36) IHDEC=1
16554 IF(IHDEC.EQ.1) ISUB=3
16555 ENDIF
16556
16557C...Start treatment of one, two or three resonances in parallel.
16558 180 N=NSAV
16559 DO 340 JT=1,JTMAX
16560 ID=IREF(IP,JT)
16561 KDCY(JT)=0
16562 KFL1(JT)=0
16563 KFL2(JT)=0
16564 KFL3(JT)=0
16565 KEQL(JT)=0
16566 NSD(JT)=ID
16567 ITJUNC(JT)=0
16568
16569C...Check whether particle can/is allowed to decay.
16570 IF(ID.EQ.0) GOTO 330
16571 KFA=IABS(K(ID,2))
16572 KCA=PYCOMP(KFA)
16573 IF(MWID(KCA).EQ.0) GOTO 330
16574 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16575 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16576 & KFA.EQ.18) IT4=IT4+1
16577 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16578 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16579
16580C...Choose lifetime and determine decay vertex.
16581 IF(K(ID,1).EQ.5) THEN
16582 V(ID,5)=0D0
16583 ELSEIF(K(ID,1).NE.4) THEN
16584 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16585 ENDIF
16586 DO 190 J=1,4
16587 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16588 190 CONTINUE
16589
16590C...Determine whether decay allowed or not.
16591 MOUT=0
16592 IF(MSTJ(22).EQ.2) THEN
16593 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16594 ELSEIF(MSTJ(22).EQ.3) THEN
16595 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16596 ELSEIF(MSTJ(22).EQ.4) THEN
16597 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16598 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16599 ENDIF
16600 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16601 K(ID,1)=4
16602 GOTO 330
16603 ENDIF
16604
16605C...Info for selection of decay channel: sign, pairings.
16606 IF(KCHG(KCA,3).EQ.0) THEN
16607 IPM=2
16608 ELSE
16609 IPM=(5-ISIGN(1,K(ID,2)))/2
16610 ENDIF
16611 KFB=0
16612 IF(JTMAX.EQ.2) THEN
16613 KFB=IABS(K(IREF(IP,3-JT),2))
16614 ELSEIF(JTMAX.EQ.3) THEN
16615 JT2=JT+1-3*(JT/3)
16616 KFB=IABS(K(IREF(IP,JT2),2))
16617 IF(KFB.NE.KFA) THEN
16618 JT2=JT+2-3*((JT+1)/3)
16619 KFB=IABS(K(IREF(IP,JT2),2))
16620 ENDIF
16621 ENDIF
16622
16623C...Select decay channel.
16624 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16625 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16626 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16627 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16628 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16629 IF(WDTE0S.LE.0D0) GOTO 330
16630 RKFL=WDTE0S*PYR(0)
16631 IDL=0
16632 200 IDL=IDL+1
16633 IDC=IDL+MDCY(KCA,2)-1
16634 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16635 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16636 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16637
16638C...Read out flavours and colour charges of decay channel chosen.
16639 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16640 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16641 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16642 KFC1A=PYCOMP(IABS(KFL1(JT)))
16643 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16644 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16645 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16646 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16647 KFC2A=PYCOMP(IABS(KFL2(JT)))
16648 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16649 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16650 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16651 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16652 KCQ3(JT)=0
16653 IF(KFL3(JT).NE.0) THEN
16654 KFC3A=PYCOMP(IABS(KFL3(JT)))
16655 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16656 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16657 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16658 ENDIF
16659
16660C...Set/save further info on channel.
16661 KDCY(JT)=1
16662 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16663 NSD(JT)=N
16664 HGZ(JT,1)=VINT(111)
16665 HGZ(JT,2)=VINT(112)
16666 HGZ(JT,3)=VINT(114)
16667 JTZ=JT
16668
16669C...Select masses; to begin with assume resonances narrow.
16670 DO 220 I=1,3
16671 P(N+I,5)=0D0
16672 PMMN(I)=0D0
16673 IF(I.EQ.1) THEN
16674 KFLW=IABS(KFL1(JT))
16675 KCW=KFC1A
16676 ELSEIF(I.EQ.2) THEN
16677 KFLW=IABS(KFL2(JT))
16678 KCW=KFC2A
16679 ELSEIF(I.EQ.3) THEN
16680 IF(KFL3(JT).EQ.0) GOTO 220
16681 KFLW=IABS(KFL3(JT))
16682 KCW=KFC3A
16683 ENDIF
16684 P(N+I,5)=PMAS(KCW,1)
16685CMRENNA++
16686C...This prevents SUSY/t particles from becoming too light.
16687 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16688 PMMN(I)=PMAS(KCW,1)
16689 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16690 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16691 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16692 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16693 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16694 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16695 PMMN(I)=MIN(PMMN(I),PMSUM)
16696 ENDIF
16697 210 CONTINUE
16698CMRENNA--
16699 ELSEIF(KFLW.EQ.6) THEN
16700 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16701 ENDIF
16702 220 CONTINUE
16703
16704C...Check which two out of three are widest.
16705 IWID1=1
16706 IWID2=2
16707 PWID1=PMAS(KFC1A,2)
16708 PWID2=PMAS(KFC2A,2)
16709 KFLW1=IABS(KFL1(JT))
16710 KFLW2=IABS(KFL2(JT))
16711 IF(KFL3(JT).NE.0) THEN
16712 PWID3=PMAS(KFC3A,2)
16713 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16714 IWID1=3
16715 PWID1=PWID3
16716 KFLW1=IABS(KFL3(JT))
16717 ELSEIF(PWID3.GT.PWID2) THEN
16718 IWID2=3
16719 PWID2=PWID3
16720 KFLW2=IABS(KFL3(JT))
16721 ENDIF
16722 ENDIF
16723
16724C...If all narrow then only check that masses consistent.
16725 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16726 & PWID2.LT.PARP(41))) THEN
16727CMRENNA++
16728C....Handle near degeneracy cases.
16729 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16730 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16731 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16732 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16733 ENDIF
16734 ENDIF
16735CMRENNA--
16736 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16737 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16738 MINT(51)=1
16739 GOTO 720
16740 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16741 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16742 MINT(51)=1
16743 GOTO 720
16744 ENDIF
16745
16746C...For three wide resonances select narrower of three
16747C...according to BW decoupled from rest.
16748 ELSE
16749 PMTOT=P(ID,5)
16750 IF(KFL3(JT).NE.0) THEN
16751 IWID3=6-IWID1-IWID2
16752 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16753 & KFLW1-KFLW2
16754 LOOP=0
16755 230 LOOP=LOOP+1
16756 P(N+IWID3,5)=PYMASS(KFLW3)
16757 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16758 PMTOT=PMTOT-P(N+IWID3,5)
16759 ENDIF
16760C...Select other two correlated within remaining phase space.
16761 IF(IP.EQ.1) THEN
16762 CKIN45=CKIN(45)
16763 CKIN47=CKIN(47)
16764 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16765 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16766 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16767 & P(N+IWID2,5))
16768 CKIN(45)=CKIN45
16769 CKIN(47)=CKIN47
16770 ELSE
16771 CKIN(49)=PMMN(IWID1)
16772 CKIN(50)=PMMN(IWID2)
16773 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16774 & P(N+IWID2,5))
16775 CKIN(49)=0D0
16776 CKIN(50)=0D0
16777 ENDIF
16778 IF(MINT(51).EQ.1) GOTO 720
16779 ENDIF
16780
16781C...Begin fill decay products, with colour flow for coloured objects.
16782 MSTU10=MSTU(10)
16783 MSTU(10)=1
16784 MSTU(19)=1
16785
16786C...Three-body decays
16787 IF(KFL3(JT).NE.0) THEN
16788 DO 250 I=N+1,N+3
16789 DO 240 J=1,5
16790 K(I,J)=0
16791 V(I,J)=0D0
16792 240 CONTINUE
16793 MCT(I,1)=0
16794 MCT(I,2)=0
16795 250 CONTINUE
16796 K(N+1,1)=1
16797 K(N+1,2)=KFL1(JT)
16798 K(N+2,1)=1
16799 K(N+2,2)=KFL2(JT)
16800 K(N+3,1)=1
16801 K(N+3,2)=KFL3(JT)
16802 IDIN=ID
16803
16804C...Generate kinematics (default is flat)
16805 CALL PYTBDY(IDIN)
16806
16807C...Set generic colour flows whenever unambiguous,
16808C...(independently of the order of the decay products)
16809C...Sum up total colour content
16810 NANT=0
16811 NTRI=0
16812 NOCT=0
16813 KCQ(0)=KCQM(JT)
16814 KCQ(1)=KCQ1(JT)
16815 KCQ(2)=KCQ2(JT)
16816 KCQ(3)=KCQ3(JT)
16817 DO 255 J=0,3
16818 IF (KCQ(J).EQ.-1) THEN
16819 NANT=NANT+1
16820 IANT(NANT)=N+J
16821 ELSEIF (KCQ(J).EQ.1) THEN
16822 NTRI=NTRI+1
16823 ITRI(NTRI)=N+J
16824 ELSEIF (KCQ(J).EQ.2) THEN
16825 NOCT=NOCT+1
16826 IOCT(NOCT)=N+J
16827 ENDIF
16828 255 CONTINUE
16829
16830C...Set color flow for generic 1 -> N processes (N arbitrary)
16831 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
16832C...All singlets: do nothing
16833
16834 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
16835C...Two octets, zero triplets, n singlets:
16836 IF (KCQ(0).EQ.2) THEN
16837C...8 -> 8 + n(1)
16838 K(ID,4)=K(ID,4)+IOCT(2)
16839 K(ID,5)=K(ID,5)+IOCT(2)
16840 K(IOCT(2),1)=3
16841 K(IOCT(2),4)=MSTU(5)*ID
16842 K(IOCT(2),5)=MSTU(5)*ID
16843 MCT(IOCT(2),1)=MCT(ID,1)
16844 MCT(IOCT(2),2)=MCT(ID,2)
16845 ELSE
16846C...1 -> 8 + 8 + n(1)
16847 K(IOCT(1),1)=3
16848 K(IOCT(1),4)=MSTU(5)*IOCT(2)
16849 K(IOCT(1),5)=MSTU(5)*IOCT(2)
16850 K(IOCT(2),1)=3
16851 K(IOCT(2),4)=MSTU(5)*IOCT(1)
16852 K(IOCT(2),5)=MSTU(5)*IOCT(1)
16853 NCT=NCT+1
16854 MCT(IOCT(1),1)=NCT
16855 MCT(IOCT(2),2)=NCT
16856 NCT=NCT+1
16857 MCT(IOCT(2),1)=NCT
16858 MCT(IOCT(1),2)=NCT
16859 ENDIF
16860
16861 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
16862C...Two triplets, zero octets, n singlets.
16863 IF (KCQ(0).EQ.1) THEN
16864C...3 -> 3 + n(1)
16865 K(ID,4)=K(ID,4)+ITRI(2)
16866 K(ITRI(2),1)=3
16867 K(ITRI(2),4)=MSTU(5)*ID
16868 MCT(ITRI(2),1)=MCT(ID,1)
16869 ELSEIF (KCQ(0).EQ.-1) THEN
16870C...3bar -> 3bar + n(1)
16871 K(ID,5)=K(ID,5)+IANT(2)
16872 K(IANT(2),1)=3
16873 K(IANT(2),5)=MSTU(5)*ID
16874 MCT(IANT(2),2)=MCT(ID,2)
16875 ELSE
16876C...1 -> 3 + 3bar + n(1)
16877 K(ITRI(1),1)=3
16878 K(ITRI(1),4)=MSTU(5)*IANT(1)
16879 K(IANT(1),1)=3
16880 K(IANT(1),5)=MSTU(5)*ITRI(1)
16881 NCT=NCT+1
16882 MCT(ITRI(1),1)=NCT
16883 MCT(IANT(1),2)=NCT
16884 ENDIF
16885
16886 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
16887C...Two triplets, one octet, n singlets.
16888 IF (KCQ(0).EQ.2) THEN
16889C...8 -> 3 + 3bar + n(1)
16890 K(ID,4)=K(ID,4)+ITRI(1)
16891 K(ID,5)=K(ID,5)+IANT(1)
16892 K(ITRI(1),1)=3
16893 K(ITRI(1),4)=MSTU(5)*ID
16894 K(IANT(1),1)=3
16895 K(IANT(1),5)=MSTU(5)*ID
16896 MCT(ITRI(1),1)=MCT(ID,1)
16897 MCT(IANT(1),2)=MCT(ID,2)
16898 ELSEIF (KCQ(0).EQ.1) THEN
16899C...3 -> 8 + 3 + n(1)
16900 K(ID,4)=K(ID,4)+IOCT(1)
16901 K(IOCT(1),1)=3
16902 K(IOCT(1),4)=MSTU(5)*ID
16903 K(IOCT(1),5)=MSTU(5)*ITRI(2)
16904 K(ITRI(2),1)=3
16905 K(ITRI(2),4)=MSTU(5)*IOCT(1)
16906 MCT(IOCT(1),1)=MCT(ID,1)
16907 NCT=NCT+1
16908 MCT(IOCT(1),2)=NCT
16909 MCT(ITRI(2),1)=NCT
16910 ELSEIF (KCQ(0).EQ.-1) THEN
16911C...3bar -> 8 + 3bar + n(1)
16912 K(ID,5)=K(ID,5)+IOCT(1)
16913 K(IOCT(1),1)=3
16914 K(IOCT(1),5)=MSTU(5)*ID
16915 K(IOCT(1),4)=MSTU(5)*IANT(2)
16916 K(IANT(2),1)=3
16917 K(IANT(2),5)=MSTU(5)*IOCT(1)
16918 MCT(IOCT(1),2)=MCT(ID,2)
16919 NCT=NCT+1
16920 MCT(IOCT(1),1)=NCT
16921 MCT(IANT(2),2)=NCT
16922 ELSE
16923C...1 -> 3 + 3bar + 8 + n(1)
16924 K(ITRI(1),1)=3
16925 K(ITRI(1),4)=MSTU(5)*IOCT(1)
16926 K(IOCT(1),1)=3
16927 K(IOCT(1),5)=MSTU(5)*ITRI(1)
16928 K(IOCT(1),4)=MSTU(5)*IANT(1)
16929 K(IANT(1),1)=3
16930 K(IANT(1),5)=MSTU(5)*IOCT(1)
16931 NCT=NCT+1
16932 MCT(ITRI(1),1)=NCT
16933 MCT(IOCT(1),2)=NCT
16934 NCT=NCT+1
16935 MCT(IOCT(1),1)=NCT
16936 MCT(IANT(1),2)=NCT
16937 ENDIF
16938CPS-- End of generic cases
16939C...(could three octets also be handled?)
16940C...(could (some of) the RPV cases be made generic as well?)
16941
16942C...Special cases (= old treatment)
16943C...Set colour flow for t -> W + b + Z.
16944 ELSEIF(KFA.EQ.6) THEN
16945 K(N+2,1)=3
16946 ISID=4
16947 IF(KCQM(JT).EQ.-1) ISID=5
16948 IDAU=N+2
16949 K(ID,ISID)=K(ID,ISID)+IDAU
16950 K(IDAU,ISID)=MSTU(5)*ID
16951
16952C...Set colour flow in three-body decays - programmed as special cases.
16953
16954 ELSEIF(KFC2A.LE.6) THEN
16955 K(N+2,1)=3
16956 K(N+3,1)=3
16957 ISID=4
16958 IF(KFL2(JT).LT.0) ISID=5
16959 K(N+2,ISID)=MSTU(5)*(N+3)
16960 K(N+3,9-ISID)=MSTU(5)*(N+2)
16961C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16962 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16963 & .AND.KFL3(JT).NE.0) THEN
16964 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16965C...3-body decays of squarks to colour singlets plus one quark
16966 IF (KQSUMA.EQ.1) THEN
16967C...Find quark
16968 IQ=0
16969 IF (KCQ1(JT).NE.0) IQ=1
16970 IF (KCQ2(JT).NE.0) IQ=2
16971 IF (KCQ3(JT).NE.0) IQ=3
16972 ISID=4
16973 IF (K(N+IQ,2).LT.0) ISID=5
16974 K(N+IQ,1)=3
16975 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16976 K(N+IQ,ISID)=MSTU(5)*ID
16977 ENDIF
16978C...PS--
16979 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
16980 K(N+1,1)=3
16981 K(N+2,1)=3
16982 K(N+3,1)=3
16983 ISID=4
16984 IF(KFL2(JT).LT.0) ISID=5
16985 K(N+1,ISID)=MSTU(5)*(N+2)
16986 K(N+1,9-ISID)=MSTU(5)*(N+3)
16987 K(N+2,ISID)=MSTU(5)*(N+1)
16988 K(N+3,9-ISID)=MSTU(5)*(N+1)
16989 ELSEIF(KFA.EQ.KSUSY1+21) THEN
16990 K(N+2,1)=3
16991 K(N+3,1)=3
16992 ISID=4
16993 IF(KFL2(JT).LT.0) ISID=5
16994 K(ID,ISID)=K(ID,ISID)+(N+2)
16995 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
16996 K(N+2,ISID)=MSTU(5)*ID
16997 K(N+3,9-ISID)=MSTU(5)*ID
16998CMRENNA--
16999
17000 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17001 & IABS(KCQ2(JT)).EQ.1) THEN
17002 K(N+2,1)=3
17003 K(N+3,1)=3
17004 ISID=4
17005 IF(KFL2(JT).LT.0) ISID=5
17006 K(N+2,ISID)=MSTU(5)*(N+3)
17007 K(N+3,9-ISID)=MSTU(5)*(N+2)
17008 ENDIF
17009
17010 NSAV=N
17011
17012C...Set colour flow in three-body decays with baryon number violation.
17013C...Neutralino and chargino decays first.
17014 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17015 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17016 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17017 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17018C...Insert junction to keep track of colours.
17019 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17020 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17021 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17022C...Set special junction codes:
17023 K(N+4,1)=42
17024 K(N+4,2)=88
17025
17026C...Order decay products by invariant mass. (will be used in PYSTRF).
17027 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)-
17028 & P(N+1,3)*P(N+2,3)
17029 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)-
17030 & P(N+1,3)*P(N+3,3)
17031 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)-
17032 & P(N+2,3)*P(N+3,3)
17033 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17034 K(N+4,4)=N+3+K(N+4,4)
17035 K(N+4,5)=N+1+MSTU(5)*(N+2)
17036 ELSEIF(PM13.LT.PM23) THEN
17037 K(N+4,4)=N+2+K(N+4,4)
17038 K(N+4,5)=N+1+MSTU(5)*(N+3)
17039 ELSE
17040 K(N+4,4)=N+1+K(N+4,4)
17041 K(N+4,5)=N+2+MSTU(5)*(N+3)
17042 ENDIF
17043 DO 260 J=1,5
17044 P(N+4,J)=0D0
17045 V(N+4,J)=0D0
17046 260 CONTINUE
17047C...Connect daughters to junction.
17048 DO 270 II=N+1,N+3
17049 K(II,4)=0
17050 K(II,5)=0
17051 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17052 270 CONTINUE
17053C...Particle counter should be stepped up one extra for junction.
17054 N=N+1
17055
17056C...Gluino decays.
17057 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17058 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17059 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17060C...Insert junction to keep track of colours.
17061 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17062 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17063 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17064 K(N+4,1)=42
17065 K(N+4,2)=88
17066 DO 280 J=1,5
17067 P(N+4,J)=0D0
17068 V(N+4,J)=0D0
17069 280 CONTINUE
17070 CTMSUM=0D0
17071 DO 290 II=N+1,N+3
17072 K(II,4)=0
17073 K(II,5)=0
17074C...Start by connecting all daughters to junction.
17075 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17076C...Only consider colour topologies with off shell resonances.
17077 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17078 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17079 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17080 IF (RMGLU-RMQ1.LT.RMRES) THEN
17081C...Calculate propagators for each colour topology.
17082 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17083 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17084 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17085 ELSE
17086 CTM2(II-N)=0D0
17087 ENDIF
17088 CTMSUM=CTMSUM+CTM2(II-N)
17089 290 CONTINUE
17090 CTMSUM=PYR(0)*CTMSUM
17091C...Select colour topology J, with most off shell least likely.
17092 J=0
17093 300 J=J+1
17094 CTMSUM=CTMSUM-CTM2(J)
17095 IF (CTMSUM.GT.0D0) GOTO 300
17096C...The lucky winner gets its colour (anti-colour) directly from gluino.
17097 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17098 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17099C...The other gluino colour is connected to junction
17100 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17101 & MSTU(5)
17102 K(N+4,4)=K(N+4,4)+ID
17103C...Lastly, connect junction to remaining daughters.
17104 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17105C...Particle counter should be stepped up one extra for junction.
17106 N=N+1
17107 ENDIF
17108
17109C...Update particle counter.
17110 N=N+3
17111
17112C...2) Everything else two-body decay.
17113 ELSE
17114 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17115 MCT(N-1,1)=0
17116 MCT(N-1,2)=0
17117 MCT(N,1)=0
17118 MCT(N,2)=0
17119C...First set colour flow as if mother colour singlet.
17120 IF(KCQ1(JT).NE.0) THEN
17121 K(N-1,1)=3
17122 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17123 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17124 ENDIF
17125 IF(KCQ2(JT).NE.0) THEN
17126 K(N,1)=3
17127 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17128 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17129 ENDIF
17130C...Then redirect colour flow if mother (anti)triplet.
17131 IF(KCQM(JT).EQ.0) THEN
17132 ELSEIF(KCQM(JT).NE.2) THEN
17133 ISID=4
17134 IF(KCQM(JT).EQ.-1) ISID=5
17135 IDAU=N-1
17136 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17137 K(ID,ISID)=K(ID,ISID)+IDAU
17138 K(IDAU,ISID)=MSTU(5)*ID
17139C...Then redirect colour flow if mother octet.
17140 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17141 IDAU=N-1
17142 IF(KCQ1(JT).EQ.0) IDAU=N
17143 K(ID,4)=K(ID,4)+IDAU
17144 K(ID,5)=K(ID,5)+IDAU
17145 K(IDAU,4)=MSTU(5)*ID
17146 K(IDAU,5)=MSTU(5)*ID
17147 ELSE
17148 ISID=4
17149 IF(KCQ1(JT).EQ.-1) ISID=5
17150 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17151 K(ID,ISID)=K(ID,ISID)+(N-1)
17152 K(ID,9-ISID)=K(ID,9-ISID)+N
17153 K(N-1,ISID)=MSTU(5)*ID
17154 K(N,9-ISID)=MSTU(5)*ID
17155 ENDIF
17156
17157C...Insert junction
17158 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17159 N=N+1
17160C...~q* mother: type 3 junction. ~q mother: type 4.
17161 ITJUNC(JT)=(7+KCQM(JT))/2
17162C...Specify junction KF and set colour flow from junction
17163 K(N,1)=42
17164 K(N,2)=88
17165 K(N,3)=ID
17166C...Junction type encoded together with mother:
17167 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17168 K(N,5)=N-1+MSTU(5)*(N-2)
17169C...Zero P and V for junction (V filled later)
17170 DO 310 J=1,5
17171 P(N,J)=0D0
17172 V(N,J)=0D0
17173 310 CONTINUE
17174C...Set colour flow from mother to junction
17175 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17176C...Set colour flow from daughters to junction
17177 DO 320 II=N-2,N-1
17178 K(II,4) = 0
17179 K(II,5) = 0
17180C...(Anti-)colour mother is junction.
17181 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17182 320 CONTINUE
17183 ENDIF
17184 ENDIF
17185
17186C...End loop over resonances for daughter flavour and mass selection.
17187 MSTU(10)=MSTU10
17188 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17189 & NINH=NINH+1
17190 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17191 & KFL1(JT).EQ.0) THEN
17192 WRITE(CODE,'(I9)') K(ID,2)
17193 WRITE(MASS,'(F9.3)') P(ID,5)
17194 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17195 & CODE//' with mass'//MASS)
17196 MINT(51)=1
17197 GOTO 720
17198 ENDIF
17199 340 CONTINUE
17200
17201C...Check for allowed combinations. Skip if no decays.
17202 IF(JTMAX.EQ.1) THEN
17203 IF(KDCY(1).EQ.0) GOTO 710
17204 ELSEIF(JTMAX.EQ.2) THEN
17205 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17206 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17207 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17208 ELSEIF(JTMAX.EQ.3) THEN
17209 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17210 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17211 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17212 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17213 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17214 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17215 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17216 ENDIF
17217
17218C...Special case: matrix element option for Z0 decay to quarks.
17219 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17220 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17221
17222C...Check consistency of MSTJ options set.
17223 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17224 CALL PYERRM(6,
17225 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17226 MSTJ(110)=1
17227 ENDIF
17228 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17229 CALL PYERRM(6,
17230 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17231
17232 MSTJ(111)=0
17233 ENDIF
17234
17235C...Select alpha_strong behaviour.
17236 MST111=MSTU(111)
17237 PAR112=PARU(112)
17238 MSTU(111)=MSTJ(108)
17239 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17240 & MSTU(111)=1
17241 PARU(112)=PARJ(121)
17242 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17243
17244C...Find axial fraction in total cross section for scalar gluon model.
17245 PARJ(171)=0D0
17246 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17247 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17248 POLL=1D0-PARJ(131)*PARJ(132)
17249 SFF=1D0/(16D0*XW*XW1)
17250 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17251 & (PARJ(123)*PARJ(124))**2)
17252 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17253 VE=4D0*XW-1D0
17254 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17255 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17256 & (PARJ(132)-PARJ(131)))
17257 KFLC=IABS(KFL1(1))
17258 PMQ=PYMASS(KFLC)
17259 QF=KCHG(KFLC,1)/3D0
17260 VQ=1D0
17261 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17262 & 1D0-(2D0*PMQ/P(ID,5))**2))
17263 VF=SIGN(1D0,QF)-4D0*QF*XW
17264 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17265 & VF**2*HF1W)+VQ**3*HF1W
17266 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17267 ENDIF
17268
17269C...Choice of jet configuration.
17270 CALL PYXJET(P(ID,5),NJET,CUT)
17271 KFLC=IABS(KFL1(1))
17272 KFLN=21
17273 IF(NJET.EQ.4) THEN
17274 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17275 ELSEIF(NJET.EQ.3) THEN
17276 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17277 ELSE
17278 MSTJ(120)=1
17279 ENDIF
17280
17281C...Fill jet configuration; return if incorrect kinematics.
17282 NC=N-2
17283 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17284 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17285 ELSEIF(NJET.EQ.2) THEN
17286 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17287 ELSEIF(NJET.EQ.3) THEN
17288 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17289 ELSEIF(KFLN.EQ.21) THEN
17290 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17291 & X12,X14)
17292 ELSE
17293 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17294 & X12,X14)
17295 ENDIF
17296 IF(MSTU(24).NE.0) THEN
17297 MINT(51)=1
17298 MSTU(111)=MST111
17299 PARU(112)=PAR112
17300 GOTO 720
17301 ENDIF
17302
17303C...Angular orientation according to matrix element.
17304 IF(MSTJ(106).EQ.1) THEN
17305 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17306 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17307 CTHE(1)=COS(THEZ)
17308 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17309 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17310 ENDIF
17311
17312C...Boost partons to Z0 rest frame.
17313 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17314 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17315
17316C...Mark decayed resonance and add documentation lines,
17317 K(ID,1)=K(ID,1)+10
17318 IDOC=MINT(83)+MINT(4)
17319 DO 360 I=NC+1,N
17320 I1=MINT(83)+MINT(4)+1
17321 K(I,3)=I1
17322 IF(MSTP(128).GE.1) K(I,3)=ID
17323 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17324 MINT(4)=MINT(4)+1
17325 K(I1,1)=21
17326 K(I1,2)=K(I,2)
17327 K(I1,3)=IREF(IP,4)
17328 DO 350 J=1,5
17329 P(I1,J)=P(I,J)
17330 350 CONTINUE
17331 ENDIF
17332 360 CONTINUE
17333
17334C...Generate parton shower.
17335 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17336 CALL PYSHOW(N-1,N,P(ID,5))
17337 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17338 NPART=2
17339 IPART(1)=N-1
17340 IPART(2)=N
17341 PTPART(1)=0.5D0*P(ID,5)
17342 PTPART(2)=PTPART(1)
17343 NCT=NCT+1
17344 IF(K(N-1,2).GT.0) THEN
17345 MCT(N-1,1)=NCT
17346 MCT(N,2)=NCT
17347 ELSE
17348 MCT(N-1,2)=NCT
17349 MCT(N,1)=NCT
17350 ENDIF
17351 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17352 ENDIF
17353
17354C... End special case for Z0: skip ahead.
17355 MSTU(111)=MST111
17356 PARU(112)=PAR112
17357 GOTO 700
17358 ENDIF
17359
17360C...Order incoming partons and outgoing resonances.
17361 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17362 &NINH.EQ.0) THEN
17363 ILIN(1)=MINT(84)+1
17364 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17365 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17366 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17367 ILIN(2)=2*MINT(84)+3-ILIN(1)
17368 IMIN=1
17369 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17370 & .EQ.36) IMIN=3
17371 IMAX=2
17372 IORD=1
17373 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17374 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17375 IAKIPD=IABS(K(IREF(IP,IORD),2))
17376 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17377 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17378
17379C...Order decay products of resonances.
17380 DO 370 JT=IORD,3-IORD,3-2*IORD
17381 IF(KDCY(JT).EQ.0) THEN
17382 ILIN(IMAX+1)=NSD(JT)
17383 IMAX=IMAX+1
17384 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
17385 ILIN(IMAX+1)=N+2*JT-1
17386 ILIN(IMAX+2)=N+2*JT
17387 IMAX=IMAX+2
17388 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17389 K(N+2*JT,2)=K(NSD(JT)+2,2)
17390 ELSE
17391 ILIN(IMAX+1)=N+2*JT
17392
17393 ILIN(IMAX+2)=N+2*JT-1
17394 IMAX=IMAX+2
17395 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17396 K(N+2*JT,2)=K(NSD(JT)+2,2)
17397 ENDIF
17398 370 CONTINUE
17399
17400C...Find charge, isospin, left- and righthanded couplings.
17401 DO 390 I=IMIN,IMAX
17402 DO 380 J=1,4
17403 COUP(I,J)=0D0
17404 380 CONTINUE
17405 KFA=IABS(K(ILIN(I),2))
17406 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
17407 COUP(I,1)=KCHG(KFA,1)/3D0
17408 COUP(I,2)=(-1)**MOD(KFA,2)
17409 COUP(I,4)=-2D0*COUP(I,1)*XWV
17410 COUP(I,3)=COUP(I,2)+COUP(I,4)
17411 390 CONTINUE
17412
17413C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17414 IF(ISUB.EQ.22) THEN
17415 DO 420 I=3,5,2
17416 I1=IORD
17417 IF(I.EQ.5) I1=3-IORD
17418 DO 410 J1=1,2
17419 DO 400 J2=1,2
17420 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
17421 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
17422 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
17423 & COUP(I,J2+2)**2
17424 400 CONTINUE
17425 410 CONTINUE
17426 420 CONTINUE
17427 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17428 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
17429 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
17430 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
17431
17432 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
17433 ENDIF
17434 ENDIF
17435
17436C...Select angular orientation type - Z'/W' only.
17437 MZPWP=0
17438 IF(ISUB.EQ.141) THEN
17439 IF(PYR(0).LT.PARU(130)) MZPWP=1
17440 IF(IP.EQ.2) THEN
17441 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
17442 IAKIR=IABS(K(IREF(2,2),2))
17443 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17444 IF(IAKIR.LE.20) MZPWP=2
17445 ENDIF
17446 IF(IP.GE.3) MZPWP=2
17447 ELSEIF(ISUB.EQ.142) THEN
17448 IF(PYR(0).LT.PARU(136)) MZPWP=1
17449 IF(IP.EQ.2) THEN
17450 IAKIR=IABS(K(IREF(2,2),2))
17451 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17452 IF(IAKIR.LE.20) MZPWP=2
17453 ENDIF
17454 IF(IP.GE.3) MZPWP=2
17455 ENDIF
17456
17457C...Select random angles (begin of weighting procedure).
17458 430 DO 440 JT=1,JTMAX
17459 IF(KDCY(JT).EQ.0) GOTO 440
17460 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
17461 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
17462 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
17463 PHI(JT)=VINT(24)
17464 ELSE
17465 CTHE(JT)=2D0*PYR(0)-1D0
17466 PHI(JT)=PARU(2)*PYR(0)
17467 ENDIF
17468 440 CONTINUE
17469
17470 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
17471C...Construct massless four-vectors.
17472 DO 460 I=N+1,N+4
17473 K(I,1)=1
17474 DO 450 J=1,5
17475 P(I,J)=0D0
17476 V(I,J)=0D0
17477 450 CONTINUE
17478 460 CONTINUE
17479 DO 470 JT=1,JTMAX
17480 IF(KDCY(JT).EQ.0) GOTO 470
17481 ID=IREF(IP,JT)
17482 P(N+2*JT-1,3)=0.5D0*P(ID,5)
17483 P(N+2*JT-1,4)=0.5D0*P(ID,5)
17484 P(N+2*JT,3)=-0.5D0*P(ID,5)
17485 P(N+2*JT,4)=0.5D0*P(ID,5)
17486 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
17487 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17488 470 CONTINUE
17489
17490C...Store incoming and outgoing momenta, with random rotation to
17491C...avoid accidental zeroes in HA expressions.
17492 IF(ISUB.NE.0) THEN
17493 DO 490 I=IMIN,IMAX
17494 K(N+4+I,1)=1
17495 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
17496 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
17497 P(N+4+I,5)=P(ILIN(I),5)
17498 DO 480 J=1,3
17499 P(N+4+I,J)=P(ILIN(I),J)
17500 480 CONTINUE
17501 490 CONTINUE
17502 500 THERR=ACOS(2D0*PYR(0)-1D0)
17503 PHIRR=PARU(2)*PYR(0)
17504 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
17505 DO 520 I=IMIN,IMAX
17506 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
17507 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
17508 DO 510 J=1,4
17509 PK(I,J)=P(N+4+I,J)
17510 510 CONTINUE
17511 520 CONTINUE
17512 ENDIF
17513
17514C...Calculate internal products.
17515 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
17516 & ISUB.EQ.142) THEN
17517 DO 540 I1=IMIN,IMAX-1
17518 DO 530 I2=I1+1,IMAX
17519 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
17520 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
17521 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
17522 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
17523 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
17524 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
17525 HC(I1,I2)=CONJG(HA(I1,I2))
17526 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
17527 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
17528 HA(I2,I1)=-HA(I1,I2)
17529 HC(I2,I1)=-HC(I1,I2)
17530 530 CONTINUE
17531 540 CONTINUE
17532 ENDIF
17533
17534C...Calculate four-products.
17535 IF(ISUB.NE.0) THEN
17536 DO 560 I=1,2
17537 DO 550 J=1,4
17538 PK(I,J)=-PK(I,J)
17539 550 CONTINUE
17540 560 CONTINUE
17541 DO 580 I1=IMIN,IMAX-1
17542 DO 570 I2=I1+1,IMAX
17543 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
17544 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
17545 PKK(I2,I1)=PKK(I1,I2)
17546 570 CONTINUE
17547 580 CONTINUE
17548 ENDIF
17549 ENDIF
17550
17551 KFAGM=IABS(IREF(IP,7))
17552 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
17553C...Isotropic decay selected by user.
17554 WT=1D0
17555 WTMAX=1D0
17556
17557 ELSEIF(JTMAX.EQ.3) THEN
17558C...Isotropic decay when three mother particles.
17559 WT=1D0
17560 WTMAX=1D0
17561
17562 ELSEIF(IT4.GE.1) THEN
17563C... Isotropic decay t -> b + W etc for 4th generation q and l.
17564 WT=1D0
17565 WTMAX=1D0
17566
17567 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
17568 & IREF(IP,7).EQ.36) THEN
17569C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
17570C...CP-odd case added by Kari Ertresvag Myklevoll.
17571C...Now also with mixed Higgs CP-states
17572 ETA=PARP(25)
17573 IF(IP.EQ.1) WTMAX=SH**2
17574 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
17575 KFA=IABS(K(IREF(IP,1),2))
17576 KFT=IABS(K(IREF(IP,2),2))
17577
17578 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
17579 & MSTP(25).GE.3) THEN
17580C...For mixed CP states need epsilon product.
17581 P10=PK(3,4)
17582 P20=PK(4,4)
17583 P30=PK(5,4)
17584 P40=PK(6,4)
17585 P11=PK(3,1)
17586 P21=PK(4,1)
17587 P31=PK(5,1)
17588 P41=PK(6,1)
17589 P12=PK(3,2)
17590 P22=PK(4,2)
17591 P32=PK(5,2)
17592 P42=PK(6,2)
17593 P13=PK(3,3)
17594 P23=PK(4,3)
17595 P33=PK(5,3)
17596 P43=PK(6,3)
17597 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17598 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17599 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17600 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17601 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17602 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17603 & P22*P30*P41+P13*P22*P31*P40
17604C...For mixed CP states need gauge boson masses.
17605 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17606 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17607 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17608 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17609 XMV=PMAS(KFA,1)
17610 ENDIF
17611
17612C...Z decay
17613 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
17614 KFLF1A=IABS(KFL1(1))
17615 EF1=KCHG(KFLF1A,1)/3D0
17616 AF1=SIGN(1D0,EF1+0.1D0)
17617 VF1=AF1-4D0*EF1*XWV
17618 KFLF2A=IABS(KFL1(2))
17619 EF2=KCHG(KFLF2A,1)/3D0
17620 AF2=SIGN(1D0,EF2+0.1D0)
17621 VF2=AF2-4D0*EF2*XWV
17622 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17623 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17624 & THEN
17625C...CP-even decay
17626 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17627 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17628 ELSEIF(MSTP(25).LE.2) THEN
17629C...CP-odd decay
17630 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17631 & -2*PKK(3,4)*PKK(5,6)
17632 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17633 & (PKK(3,4)*PKK(5,6))
17634 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17635 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17636 ELSE
17637C...Mixed CP states.
17638 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17639 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17640 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17641 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17642 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17643 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17644 & +PKK(3,4)*PKK(5,6)
17645 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17646 & +VA12AS*PKK(3,4)*PKK(5,6)
17647 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17648 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17649 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17650 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17651 ENDIF
17652
17653C...W decay
17654 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
17655 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17656 & THEN
17657C...CP-even decay
17658 WT=16D0*PKK(3,5)*PKK(4,6)
17659 ELSEIF(MSTP(25).LE.2) THEN
17660C...CP-odd decay
17661 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17662 & -2*PKK(3,4)*PKK(5,6)
17663 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17664 & (PKK(3,4)*PKK(5,6))
17665 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17666 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17667 ELSE
17668C...Mixed CP states.
17669 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17670 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17671 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17672 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17673 & +PKK(3,4)*PKK(5,6)
17674 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17675 & +PKK(3,4)*PKK(5,6)
17676 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17677 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17678 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17679 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17680 ENDIF
17681
17682C...No angular correlations in other Higgs decays.
17683 ELSE
17684 WT=WTMAX
17685 ENDIF
17686
17687 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17688 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17689 & THEN
17690C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17691 I1=IREF(IP,8)
17692 IF(MOD(KFAGM,2).EQ.0) THEN
17693 I2=N+1
17694 I3=N+2
17695 ELSE
17696 I2=N+2
17697 I3=N+1
17698 ENDIF
17699 I4=IREF(IP,2)
17700 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17701 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17702 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17703 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17704
17705 ELSEIF(ISUB.EQ.1) THEN
17706C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17707 EI=KCHG(IABS(MINT(15)),1)/3D0
17708 AI=SIGN(1D0,EI+0.1D0)
17709 VI=AI-4D0*EI*XWV
17710 EF=KCHG(IABS(KFL1(1)),1)/3D0
17711 AF=SIGN(1D0,EF+0.1D0)
17712
17713 VF=AF-4D0*EF*XWV
17714 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17715 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17716 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17717 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17718 & (VI**2+AI**2)*VINT(114)*VF**2)
17719 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17720 & 4D0*VI*AI*VINT(114)*VF*AF)
17721 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17722 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17723 WTMAX=2D0*(WT1+ABS(WT3))
17724
17725 ELSEIF(ISUB.EQ.2) THEN
17726C...Angular weight for W+/- -> 2 quarks/leptons.
17727 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17728 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17729 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17730 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17731 WTMAX=4D0
17732
17733 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17734C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17735C...-> gluon/gamma + 2 quarks/leptons.
17736 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17737 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17738 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17739 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17740 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17741 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17742 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17743 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17744 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17745 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17746 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17747 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17748 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17749 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17750 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17751 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17752
17753 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17754C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17755C...-> gluon/gamma + 2 quarks/leptons.
17756 WT=PKK(1,3)**2+PKK(2,4)**2
17757 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17758
17759 ELSEIF(ISUB.EQ.22) THEN
17760C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17761 S34=P(IREF(IP,IORD),5)**2
17762 S56=P(IREF(IP,3-IORD),5)**2
17763 TI=PKK(1,3)+PKK(1,4)+S34
17764 UI=PKK(1,5)+PKK(1,6)+S56
17765 TIR=REAL(TI)
17766 UIR=REAL(UI)
17767 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17768 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17769 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17770 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17771 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17772 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17773 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17774 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17775
17776 WT=
17777 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17778 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17779 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17780 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17781 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17782 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17783 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17784 & 1D0/UI**2))
17785
17786 ELSEIF(ISUB.EQ.23) THEN
17787C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17788 D34=P(IREF(IP,IORD),5)**2
17789 D56=P(IREF(IP,3-IORD),5)**2
17790 DT=PKK(1,3)+PKK(1,4)+D34
17791 DU=PKK(1,5)+PKK(1,6)+D56
17792 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17793 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17794 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17795 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17796
17797 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17798 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17799 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17800 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17801 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17802 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17803
17804 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17805C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17806C...(or H0, or A0).
17807 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17808 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17809 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17810 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17811 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17812
17813 ELSEIF(ISUB.EQ.25) THEN
17814C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17815 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17816 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17817 D34=P(IREF(IP,IORD),5)**2
17818 D56=P(IREF(IP,3-IORD),5)**2
17819 DT=PKK(1,3)+PKK(1,4)+D34
17820 DU=PKK(1,5)+PKK(1,6)+D56
17821 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17822 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17823 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17824 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17825 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17826 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17827 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17828 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17829 IF(MSTP(50).LE.0) THEN
17830 WT=FGK135**2+(CCWW*FGK253)**2
17831 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17832 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17833 & DJGK(DT,DU)))
17834 ELSE
17835 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17836 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17837 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17838 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17839 ENDIF
17840
17841 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17842C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17843C...(or H0, or A0).
17844 WT=PKK(1,3)*PKK(2,4)
17845 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17846
17847 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17848C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17849C...-> f + 2 quarks/leptons.
17850 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17851 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17852 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17853 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17854 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17855 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17856 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17857 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17858 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17859 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17860 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17861 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17862 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17863 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17864 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17865 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17866 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17867 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17868
17869 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17870C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17871 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17872 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17873 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17874
17875 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17876 & ISUB.EQ.77) THEN
17877C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17878 WT=16D0*PKK(3,5)*PKK(4,6)
17879 WTMAX=SH**2
17880
17881 ELSEIF(ISUB.EQ.110) THEN
17882C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17883 WT=1D0
17884 WTMAX=1D0
17885
17886 ELSEIF(ISUB.EQ.141) THEN
17887 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17888C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17889C...Couplings of incoming flavour.
17890 KFAI=IABS(MINT(15))
17891 EI=KCHG(KFAI,1)/3D0
17892 AI=SIGN(1D0,EI+0.1D0)
17893 VI=AI-4D0*EI*XWV
17894 KFAIC=1
17895 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17896 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17897 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17898 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17899 VPI=PARU(119+2*KFAIC)
17900 API=PARU(120+2*KFAIC)
17901 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17902 VPI=PARJ(178+2*KFAIC)
17903 API=PARJ(179+2*KFAIC)
17904 ELSE
17905 VPI=PARJ(186+2*KFAIC)
17906 API=PARJ(187+2*KFAIC)
17907 ENDIF
17908C...Couplings of final flavour.
17909 KFAF=IABS(KFL1(1))
17910 EF=KCHG(KFAF,1)/3D0
17911 AF=SIGN(1D0,EF+0.1D0)
17912 VF=AF-4D0*EF*XWV
17913 KFAFC=1
17914 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17915 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17916 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17917 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17918 VPF=PARU(119+2*KFAFC)
17919 APF=PARU(120+2*KFAFC)
17920 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17921 VPF=PARJ(178+2*KFAFC)
17922 APF=PARJ(179+2*KFAFC)
17923 ELSE
17924 VPF=PARJ(186+2*KFAFC)
17925 APF=PARJ(187+2*KFAFC)
17926 ENDIF
17927C...Asymmetry and weight.
17928 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17929 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17930 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17931 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17932 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17933 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17934 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17935 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17936 WTMAX=2D0+ABS(ASYM)
17937 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17938C...Angular weight for f + fbar -> Z' -> W+ + W-.
17939 RM1=P(NSD(1)+1,5)**2/SH
17940 RM2=P(NSD(1)+2,5)**2/SH
17941 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17942 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17943 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17944 & (RM2-RM1)**2)
17945 WT=CFLAT+CCOS2*CTHE(1)**2
17946 WTMAX=CFLAT+MAX(0D0,CCOS2)
17947 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17948 & IABS(KFL1(1)).EQ.37)) THEN
17949C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17950 WT=1D0-CTHE(1)**2
17951 WTMAX=1D0
17952 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17953C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17954 RM1=P(NSD(1)+1,5)**2/SH
17955 RM2=P(NSD(1)+2,5)**2/SH
17956 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17957 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17958 WTMAX=1D0+FLAM2/(8D0*RM1)
17959 ELSEIF(MZPWP.EQ.0) THEN
17960C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17961C...(W:s like if intermediate Z).
17962 D34=P(IREF(IP,IORD),5)**2
17963 D56=P(IREF(IP,3-IORD),5)**2
17964 DT=PKK(1,3)+PKK(1,4)+D34
17965 DU=PKK(1,5)+PKK(1,6)+D56
17966 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17967 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17968 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17969 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17970 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17971 ELSEIF(MZPWP.EQ.1) THEN
17972C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17973C...(W:s approximately longitudinal, like if intermediate H).
17974 WT=16D0*PKK(3,5)*PKK(4,6)
17975 WTMAX=SH**2
17976 ELSE
17977C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17978C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17979 WT=1D0
17980 WTMAX=1D0
17981 ENDIF
17982
17983 ELSEIF(ISUB.EQ.142) THEN
17984 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17985C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17986 KFAI=IABS(MINT(15))
17987 KFAIC=1
17988 IF(KFAI.GT.10) KFAIC=2
17989 VI=PARU(129+2*KFAIC)
17990 AI=PARU(130+2*KFAIC)
17991 KFAF=IABS(KFL1(1))
17992 KFAFC=1
17993 IF(KFAF.GT.10) KFAFC=2
17994 VF=PARU(129+2*KFAFC)
17995 AF=PARU(130+2*KFAFC)
17996 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
17997 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17998 WTMAX=2D0+ABS(ASYM)
17999 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18000C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18001 RM1=P(NSD(1)+1,5)**2/SH
18002 RM2=P(NSD(1)+2,5)**2/SH
18003 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18004 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18005 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18006 & (RM2-RM1)**2)
18007 WT=CFLAT+CCOS2*CTHE(1)**2
18008 WTMAX=CFLAT+MAX(0D0,CCOS2)
18009 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18010C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18011 RM1=P(NSD(1)+1,5)**2/SH
18012 RM2=P(NSD(1)+2,5)**2/SH
18013 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18014 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18015 WTMAX=1D0+FLAM2/(8D0*RM1)
18016 ELSEIF(MZPWP.EQ.0) THEN
18017C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18018C...(W/Z like if intermediate W).
18019 D34=P(IREF(IP,IORD),5)**2
18020 D56=P(IREF(IP,3-IORD),5)**2
18021 DT=PKK(1,3)+PKK(1,4)+D34
18022 DU=PKK(1,5)+PKK(1,6)+D56
18023 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18024 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18025 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18026 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18027 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18028 ELSEIF(MZPWP.EQ.1) THEN
18029C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18030C...(W/Z approximately longitudinal, like if intermediate H).
18031 WT=16D0*PKK(3,5)*PKK(4,6)
18032 WTMAX=SH**2
18033 ELSE
18034C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18035C...t + bbar -> t + W + bbar.
18036 WT=1D0
18037 WTMAX=1D0
18038 ENDIF
18039
18040 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18041 & THEN
18042C...Isotropic decay of leptoquarks (assumed spin 0).
18043 WT=1D0
18044 WTMAX=1D0
18045
18046 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18047C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18048 SIDE=1D0
18049 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18050 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18051 WT=1D0+SIDE*CTHE(1)
18052 WTMAX=2D0
18053 ELSEIF(IP.EQ.1) THEN
18054
18055 RM1=P(NSD(1)+1,5)**2/SH
18056 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18057 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18058 ELSE
18059C...W/Z decay assumed isotropic, since not known.
18060 WT=1D0
18061 WTMAX=1D0
18062 ENDIF
18063
18064 ELSEIF(ISUB.EQ.149) THEN
18065C...Isotropic decay of techni-eta.
18066 WT=1D0
18067 WTMAX=1D0
18068
18069 ELSEIF(ISUB.EQ.191) THEN
18070 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18071C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18072C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18073 WT=1D0-CTHE(1)**2
18074 WTMAX=1D0
18075 ELSEIF(IP.EQ.1) THEN
18076C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18077 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18078 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18079 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18080 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18081 KFAI=IABS(MINT(15))
18082 EI=KCHG(KFAI,1)/3D0
18083 AI=SIGN(1D0,EI+0.1D0)
18084 VI=AI-4D0*EI*XWV
18085 VALI=0.5D0*(VI+AI)
18086 VARI=0.5D0*(VI-AI)
18087 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18088 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18089 KFAF=IABS(KFL1(1))
18090 EF=KCHG(KFAF,1)/3D0
18091 AF=SIGN(1D0,EF+0.1D0)
18092 VF=AF-4D0*EF*XWV
18093 VALF=0.5D0*(VF+AF)
18094 VARF=0.5D0*(VF-AF)
18095 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18096 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18097 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18098 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18099 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18100 WTMAX=4D0*MAX(ASAME,AFLIP)
18101 ELSE
18102C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18103 WT=1D0
18104 WTMAX=1D0
18105 ENDIF
18106
18107 ELSEIF(ISUB.EQ.192) THEN
18108 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18109C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18110C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18111 WT=1D0-CTHE(1)**2
18112 WTMAX=1D0
18113 ELSEIF(IP.EQ.1) THEN
18114C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18115 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18116 WT=(1D0+CTHESG)**2
18117 WTMAX=4D0
18118 ELSE
18119C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18120 WT=1D0
18121 WTMAX=1D0
18122 ENDIF
18123
18124 ELSEIF(ISUB.EQ.193) THEN
18125 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18126C...Angular weight for f + fbar -> omega_tc0 ->
18127C...gamma pi_tc0 or Z0 pi_tc0.
18128 WT=1D0+CTHE(1)**2
18129 WTMAX=2D0
18130 ELSEIF(IP.EQ.1) THEN
18131C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18132 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18133 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18134 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18135 KFAI=IABS(MINT(15))
18136 EI=KCHG(KFAI,1)/3D0
18137 AI=SIGN(1D0,EI+0.1D0)
18138 VI=AI-4D0*EI*XWV
18139 VALI=0.5D0*(VI+AI)
18140 VARI=0.5D0*(VI-AI)
18141 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18142 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18143 KFAF=IABS(KFL1(1))
18144 EF=KCHG(KFAF,1)/3D0
18145 AF=SIGN(1D0,EF+0.1D0)
18146 VF=AF-4D0*EF*XWV
18147 VALF=0.5D0*(VF+AF)
18148 VARF=0.5D0*(VF-AF)
18149 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18150 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18151 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18152 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18153 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18154 WTMAX=4D0*MAX(BSAME,BFLIP)
18155 ELSE
18156C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18157 WT=1D0
18158 WTMAX=1D0
18159 ENDIF
18160
18161 ELSEIF(ISUB.EQ.353) THEN
18162C...Angular weight for Z_R0 -> 2 quarks/leptons.
18163 EI=KCHG(IABS(MINT(15)),1)/3D0
18164 AI=SIGN(1D0,EI+0.1D0)
18165 VI=AI-4D0*EI*XWV
18166 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18167 AF=SIGN(1D0,EF+0.1D0)
18168 VF=AF-4D0*EF*XWV
18169 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18170 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18171 WT2=RMF*(VI**2+AI**2)*VF**2
18172 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18173 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18174 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18175 WTMAX=2D0*(WT1+ABS(WT3))
18176
18177 ELSEIF(ISUB.EQ.354) THEN
18178C...Angular weight for W_R+/- -> 2 quarks/leptons.
18179 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18180 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18181 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18182 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18183 WTMAX=4D0
18184
18185 ELSEIF(ISUB.EQ.391) THEN
18186C...Angular weight for f + fbar -> G* -> f + fbar
18187 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18188 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18189 WTMAX=2D0
18190C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18191C...implemented by M.-C. Lemaire
18192 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18193 & IABS(KFL1(1)).EQ.22)) THEN
18194 WT=1D0-CTHE(1)**4
18195 WTMAX=1D0
18196C...Other G* decays not yet implemented angular distributions.
18197 ELSE
18198 WT=1D0
18199 WTMAX=1D0
18200 ENDIF
18201
18202 ELSEIF(ISUB.EQ.392) THEN
18203C...Angular weight for g + g -> G* -> f + fbar
18204 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18205 WT=1D0-CTHE(1)**4
18206 WTMAX=1D0
18207C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18208C...implemented by M.-C. Lemaire
18209 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18210 & IABS(KFL1(1)).EQ.22)) THEN
18211 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18212 WTMAX=8D0
18213C...Other G* decays not yet implemented angular distributions.
18214 ELSE
18215 WT=1D0
18216 WTMAX=1D0
18217 ENDIF
18218
18219C...Obtain correct angular distribution by rejection techniques.
18220 ELSE
18221 WT=1D0
18222 WTMAX=1D0
18223 ENDIF
18224 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18225
18226C...Construct massive four-vectors using angles chosen.
18227 590 DO 690 JT=1,JTMAX
18228 IF(KDCY(JT).EQ.0) GOTO 690
18229 ID=IREF(IP,JT)
18230 DO 600 J=1,5
18231 DPMO(J)=P(ID,J)
18232 600 CONTINUE
18233 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18234CMRENNA++
18235 IF(KFL3(JT).EQ.0) THEN
18236 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18237 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18238 N0=NSD(JT)+2
18239 ELSE
18240 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18241 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18242 N0=NSD(JT)+3
18243 ENDIF
18244
18245 DO 610 J=1,4
18246 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18247 610 CONTINUE
18248C...Fill in position of decay vertex.
18249 DO 630 I=NSD(JT)+1,N0
18250 DO 620 J=1,4
18251 V(I,J)=VDCY(J)
18252 620 CONTINUE
18253 V(I,5)=0D0
18254
18255 630 CONTINUE
18256CMRENNA--
18257
18258C...Mark decayed resonances; trace history.
18259 K(ID,1)=K(ID,1)+10
18260 KFA=IABS(K(ID,2))
18261 KCA=PYCOMP(KFA)
18262 IF(KCQM(JT).NE.0) THEN
18263C...Do not kill colour flow through coloured resonance!
18264 ELSE
18265 K(ID,4)=NSD(JT)+1
18266 K(ID,5)=NSD(JT)+2
18267C...If 3-body or 2-body with junction:
18268 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18269C...If 3-body with junction:
18270 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18271 ENDIF
18272
18273C...Add documentation lines.
18274 ISUBRG=MAX(1,MIN(500,MINT(1)))
18275 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18276 IDOC=MINT(83)+MINT(4)
18277CMRENNA+++
18278 IHI=NSD(JT)+2
18279 IF(KFL3(JT).NE.0) IHI=IHI+1
18280 DO 650 I=NSD(JT)+1,IHI
18281CMRENNA---
18282 I1=MINT(83)+MINT(4)+1
18283 K(I,3)=I1
18284 IF(MSTP(128).GE.1) K(I,3)=ID
18285 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18286 MINT(4)=MINT(4)+1
18287 K(I1,1)=21
18288 K(I1,2)=K(I,2)
18289 K(I1,3)=IREF(IP,JT+3)
18290 DO 640 J=1,5
18291 P(I1,J)=P(I,J)
18292 640 CONTINUE
18293 ENDIF
18294 650 CONTINUE
18295 ELSE
18296 K(NSD(JT)+1,3)=ID
18297 K(NSD(JT)+2,3)=ID
18298C...If 3-body or 2-body with junction:
18299 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18300C...If 3-body with junction:
18301 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18302 ENDIF
18303
18304C...Do showering of two or three objects.
18305 NSHBEF=N
18306 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18307 IF(KFL3(JT).EQ.0) THEN
18308 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18309 ELSE
18310 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18311 ENDIF
18312
18313c...For pT-ordered shower need set up first, especially colour tags.
18314C...(Need to set up colour tags even if MSTP(71) = 0)
18315 ELSEIF(MINT(35).GE.2) THEN
18316 NPART=2
18317 IF(KFL3(JT).NE.0) NPART=3
18318 IPART(1)=NSD(JT)+1
18319 IPART(2)=NSD(JT)+2
18320 IPART(3)=NSD(JT)+3
18321 PTPART(1)=0.5D0*P(ID,5)
18322 PTPART(2)=PTPART(1)
18323 PTPART(3)=PTPART(1)
18324 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18325 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18326 IF(MOTHER.LE.NSD(JT)) THEN
18327 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18328 ELSE
18329 NCT=NCT+1
18330 MCT(NSD(JT)+1,1)=NCT
18331 MCT(MOTHER,2)=NCT
18332 ENDIF
18333 ENDIF
18334 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18335 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18336 IF(MOTHER.LE.NSD(JT)) THEN
18337 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18338 ELSE
18339 NCT=NCT+1
18340 MCT(NSD(JT)+1,2)=NCT
18341 MCT(MOTHER,1)=NCT
18342 ENDIF
18343 ENDIF
18344 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18345 & KCQ2(JT).EQ.2)) THEN
18346 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18347 IF(MOTHER.LE.NSD(JT)) THEN
18348 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18349 ELSE
18350 NCT=NCT+1
18351 MCT(NSD(JT)+2,1)=NCT
18352 MCT(MOTHER,2)=NCT
18353 ENDIF
18354 ENDIF
18355 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18356 & KCQ2(JT).EQ.2)) THEN
18357 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18358 IF(MOTHER.LE.NSD(JT)) THEN
18359 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18360 ELSE
18361 NCT=NCT+1
18362 MCT(NSD(JT)+2,2)=NCT
18363 MCT(MOTHER,1)=NCT
18364 ENDIF
18365 ENDIF
18366 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18367 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18368 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18369 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18370 ENDIF
18371 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18372 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18373 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18374 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18375 ENDIF
18376 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18377 ENDIF
18378 NSHAFT=N
18379 IF(JT.EQ.1) NAFT1=N
18380
18381C...Check if decay products moved by shower.
18382 NSD1=NSD(JT)+1
18383 NSD2=NSD(JT)+2
18384 NSD3=NSD(JT)+3
18385 IF(NSHAFT.GT.NSHBEF) THEN
18386 IF(K(NSD1,1).GT.10) THEN
18387 DO 660 I=NSHBEF+1,NSHAFT
18388 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
18389 660 CONTINUE
18390 ENDIF
18391 IF(K(NSD2,1).GT.10) THEN
18392 DO 670 I=NSHBEF+1,NSHAFT
18393 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
18394 & I.NE.NSD1) NSD2=I
18395 670 CONTINUE
18396 ENDIF
18397 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
18398 DO 680 I=NSHBEF+1,NSHAFT
18399 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
18400 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
18401 680 CONTINUE
18402 ENDIF
18403 ENDIF
18404
18405C...Store decay products for further treatment.
18406 NP=NP+1
18407 IREF(NP,1)=NSD1
18408 IREF(NP,2)=NSD2
18409 IREF(NP,3)=0
18410 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
18411 IREF(NP,4)=IDOC+1
18412 IREF(NP,5)=IDOC+2
18413 IREF(NP,6)=0
18414 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
18415 IREF(NP,7)=K(IREF(IP,JT),2)
18416 IREF(NP,8)=IREF(IP,JT)
18417 690 CONTINUE
18418
18419
18420C...Fill information for 2 -> 1 -> 2.
18421 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
18422 MINT(7)=MINT(83)+6+2*ISET(ISUB)
18423 MINT(8)=MINT(83)+7+2*ISET(ISUB)
18424 MINT(25)=KFL1(1)
18425 MINT(26)=KFL2(1)
18426 VINT(23)=CTHE(1)
18427 RM3=P(N-1,5)**2/SH
18428 RM4=P(N,5)**2/SH
18429 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18430 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
18431 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
18432 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
18433 VINT(47)=SQRT(VINT(48))
18434 ENDIF
18435
18436C...Possibility of colour rearrangement in W+W- events.
18437 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
18438 IAKF1=IABS(KFL1(1))
18439 IAKF2=IABS(KFL1(2))
18440 IAKF3=IABS(KFL2(1))
18441 IAKF4=IABS(KFL2(2))
18442 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
18443 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
18444 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
18445 IF(MINT(51).NE.0) RETURN
18446 ENDIF
18447
18448C...Loop back if needed.
18449 710 IF(IP.LT.NP) GOTO 170
18450
18451C...Boost back to standard frame.
18452 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
18453 &BEZIN)
18454
18455 RETURN
18456 END
18457
18458C*********************************************************************
18459
18460C...PYMULT
18461C...Initializes treatment of multiple interactions, selects kinematics
18462C...of hardest interaction if low-pT physics included in run, and
18463C...generates all non-hardest interactions.
18464
18465 SUBROUTINE PYMULT(MMUL)
18466
18467C...Double precision and integer declarations.
18468 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18469 IMPLICIT INTEGER(I-N)
18470 INTEGER PYK,PYCHGE,PYCOMP
18471C...Commonblocks.
18472 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18473 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18474 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18475 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18476 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18477 COMMON/PYINT1/MINT(400),VINT(400)
18478 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18479 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18480 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18481 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18482 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
18483 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
18484C...Local arrays and saved variables.
18485 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
18486 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
18487 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
18488 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
18489
18490C...Initialization of multiple interaction treatment.
18491 IF(MMUL.EQ.1) THEN
18492 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
18493 ISUB=96
18494 MINT(1)=96
18495 VINT(63)=0D0
18496 VINT(64)=0D0
18497 VINT(143)=1D0
18498 VINT(144)=1D0
18499
18500C...Loop over phase space points: xT2 choice in 20 bins.
18501 100 SIGSUM=0D0
18502 DO 120 IXT2=1,20
18503 NMUL(IXT2)=MSTP(83)
18504 SIGM(IXT2)=0D0
18505 DO 110 ITRY=1,MSTP(83)
18506 RSCA=0.05D0*((21-IXT2)-PYR(0))
18507 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
18508 XT2=MAX(0.01D0*VINT(149),XT2)
18509 VINT(25)=XT2
18510
18511C...Choose tau and y*. Calculate cos(theta-hat).
18512 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18513 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18514 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18515 ELSE
18516 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18517 ENDIF
18518 VINT(21)=TAU
18519 CALL PYKLIM(2)
18520 RYST=PYR(0)
18521 MYST=1
18522 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18523 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18524 CALL PYKMAP(2,MYST,PYR(0))
18525 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18526
18527C...Calculate differential cross-section.
18528 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18529 CALL PYSIGH(NCHN,SIGS)
18530 SIGM(IXT2)=SIGM(IXT2)+SIGS
18531 110 CONTINUE
18532 SIGSUM=SIGSUM+SIGM(IXT2)
18533 120 CONTINUE
18534 SIGSUM=SIGSUM/(20D0*MSTP(83))
18535
18536C...Reject result if sigma(parton-parton) is smaller than hadronic one.
18537 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
18538 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
18539 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
18540 PARP(82)=0.9D0*PARP(82)
18541 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
18542 & VINT(2)
18543 GOTO 100
18544 ENDIF
18545 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
18546 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
18547
18548C...Start iteration to find k factor.
18549 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
18550 P83A=(1D0-PARP(83))**2
18551 P83B=2D0*PARP(83)*(1D0-PARP(83))
18552 P83C=PARP(83)**2
18553 CQ2I=1D0/PARP(84)**2
18554 CQ2R=2D0/(1D0+PARP(84)**2)
18555 SO=0.5D0
18556 XI=0D0
18557 YI=0D0
18558 XF=0D0
18559 YF=0D0
18560 XK=0.5D0
18561 IIT=0
18562 130 IF(IIT.EQ.0) THEN
18563 XK=2D0*XK
18564 ELSEIF(IIT.EQ.1) THEN
18565 XK=0.5D0*XK
18566 ELSE
18567 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
18568 ENDIF
18569
18570C...Evaluate overlap integrals. Find where to divide the b range.
18571 IF(MSTP(82).EQ.2) THEN
18572 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
18573 SOP=SP/PARU(1)
18574 ELSE
18575 IF(MSTP(82).EQ.3) THEN
18576 DELTAB=0.02D0
18577 ELSEIF(MSTP(82).EQ.4) THEN
18578 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
18579 ELSE
18580 POWIP=MAX(0.4D0,PARP(83))
18581 RPWIP=2D0/POWIP-1D0
18582 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
18583 SO=0D0
18584 ENDIF
18585 SP=0D0
18586 SOP=0D0
18587 BSP=0D0
18588 SOHIGH=0D0
18589 IBDIV=0
18590 B=-0.5D0*DELTAB
18591 140 B=B+DELTAB
18592 IF(MSTP(82).EQ.3) THEN
18593 OV=EXP(-B**2)/PARU(2)
18594 ELSEIF(MSTP(82).EQ.4) THEN
18595 OV=(P83A*EXP(-MIN(50D0,B**2))+
18596 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18597 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18598 ELSE
18599 OV=EXP(-B**POWIP)/PARU(2)
18600 SO=SO+PARU(2)*B*DELTAB*OV
18601 ENDIF
18602 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18603 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18604 SP=SP+PARU(2)*B*DELTAB*PACC
18605 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18606 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18607 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18608 IBDIV=1
18609 BDIV=B+0.5D0*DELTAB
18610 ENDIF
18611 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18612 ENDIF
18613 YK=PARU(1)*XK*SO/SP
18614
18615C...Continue iteration until convergence.
18616 IF(YK.LT.YKE) THEN
18617 XI=XK
18618 YI=YK
18619 IF(IIT.EQ.1) IIT=2
18620 ELSE
18621 XF=XK
18622 YF=YK
18623 IF(IIT.EQ.0) IIT=1
18624 ENDIF
18625 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18626
18627C...Store some results for subsequent use.
18628 BAVG=BSP/SP
18629 VINT(145)=SIGSUM
18630 VINT(146)=SOP/SO
18631 VINT(147)=SOP/SP
18632 VNT145=VINT(145)
18633 VNT146=VINT(146)
18634 VNT147=VINT(147)
18635C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18636 PIK=(VNT146/VNT147)*YKE
18637
18638C...Find relative weight for low and high impact parameter.
18639 PLOWB=PARU(1)*BDIV**2
18640 IF(MSTP(82).EQ.3) THEN
18641 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18642 ELSEIF(MSTP(82).EQ.4) THEN
18643 S4A=P83A*EXP(-BDIV**2)
18644 S4B=P83B*EXP(-BDIV**2*CQ2R)
18645 S4C=P83C*EXP(-BDIV**2*CQ2I)
18646 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18647 ELSEIF(PARP(83).GE.1.999D0) THEN
18648 PHIGHB=PIK*SOHIGH
18649 B2RPDV=BDIV**POWIP
18650 ELSE
18651 PHIGHB=PIK*SOHIGH
18652 B2RPDV=BDIV**POWIP
18653 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18654 ENDIF
18655 PALLB=PLOWB+PHIGHB
18656
18657C...Initialize iteration in xT2 for hardest interaction.
18658 ELSEIF(MMUL.EQ.2) THEN
18659 VINT(145)=VNT145
18660 VINT(146)=VNT146
18661 VINT(147)=VNT147
18662 IF(MSTP(82).LE.0) THEN
18663 ELSEIF(MSTP(82).EQ.1) THEN
18664 XT2=1D0
18665 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18666 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18667 & VINT(317)/(VINT(318)*VINT(320))
18668 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18669 ELSEIF(MSTP(82).EQ.2) THEN
18670 XT2=1D0
18671 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18672 & VINT(149)*(1D0+VINT(149))
18673 ELSE
18674 XC2=4D0*CKIN(3)**2/VINT(2)
18675 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18676 ENDIF
18677
18678C...Select impact parameter for hardest interaction.
18679 IF(MSTP(82).LE.2) RETURN
18680 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18681C...Treatment in low b region.
18682 MINT(39)=1
18683 B=BDIV*SQRT(PYR(0))
18684 IF(MSTP(82).EQ.3) THEN
18685 OV=EXP(-B**2)/PARU(2)
18686 ELSEIF(MSTP(82).EQ.4) THEN
18687 OV=(P83A*EXP(-MIN(50D0,B**2))+
18688 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18689 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18690 ELSE
18691 OV=EXP(-B**POWIP)/PARU(2)
18692 ENDIF
18693 VINT(148)=OV/VNT147
18694 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18695 XT2=1D0
18696 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18697 & VINT(149)*(1D0+VINT(149))
18698 ELSE
18699C...Treatment in high b region.
18700 MINT(39)=2
18701 IF(MSTP(82).EQ.3) THEN
18702 B=SQRT(BDIV**2-LOG(PYR(0)))
18703 OV=EXP(-B**2)/PARU(2)
18704 ELSEIF(MSTP(82).EQ.4) THEN
18705 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18706 IF(S4RNDM.LT.S4A) THEN
18707 B=SQRT(BDIV**2-LOG(PYR(0)))
18708 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18709 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18710 ELSE
18711 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18712 ENDIF
18713 OV=(P83A*EXP(-MIN(50D0,B**2))+
18714 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18715 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18716 ELSEIF(PARP(83).GE.1.999D0) THEN
18717 144 B2RPW=B2RPDV-LOG(PYR(0))
18718 ACCIP=(B2RPW/B2RPDV)**RPWIP
18719 IF(ACCIP.LT.PYR(0)) GOTO 144
18720 OV=EXP(-B2RPW)/PARU(2)
18721 B=B2RPW**(1D0/POWIP)
18722 ELSE
18723 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18724 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18725 IF(ACCIP.LT.PYR(0)) GOTO 146
18726 OV=EXP(-B2RPW)/PARU(2)
18727 B=B2RPW**(1D0/POWIP)
18728 ENDIF
18729 VINT(148)=OV/VNT147
18730 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18731 ENDIF
18732 IF(PACC.LT.PYR(0)) GOTO 142
18733 VINT(139)=B/BAVG
18734
18735 ELSEIF(MMUL.EQ.3) THEN
18736C...Low-pT or multiple interactions (first semihard interaction):
18737C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18738C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18739 ISUB=MINT(1)
18740 VINT(145)=VNT145
18741 VINT(146)=VNT146
18742 VINT(147)=VNT147
18743 IF(MSTP(82).LE.0) THEN
18744 XT2=0D0
18745 ELSEIF(MSTP(82).EQ.1) THEN
18746 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18747C...Use with "Sudakov" for low b values when impact parameter dependence.
18748 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18749 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18750 & VINT(149)))).GT.PYR(0)) XT2=1D0
18751 IF(XT2.GE.1D0) THEN
18752 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18753 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18754 & VINT(149)
18755 ELSE
18756 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18757 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18758 & VINT(149)
18759 ENDIF
18760 XT2=MAX(0.01D0*VINT(149),XT2)
18761C...Use without "Sudakov" for high b values when impact parameter dep.
18762 ELSE
18763 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18764 & PYR(0)*(1D0-XC2))-VINT(149)
18765 XT2=MAX(0.01D0*VINT(149),XT2)
18766 ENDIF
18767 VINT(25)=XT2
18768
18769C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18770 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18771 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18772 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18773 ISUB=95
18774 MINT(1)=ISUB
18775 VINT(21)=0.01D0*VINT(149)
18776 VINT(22)=0D0
18777 VINT(23)=0D0
18778 VINT(25)=0.01D0*VINT(149)
18779
18780 ELSE
18781C...Multiple interactions (first semihard interaction).
18782C...Choose tau and y*. Calculate cos(theta-hat).
18783 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18784 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18785 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18786 ELSE
18787 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18788 ENDIF
18789 VINT(21)=TAU
18790 CALL PYKLIM(2)
18791 RYST=PYR(0)
18792 MYST=1
18793 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18794 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18795 CALL PYKMAP(2,MYST,PYR(0))
18796 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18797 ENDIF
18798 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18799
18800C...Store results of cross-section calculation.
18801 ELSEIF(MMUL.EQ.4) THEN
18802 ISUB=MINT(1)
18803 VINT(145)=VNT145
18804 VINT(146)=VNT146
18805 VINT(147)=VNT147
18806 XTS=VINT(25)
18807 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18808 IF(ISET(ISUB).EQ.2)
18809 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18810 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18811 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18812 & (XTS+VINT(149))))
18813 IRBIN=INT(1D0+20D0*RBIN)
18814 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18815 NMUL(IRBIN)=NMUL(IRBIN)+1
18816 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18817 ENDIF
18818
18819C...Choose impact parameter if not already done.
18820 ELSEIF(MMUL.EQ.5) THEN
18821 ISUB=MINT(1)
18822 VINT(145)=VNT145
18823 VINT(146)=VNT146
18824 VINT(147)=VNT147
18825 150 IF(MINT(39).GT.0) THEN
18826 ELSEIF(MSTP(82).EQ.3) THEN
18827 EXPB2=PYR(0)
18828 B2=-LOG(PYR(0))
18829 VINT(148)=EXPB2/(PARU(2)*VNT147)
18830 VINT(139)=SQRT(B2)/BAVG
18831 ELSEIF(MSTP(82).EQ.4) THEN
18832 RTYPE=PYR(0)
18833 IF(RTYPE.LT.P83A) THEN
18834 B2=-LOG(PYR(0))
18835 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18836 B2=-LOG(PYR(0))/CQ2R
18837 ELSE
18838 B2=-LOG(PYR(0))/CQ2I
18839 ENDIF
18840 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18841 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18842 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18843 VINT(139)=SQRT(B2)/BAVG
18844 ELSEIF(PARP(83).GE.1.999D0) THEN
18845 POWIP=MAX(2D0,PARP(83))
18846 RPWIP=2D0/POWIP-1D0
18847 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18848 160 IF(PYR(0).LT.PROB1) THEN
18849 B2RPW=PYR(0)**(0.5D0*POWIP)
18850 ACCIP=EXP(-B2RPW)
18851 ELSE
18852 B2RPW=1D0-LOG(PYR(0))
18853 ACCIP=B2RPW**RPWIP
18854 ENDIF
18855 IF(ACCIP.LT.PYR(0)) GOTO 160
18856 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18857 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18858 ELSE
18859 POWIP=MAX(0.4D0,PARP(83))
18860 RPWIP=2D0/POWIP-1D0
18861 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18862 170 IF(PYR(0).LT.PROB1) THEN
18863 B2RPW=2D0*RPWIP*PYR(0)
18864 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18865 ELSE
18866 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18867 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18868 ENDIF
18869 IF(ACCIP.LT .PYR(0)) GOTO 170
18870 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18871 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18872 ENDIF
18873
18874C...Multiple interactions (variable impact parameter) : reject with
18875C...probability exp(-overlap*cross-section above pT/normalization).
18876C...Does not apply to low-b region, where "Sudakov" already included.
18877 VINT(150)=1D0
18878 IF(MINT(39).NE.1) THEN
18879 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18880 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18881 DO 180 IBIN=IRBIN+1,20
18882 RNCOR=RNCOR+NMUL(IBIN)
18883 SIGCOR=SIGCOR+SIGM(IBIN)
18884 180 CONTINUE
18885 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18886 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18887 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18888 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18889 ENDIF
18890 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18891 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18892 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18893 IF(VINT(150).LT.PYR(0)) GOTO 150
18894 VINT(150)=1D0
18895 ENDIF
18896
18897C...Generate additional multiple semihard interactions.
18898 ELSEIF(MMUL.EQ.6) THEN
18899 ISUBSV=MINT(1)
18900 VINT(145)=VNT145
18901 VINT(146)=VNT146
18902 VINT(147)=VNT147
18903 DO 190 J=11,80
18904 VINTSV(J)=VINT(J)
18905 190 CONTINUE
18906 ISUB=96
18907 MINT(1)=96
18908 VINT(151)=0D0
18909 VINT(152)=0D0
18910
18911C...Reconstruct strings in hard scattering.
18912 NMAX=MINT(84)+4
18913 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18914 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18915 NSTR=0
18916 DO 210 I=MINT(84)+1,NMAX
18917 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18918 IF(KCS.EQ.0) GOTO 210
18919 DO 200 J=1,4
18920 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18921 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18922 IF(J.LE.2) THEN
18923 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18924 ELSE
18925 IST=MOD(K(I,J+1),MSTU(5))
18926 ENDIF
18927 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18928 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18929 NSTR=NSTR+1
18930 IF(J.EQ.1.OR.J.EQ.4) THEN
18931 KSTR(NSTR,1)=I
18932 KSTR(NSTR,2)=IST
18933 ELSE
18934 KSTR(NSTR,1)=IST
18935 KSTR(NSTR,2)=I
18936 ENDIF
18937 200 CONTINUE
18938 210 CONTINUE
18939
18940C...Set up starting values for iteration in xT2.
18941 XT2=4D0*VINT(62)/VINT(2)
18942 IF(MSTP(82).LE.1) THEN
18943 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18944 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18945 & VINT(317)/(VINT(318)*VINT(320))
18946 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18947 ELSE
18948 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18949 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18950 ENDIF
18951 VINT(63)=0D0
18952 VINT(64)=0D0
18953 VINT(143)=1D0-VINT(141)
18954 VINT(144)=1D0-VINT(142)
18955
18956C...Iterate downwards in xT2.
18957 220 IF(MSTP(82).LE.1) THEN
18958 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18959 IF(XT2.LT.VINT(149)) GOTO 270
18960 ELSE
18961 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18962 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18963 & LOG(PYR(0)))-VINT(149)
18964 IF(XT2.LE.0D0) GOTO 270
18965 XT2=MAX(0.01D0*VINT(149),XT2)
18966 ENDIF
18967 VINT(25)=XT2
18968
18969C...Choose tau and y*. Calculate cos(theta-hat).
18970 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18971 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18972 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18973 ELSE
18974 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18975 ENDIF
18976 VINT(21)=TAU
18977 CALL PYKLIM(2)
18978 RYST=PYR(0)
18979 MYST=1
18980 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18981 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18982 CALL PYKMAP(2,MYST,PYR(0))
18983 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18984
18985C...Check that x not used up. Accept or reject kinematical variables.
18986 X1M=SQRT(TAU)*EXP(VINT(22))
18987 X2M=SQRT(TAU)*EXP(-VINT(22))
18988 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
18989 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18990 CALL PYSIGH(NCHN,SIGS)
18991 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
18992 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
18993
18994C...Reset K, P and V vectors. Select some variables.
18995 DO 240 I=N+1,N+2
18996 DO 230 J=1,5
18997 K(I,J)=0
18998 P(I,J)=0D0
18999 V(I,J)=0D0
19000 230 CONTINUE
19001 240 CONTINUE
19002 RFLAV=PYR(0)
19003 PT=0.5D0*VINT(1)*SQRT(XT2)
19004 PHI=PARU(2)*PYR(0)
19005 CTH=VINT(23)
19006
19007C...Add first parton to event record.
19008 K(N+1,1)=3
19009 K(N+1,2)=21
19010 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19011 & 1+INT((2D0+PARJ(2))*PYR(0))
19012 P(N+1,1)=PT*COS(PHI)
19013 P(N+1,2)=PT*SIN(PHI)
19014 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19015 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19016 P(N+1,5)=0D0
19017
19018C...Add second parton to event record.
19019 K(N+2,1)=3
19020 K(N+2,2)=21
19021 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19022 P(N+2,1)=-P(N+1,1)
19023 P(N+2,2)=-P(N+1,2)
19024 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19025 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19026 P(N+2,5)=0D0
19027
19028 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19029C....Choose relevant string pieces to place gluons on.
19030 DO 260 I=N+1,N+2
19031 DMIN=1D8
19032 DO 250 ISTR=1,NSTR
19033 I1=KSTR(ISTR,1)
19034 I2=KSTR(ISTR,2)
19035 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19036 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19037 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19038 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19039 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19040 DMIN=DIST
19041 IST1=I1
19042 IST2=I2
19043 ISTM=ISTR
19044 ENDIF
19045 250 CONTINUE
19046
19047C....Colour flow adjustments, new string pieces.
19048 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19049 & MOD(K(IST1,4),MSTU(5))
19050 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19051 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19052 K(I,5)=MSTU(5)*IST1
19053 K(I,4)=MSTU(5)*IST2
19054 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19055 & MOD(K(IST2,5),MSTU(5))
19056 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19057 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19058 KSTR(ISTM,2)=I
19059 KSTR(NSTR+1,1)=I
19060 KSTR(NSTR+1,2)=IST2
19061 NSTR=NSTR+1
19062 260 CONTINUE
19063
19064C...String drawing and colour flow for gluon loop.
19065 ELSEIF(K(N+1,2).EQ.21) THEN
19066 K(N+1,4)=MSTU(5)*(N+2)
19067 K(N+1,5)=MSTU(5)*(N+2)
19068 K(N+2,4)=MSTU(5)*(N+1)
19069 K(N+2,5)=MSTU(5)*(N+1)
19070 KSTR(NSTR+1,1)=N+1
19071 KSTR(NSTR+1,2)=N+2
19072 KSTR(NSTR+2,1)=N+2
19073 KSTR(NSTR+2,2)=N+1
19074 NSTR=NSTR+2
19075
19076C...String drawing and colour flow for qqbar pair.
19077 ELSE
19078 K(N+1,4)=MSTU(5)*(N+2)
19079 K(N+2,5)=MSTU(5)*(N+1)
19080 KSTR(NSTR+1,1)=N+1
19081 KSTR(NSTR+1,2)=N+2
19082 NSTR=NSTR+1
19083 ENDIF
19084
19085C...Global statistics.
19086 MINT(351)=MINT(351)+1
19087 VINT(351)=VINT(351)+PT
19088 IF (MINT(351).EQ.1) VINT(356)=PT
19089
19090C...Update remaining energy; iterate.
19091 N=N+2
19092 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19093 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19094 MINT(51)=1
19095 RETURN
19096 ENDIF
19097 MINT(31)=MINT(31)+1
19098 VINT(151)=VINT(151)+VINT(41)
19099 VINT(152)=VINT(152)+VINT(42)
19100 VINT(143)=VINT(143)-VINT(41)
19101 VINT(144)=VINT(144)-VINT(42)
19102C...Allow FSR for UE
19103 IF(MSTP(152).EQ.1) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19104 IF(MINT(31).LT.240) GOTO 220
19105 270 CONTINUE
19106 MINT(1)=ISUBSV
19107 DO 280 J=11,80
19108 VINT(J)=VINTSV(J)
19109 280 CONTINUE
19110 ENDIF
19111
19112C...Format statements for printout.
19113 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19114 &'actions for MSTP(82) =',I2,' ******')
19115 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19116 &D9.2,' mb: rejected')
19117 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19118 &D9.2,' mb: accepted')
19119
19120 RETURN
19121 END
19122
19123C*********************************************************************
19124
19125C...PYREMN
19126C...Adds on target remnants (one or two from each side) and
19127C...includes primordial kT for hadron beams.
19128
19129 SUBROUTINE PYREMN(IPU1,IPU2)
19130
19131C...Double precision and integer declarations.
19132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19133 IMPLICIT INTEGER(I-N)
19134 INTEGER PYK,PYCHGE,PYCOMP
19135C...Commonblocks.
19136 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19137 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19138 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19139 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19140 COMMON/PYINT1/MINT(400),VINT(400)
19141 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19142C...Local arrays.
19143 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19144 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19145
19146C...Find event type and remaining energy.
19147 ISUB=MINT(1)
19148 NS=N
19149 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19150 VINT(143)=1D0-VINT(141)
19151 VINT(144)=1D0-VINT(142)
19152 ENDIF
19153
19154C...Define initial partons.
19155 NTRY=0
19156 100 NTRY=NTRY+1
19157 DO 130 JT=1,2
19158 I=MINT(83)+JT+2
19159 IF(JT.EQ.1) IPU=IPU1
19160 IF(JT.EQ.2) IPU=IPU2
19161 K(I,1)=21
19162 K(I,2)=K(IPU,2)
19163 K(I,3)=I-2
19164 PMS(JT)=0D0
19165 VINT(156+JT)=0D0
19166 VINT(158+JT)=0D0
19167 IF(MINT(47).EQ.1) THEN
19168 DO 110 J=1,5
19169 P(I,J)=P(I-2,J)
19170 110 CONTINUE
19171 ELSEIF(ISUB.EQ.95) THEN
19172 K(I,2)=21
19173 ELSE
19174 P(I,5)=P(IPU,5)
19175
19176C...No primordial kT, or chosen according to truncated Gaussian or
19177C...exponential, or (for photon) predetermined or power law.
19178 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19179 IF(MSTP(91).LE.0) THEN
19180 PT=0D0
19181 ELSEIF(MSTP(91).EQ.1) THEN
19182 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19183 ELSE
19184 RPT1=PYR(0)
19185 RPT2=PYR(0)
19186 PT=-PARP(92)*LOG(RPT1*RPT2)
19187 ENDIF
19188 IF(PT.GT.PARP(93)) GOTO 120
19189 ELSEIF(MINT(106+JT).EQ.3) THEN
19190 PTA=SQRT(VINT(282+JT))
19191 PTB=0D0
19192 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19193 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19194 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19195 RPT1=PYR(0)
19196 RPT2=PYR(0)
19197 PTB=-PARP(99)*LOG(RPT1*RPT2)
19198 ENDIF
19199 IF(PTB.GT.PARP(100)) GOTO 120
19200 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19201 PT=PT*0.8D0**MINT(57)
19202 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19203 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19204 IF(MSTP(93).LE.0) THEN
19205 PT=0D0
19206 ELSEIF(MSTP(93).EQ.1) THEN
19207 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19208 ELSEIF(MSTP(93).EQ.2) THEN
19209 RPT1=PYR(0)
19210 RPT2=PYR(0)
19211 PT=-PARP(99)*LOG(RPT1*RPT2)
19212 ELSEIF(MSTP(93).EQ.3) THEN
19213 HA=PARP(99)**2
19214 HB=PARP(100)**2
19215 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19216 ELSE
19217 HA=PARP(99)**2
19218 HB=PARP(100)**2
19219 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19220 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19221 ENDIF
19222 IF(PT.GT.PARP(100)) GOTO 120
19223 ELSE
19224 PT=0D0
19225 ENDIF
19226 VINT(156+JT)=PT
19227 PHI=PARU(2)*PYR(0)
19228 P(I,1)=PT*COS(PHI)
19229 P(I,2)=PT*SIN(PHI)
19230 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19231 ENDIF
19232 130 CONTINUE
19233 IF(MINT(47).EQ.1) RETURN
19234
19235C...Kinematics construction for initial partons.
19236 I1=MINT(83)+3
19237 I2=MINT(83)+4
19238 IF(ISUB.EQ.95) THEN
19239 SHS=0D0
19240 SHR=0D0
19241 ELSE
19242 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19243 & (P(I1,2)+P(I2,2))**2
19244 SHR=SQRT(MAX(0D0,SHS))
19245 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19246 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19247 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19248 P(I2,4)=SHR-P(I1,4)
19249 P(I2,3)=-P(I1,3)
19250
19251C...Transform partons to overall CM-frame.
19252 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19253 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19254 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19255 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19256 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19257 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19258 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19259 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19260 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19261 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19262 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19263 ENDIF
19264
19265C...Optionally fix up x and Q2 definitions for leptoproduction.
19266 IDISXQ=0
19267 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19268 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19269 IF(IDISXQ.EQ.1) THEN
19270
19271C...Find where incoming and outgoing leptons/partons are sitting.
19272 LESD=1
19273 IF(MINT(42).EQ.1) LESD=2
19274 LPIN=MINT(83)+3-LESD
19275 LEIN=MINT(84)+LESD
19276 LQIN=MINT(84)+3-LESD
19277 LEOUT=MINT(84)+2+LESD
19278 LQOUT=MINT(84)+5-LESD
19279 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19280 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19281 LSCMS=0
19282 DO 140 I=MINT(84)+5,N
19283 IF(K(I,2).EQ.94) THEN
19284 LSCMS=I
19285 LEOUT=I+LESD
19286 LQOUT=I+3-LESD
19287 ENDIF
19288 140 CONTINUE
19289 LQBG=IPU1
19290 IF(LESD.EQ.1) LQBG=IPU2
19291
19292C...Calculate actual and wanted momentum transfer.
19293 XNOM=VINT(43-LESD)
19294 Q2NOM=-VINT(45)
19295 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19296 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19297 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19298 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19299 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19300 P(N+1,1)=FAC*P(LEOUT,1)
19301 P(N+1,2)=FAC*P(LEOUT,2)
19302 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19303 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19304 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19305 & P(N+1,3)**2)
19306 DO 150 J=1,4
19307 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19308 QNEW(J)=P(LEIN,J)-P(N+1,J)
19309 150 CONTINUE
19310
19311C...Boost outgoing electron and daughters.
19312 IF(LSCMS.EQ.0) THEN
19313 DO 160 J=1,4
19314 P(LEOUT,J)=P(N+1,J)
19315 160 CONTINUE
19316 ELSE
19317 DO 170 J=1,3
19318 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19319 170 CONTINUE
19320 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19321 DO 180 J=1,3
19322 DBE(J)=PINV*P(N+2,J)
19323 180 CONTINUE
19324 DO 200 I=LSCMS+1,N
19325 IORIG=I
19326 190 IORIG=K(IORIG,3)
19327 IF(IORIG.GT.LEOUT) GOTO 190
19328 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19329 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19330 200 CONTINUE
19331 ENDIF
19332
19333C...Copy shower initiator and all outgoing partons.
19334 NCOP=N+1
19335 K(NCOP,3)=LQBG
19336 DO 210 J=1,5
19337 P(NCOP,J)=P(LQBG,J)
19338 210 CONTINUE
19339 DO 240 I=MINT(84)+1,N
19340 ICOP=0
19341 IF(K(I,1).GT.10) GOTO 240
19342 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19343 ICOP=I
19344 ELSE
19345 IORIG=I
19346 220 IORIG=K(IORIG,3)
19347 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19348 ICOP=IORIG
19349 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19350 GOTO 220
19351 ENDIF
19352 ENDIF
19353 IF(ICOP.NE.0) THEN
19354 NCOP=NCOP+1
19355 K(NCOP,3)=I
19356 DO 230 J=1,5
19357 P(NCOP,J)=P(I,J)
19358 230 CONTINUE
19359 ENDIF
19360 240 CONTINUE
19361
19362C...Calculate relative rescaling factors.
19363 SLC=3-2*LESD
19364 PLCSUM=0D0
19365 DO 250 I=N+2,NCOP
19366 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
19367 250 CONTINUE
19368 DO 260 I=N+2,NCOP
19369 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
19370 260 CONTINUE
19371
19372C...Transfer extra three-momentum of current.
19373 DO 280 I=N+2,NCOP
19374 DO 270 J=1,3
19375 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
19376 270 CONTINUE
19377 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19378 280 CONTINUE
19379
19380C...Iterate change of initiator momentum to get energy right.
19381 ITER=0
19382 290 ITER=ITER+1
19383 PEEX=-P(N+1,4)-QNEW(4)
19384 PEMV=-P(N+1,3)/P(N+1,4)
19385 DO 300 I=N+2,NCOP
19386 PEEX=PEEX+P(I,4)
19387 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
19388 300 CONTINUE
19389 IF(ABS(PEMV).LT.1D-10) THEN
19390 MINT(51)=1
19391 MINT(57)=MINT(57)+1
19392 RETURN
19393 ENDIF
19394 PZCH=-PEEX/PEMV
19395 P(N+1,3)=P(N+1,3)+PZCH
19396 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)
19397 DO 310 I=N+2,NCOP
19398 P(I,3)=P(I,3)+V(I,1)*PZCH
19399 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19400 310 CONTINUE
19401 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
19402
19403C...Modify momenta in event record.
19404 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
19405 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
19406 IF(ABS(HBE).GE.1D0) THEN
19407 MINT(51)=1
19408 MINT(57)=MINT(57)+1
19409 RETURN
19410 ENDIF
19411 I=MINT(83)+5-LESD
19412 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
19413 DO 330 I=N+1,NCOP
19414 ICOP=K(I,3)
19415 DO 320 J=1,4
19416 P(ICOP,J)=P(I,J)
19417 320 CONTINUE
19418 330 CONTINUE
19419 ENDIF
19420
19421C...Check minimum invariant mass of remnant system(s).
19422 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
19423 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
19424 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19425 PMIN(0)=SQRT(PMS(0))
19426 DO 340 JT=1,2
19427 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
19428 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
19429 PMIN(JT)=0D0
19430 IF(MINT(44+JT).EQ.1) GOTO 340
19431 MINT(105)=MINT(102+JT)
19432 MINT(109)=MINT(106+JT)
19433 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
19434 IF(MINT(51).NE.0) THEN
19435 MINT(57)=MINT(57)+1
19436 RETURN
19437 ENDIF
19438 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
19439 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
19440 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
19441 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
19442 & P(MINT(83)+JT+2,2)**2)
19443 340 CONTINUE
19444 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
19445 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
19446 &PSYS(2,4))) THEN
19447 MINT(51)=1
19448 MINT(57)=MINT(57)+1
19449 RETURN
19450 ENDIF
19451
19452C...Loop over two remnants; skip if none there.
19453 I=NS
19454 DO 410 JT=1,2
19455 ISN(JT)=0
19456 IF(MINT(44+JT).EQ.1) GOTO 410
19457 IF(JT.EQ.1) IPU=IPU1
19458 IF(JT.EQ.2) IPU=IPU2
19459
19460C...Store first remnant parton.
19461 I=I+1
19462 IS(JT)=I
19463 ISN(JT)=1
19464 DO 350 J=1,5
19465 K(I,J)=0
19466 P(I,J)=0D0
19467 V(I,J)=0D0
19468 350 CONTINUE
19469 K(I,1)=1
19470 K(I,2)=KFLSP(JT)
19471 K(I,3)=MINT(83)+JT
19472 P(I,5)=PYMASS(K(I,2))
19473
19474C...First parton colour connections and kinematics.
19475 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
19476 IF(KCOL.EQ.2) THEN
19477 K(I,1)=3
19478 K(I,4)=MSTU(5)*IPU+IPU
19479 K(I,5)=MSTU(5)*IPU+IPU
19480 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19481 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19482 ELSEIF(KCOL.NE.0) THEN
19483 K(I,1)=3
19484 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
19485 K(I,KFLS+3)=IPU
19486 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19487 ENDIF
19488 IF(KFLCH(JT).EQ.0) THEN
19489 P(I,1)=-P(MINT(83)+JT+2,1)
19490 P(I,2)=-P(MINT(83)+JT+2,2)
19491 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19492 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19493 P(I,3)=PSYS(JT,3)
19494 P(I,4)=PSYS(JT,4)
19495
19496C...When extra remnant parton or hadron: store extra remnant.
19497 ELSE
19498 I=I+1
19499 ISN(JT)=2
19500 DO 360 J=1,5
19501 K(I,J)=0
19502 P(I,J)=0D0
19503 V(I,J)=0D0
19504 360 CONTINUE
19505 K(I,1)=1
19506 K(I,2)=KFLCH(JT)
19507 K(I,3)=MINT(83)+JT
19508 P(I,5)=PYMASS(K(I,2))
19509
19510C...Find parton colour connections of extra remnant.
19511 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
19512 IF(KCOL.EQ.2) THEN
19513 K(I,1)=3
19514 K(I,4)=MSTU(5)*IPU+IPU
19515 K(I,5)=MSTU(5)*IPU+IPU
19516 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19517 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19518 ELSEIF(KCOL.NE.0) THEN
19519 K(I,1)=3
19520 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
19521 K(I,KFLS+3)=IPU
19522 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19523 ENDIF
19524
19525C...Relative transverse momentum when two remnants.
19526 LOOP=0
19527 370 LOOP=LOOP+1
19528 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
19529 IF(IABS(MINT(10+JT)).LT.20) THEN
19530 P(I-1,1)=0D0
19531 P(I-1,2)=0D0
19532 ELSE
19533 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
19534 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
19535 ENDIF
19536 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
19537 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
19538 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
19539 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19540
19541C...Meson or baryon; photon as meson. For splitup below.
19542 IMB=1
19543 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
19544
19545C***Relative distribution for electron into two electrons. Temporary!
19546 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
19547 & THEN
19548 CHI(JT)=PYR(0)
19549
19550C...Relative distribution of electron energy into electron plus parton.
19551 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
19552 XHRD=VINT(140+JT)
19553 XE=VINT(154+JT)
19554 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
19555
19556C...Relative distribution of energy for particle into two jets.
19557 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
19558 CHIK=PARP(92+2*IMB)
19559 IF(MSTP(92).LE.1) THEN
19560 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19561 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19562 ELSEIF(MSTP(92).EQ.2) THEN
19563 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
19564 ELSEIF(MSTP(92).EQ.3) THEN
19565 CUT=2D0*0.3D0/VINT(1)
19566 380 CHI(JT)=PYR(0)**2
19567 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
19568 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
19569 ELSEIF(MSTP(92).EQ.4) THEN
19570 CUT=2D0*0.3D0/VINT(1)
19571 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
19572 390 CHIR=CUT*CUTR**PYR(0)
19573 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
19574 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
19575 ELSE
19576 CUT=2D0*0.3D0/VINT(1)
19577 CUTA=CUT**(1D0-PARP(98))
19578 CUTB=(1D0+CUT)**(1D0-PARP(98))
19579 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
19580 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
19581 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
19582 ENDIF
19583
19584C...Relative distribution of energy for particle into jet plus particle.
19585 ELSE
19586 IF(MSTP(94).LE.1) THEN
19587 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19588 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19589 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19590 ELSEIF(MSTP(94).EQ.2) THEN
19591 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
19592 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19593 ELSEIF(MSTP(94).EQ.3) THEN
19594 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19595 CHI(JT)=ZZ
19596 ELSE
19597 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19598 CHI(JT)=ZZ
19599 ENDIF
19600 ENDIF
19601
19602C...Construct total transverse mass; reject if too large.
19603 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19604 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19605 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19606 IF(LOOP.LT.100) THEN
19607 GOTO 370
19608 ELSE
19609 MINT(51)=1
19610 MINT(57)=MINT(57)+1
19611 RETURN
19612 ENDIF
19613 ENDIF
19614 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19615 VINT(158+JT)=CHI(JT)
19616
19617C...Subdivide longitudinal momentum according to value selected above.
19618 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19619 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19620 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19621 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19622 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19623 ENDIF
19624 410 CONTINUE
19625 N=I
19626
19627C...Check if longitudinal boosts needed - if so pick two systems.
19628 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19629 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19630 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19631 IF(ISN(1).EQ.0) THEN
19632 IR=0
19633 IL=2
19634 ELSEIF(ISN(2).EQ.0) THEN
19635 IR=1
19636 IL=0
19637 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19638 IR=1
19639 IL=2
19640 ELSEIF(VINT(143).GT.0.2D0) THEN
19641 IR=1
19642 IL=0
19643 ELSEIF(VINT(144).GT.0.2D0) THEN
19644 IR=0
19645 IL=2
19646 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19647 IR=1
19648 IL=0
19649 ELSE
19650 IR=0
19651 IL=2
19652 ENDIF
19653 IG=3-IR-IL
19654
19655C...E+-pL wanted for system to be modified.
19656 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19657 PPB=VINT(1)
19658 PNB=VINT(1)
19659 ELSE
19660 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19661 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19662 ENDIF
19663
19664C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19665 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19666 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19667 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19668 DO 420 J=1,4
19669 PSYS(0,J)=0D0
19670 420 CONTINUE
19671 DO 450 I=MINT(84)+1,NS
19672 IF(K(I,1).GT.10) GOTO 450
19673 INCL=0
19674 IORIG=I
19675 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19676 IORIG=K(IORIG,3)
19677 IF(IORIG.GT.LPIN) GOTO 430
19678 IF(INCL.EQ.0) GOTO 450
19679 DO 440 J=1,4
19680 PSYS(0,J)=PSYS(0,J)+P(I,J)
19681 440 CONTINUE
19682 450 CONTINUE
19683 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19684 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19685 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19686 ENDIF
19687
19688C...Construct longitudinal boosts.
19689 DPMTB=PPB*PNB
19690 DPMTR=PMS(IR)
19691 DPMTL=PMS(IL)
19692 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19693 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19694 MINT(51)=1
19695 MINT(57)=MINT(57)+1
19696 RETURN
19697 ENDIF
19698 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19699 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19700 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19701 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19702 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19703 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19704 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19705
19706C...Perform longitudinal boosts.
19707 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19708 P(IS(1),3)=0D0
19709 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19710 ELSEIF(IR.EQ.1) THEN
19711 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19712 ELSEIF(IDISXQ.EQ.1) THEN
19713 DO 470 I=I1,NS
19714 INCL=0
19715 IORIG=I
19716 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19717 IORIG=K(IORIG,3)
19718 IF(IORIG.GT.LPIN) GOTO 460
19719 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19720 470 CONTINUE
19721 ELSE
19722 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19723 ENDIF
19724 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19725 P(IS(2),3)=0D0
19726 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19727 ELSEIF(IL.EQ.2) THEN
19728 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19729 ELSEIF(IDISXQ.EQ.1) THEN
19730 DO 490 I=I1,NS
19731 INCL=0
19732 IORIG=I
19733 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19734 IORIG=K(IORIG,3)
19735 IF(IORIG.GT.LPIN) GOTO 480
19736 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19737 490 CONTINUE
19738 ELSE
19739 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19740 ENDIF
19741
19742C...Final check that energy-momentum conservation worked.
19743 PESUM=0D0
19744 PZSUM=0D0
19745 DO 500 I=MINT(84)+1,N
19746 IF(K(I,1).GT.10) GOTO 500
19747 PESUM=PESUM+P(I,4)
19748 PZSUM=PZSUM+P(I,3)
19749 500 CONTINUE
19750 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19751 IF(PDEV.GT.1D-4*VINT(1)) THEN
19752 MINT(51)=1
19753 MINT(57)=MINT(57)+1
19754 RETURN
19755 ENDIF
19756
19757C...Calculate rotation and boost from overall CM frame to
19758C...hadronic CM frame in leptoproduction.
19759 MINT(91)=0
19760 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19761 MINT(91)=1
19762 LESD=1
19763 IF(MINT(42).EQ.1) LESD=2
19764 LPIN=MINT(83)+3-LESD
19765
19766C...Sum upp momenta of everything not lepton or photon to define boost.
19767 DO 510 J=1,4
19768 PSUM(J)=0D0
19769 510 CONTINUE
19770 DO 530 I=1,N
19771 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19772 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19773 IF(K(I,2).EQ.22) GOTO 530
19774 DO 520 J=1,4
19775 PSUM(J)=PSUM(J)+P(I,J)
19776 520 CONTINUE
19777 530 CONTINUE
19778 VINT(223)=-PSUM(1)/PSUM(4)
19779 VINT(224)=-PSUM(2)/PSUM(4)
19780 VINT(225)=-PSUM(3)/PSUM(4)
19781
19782C...Boost incoming hadron to hadronic CM frame to determine rotations.
19783 K(N+1,1)=1
19784 DO 540 J=1,5
19785 P(N+1,J)=P(LPIN,J)
19786 V(N+1,J)=V(LPIN,J)
19787 540 CONTINUE
19788 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19789 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19790 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19791 IF(LESD.EQ.2) THEN
19792 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19793 ELSE
19794 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19795 ENDIF
19796 ENDIF
19797
19798 RETURN
19799 END
19800
19801C*********************************************************************
19802
19803C...PYMIGN
19804C...Initializes treatment of new multiple interactions scenario,
19805C...selects kinematics of hardest interaction if low-pT physics
19806C...included in run, and generates all non-hardest interactions.
19807
19808 SUBROUTINE PYMIGN(MMUL)
19809
19810C...Double precision and integer declarations.
19811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19812 IMPLICIT INTEGER(I-N)
19813 INTEGER PYK,PYCHGE,PYCOMP
19814 EXTERNAL PYALPS
19815 DOUBLE PRECISION PYALPS
19816C...Commonblocks.
19817 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19820 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19821 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19822 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19823 COMMON/PYINT1/MINT(400),VINT(400)
19824 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19825 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19826 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19827 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19828 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19829 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19830 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19831 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19832 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19833C...Local arrays and saved variables.
19834 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19835 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19836 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19837 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19838 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19839
19840C...Initialization of multiple interaction treatment.
19841 IF(MMUL.EQ.1) THEN
19842 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19843 ISUB=96
19844 MINT(1)=96
19845 VINT(63)=0D0
19846 VINT(64)=0D0
19847 VINT(143)=1D0
19848 VINT(144)=1D0
19849
19850C...Loop over phase space points: xT2 choice in 20 bins.
19851 100 SIGSUM=0D0
19852 DO 120 IXT2=1,20
19853 NMUL(IXT2)=MSTP(83)
19854 SIGM(IXT2)=0D0
19855 DO 110 ITRY=1,MSTP(83)
19856 RSCA=0.05D0*((21-IXT2)-PYR(0))
19857 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19858 XT2=MAX(0.01D0*VINT(149),XT2)
19859 VINT(25)=XT2
19860
19861C...Choose tau and y*. Calculate cos(theta-hat).
19862 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19863 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19864 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19865 ELSE
19866 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19867 ENDIF
19868 VINT(21)=TAU
19869 CALL PYKLIM(2)
19870 RYST=PYR(0)
19871 MYST=1
19872 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19873 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19874 CALL PYKMAP(2,MYST,PYR(0))
19875 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19876
19877C...Calculate differential cross-section.
19878 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19879 CALL PYSIGH(NCHN,SIGS)
19880 SIGM(IXT2)=SIGM(IXT2)+SIGS
19881 110 CONTINUE
19882 SIGSUM=SIGSUM+SIGM(IXT2)
19883 120 CONTINUE
19884 SIGSUM=SIGSUM/(20D0*MSTP(83))
19885
19886C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19887 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19888 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19889 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19890 PARP(82)=0.9D0*PARP(82)
19891 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19892 & VINT(2)
19893 GOTO 100
19894 ENDIF
19895 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19896 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19897
19898C...Start iteration to find k factor.
19899 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19900 P83A=(1D0-PARP(83))**2
19901 P83B=2D0*PARP(83)*(1D0-PARP(83))
19902 P83C=PARP(83)**2
19903 CQ2I=1D0/PARP(84)**2
19904 CQ2R=2D0/(1D0+PARP(84)**2)
19905 SO=0.5D0
19906 XI=0D0
19907 YI=0D0
19908 XF=0D0
19909 YF=0D0
19910 XK=0.5D0
19911 IIT=0
19912 130 IF(IIT.EQ.0) THEN
19913 XK=2D0*XK
19914 ELSEIF(IIT.EQ.1) THEN
19915 XK=0.5D0*XK
19916 ELSE
19917 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19918 ENDIF
19919
19920C...Evaluate overlap integrals. Find where to divide the b range.
19921 IF(MSTP(82).EQ.2) THEN
19922 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19923 SOP=SP/PARU(1)
19924 ELSE
19925 IF(MSTP(82).EQ.3) THEN
19926 DELTAB=0.02D0
19927 ELSEIF(MSTP(82).EQ.4) THEN
19928 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19929 ELSE
19930 POWIP=MAX(0.4D0,PARP(83))
19931 RPWIP=2D0/POWIP-1D0
19932 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19933 SO=0D0
19934 ENDIF
19935 SP=0D0
19936 SOP=0D0
19937 BSP=0D0
19938 SOHIGH=0D0
19939 IBDIV=0
19940 B=-0.5D0*DELTAB
19941 140 B=B+DELTAB
19942 IF(MSTP(82).EQ.3) THEN
19943 OV=EXP(-B**2)/PARU(2)
19944 ELSEIF(MSTP(82).EQ.4) THEN
19945 OV=(P83A*EXP(-MIN(50D0,B**2))+
19946 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19947 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19948 ELSE
19949 OV=EXP(-B**POWIP)/PARU(2)
19950 SO=SO+PARU(2)*B*DELTAB*OV
19951 ENDIF
19952 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19953 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19954 SP=SP+PARU(2)*B*DELTAB*PACC
19955 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19956 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19957 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19958 IBDIV=1
19959 BDIV=B+0.5D0*DELTAB
19960 ENDIF
19961 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19962 ENDIF
19963 YK=PARU(1)*XK*SO/SP
19964
19965C...Continue iteration until convergence.
19966 IF(YK.LT.YKE) THEN
19967 XI=XK
19968 YI=YK
19969 IF(IIT.EQ.1) IIT=2
19970 ELSE
19971 XF=XK
19972 YF=YK
19973 IF(IIT.EQ.0) IIT=1
19974 ENDIF
19975 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19976
19977C...Store some results for subsequent use.
19978 BAVG=BSP/SP
19979 VINT(145)=SIGSUM
19980 VINT(146)=SOP/SO
19981 VINT(147)=SOP/SP
19982 VNT145=VINT(145)
19983 VNT146=VINT(146)
19984 VNT147=VINT(147)
19985C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19986 PIK=(VNT146/VNT147)*YKE
19987
19988C...Find relative weight for low and high impact parameter..
19989 PLOWB=PARU(1)*BDIV**2
19990 IF(MSTP(82).EQ.3) THEN
19991 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19992 ELSEIF(MSTP(82).EQ.4) THEN
19993 S4A=P83A*EXP(-BDIV**2)
19994 S4B=P83B*EXP(-BDIV**2*CQ2R)
19995 S4C=P83C*EXP(-BDIV**2*CQ2I)
19996 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19997 ELSEIF(PARP(83).GE.1.999D0) THEN
19998 PHIGHB=PIK*SOHIGH
19999 B2RPDV=BDIV**POWIP
20000 ELSE
20001 PHIGHB=PIK*SOHIGH
20002 B2RPDV=BDIV**POWIP
20003 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20004 ENDIF
20005 PALLB=PLOWB+PHIGHB
20006
20007C...Initialize iteration in xT2 for hardest interaction.
20008 ELSEIF(MMUL.EQ.2) THEN
20009 VINT(145)=VNT145
20010 VINT(146)=VNT146
20011 VINT(147)=VNT147
20012 IF(MSTP(82).LE.0) THEN
20013 ELSEIF(MSTP(82).EQ.1) THEN
20014 XT2=1D0
20015 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20016 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20017 & VINT(317)/(VINT(318)*VINT(320))
20018 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20019 ELSEIF(MSTP(82).EQ.2) THEN
20020 XT2=1D0
20021 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20022 & VINT(149)*(1D0+VINT(149))
20023 ELSE
20024 XC2=4D0*CKIN(3)**2/VINT(2)
20025 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20026 ENDIF
20027
20028C...Select impact parameter for hardest interaction.
20029 IF(MSTP(82).LE.2) RETURN
20030 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20031C...Treatment in low b region.
20032 MINT(39)=1
20033 B=BDIV*SQRT(PYR(0))
20034 IF(MSTP(82).EQ.3) THEN
20035 OV=EXP(-B**2)/PARU(2)
20036 ELSEIF(MSTP(82).EQ.4) THEN
20037 OV=(P83A*EXP(-MIN(50D0,B**2))+
20038 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20039 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20040 ELSE
20041 OV=EXP(-B**POWIP)/PARU(2)
20042 ENDIF
20043 VINT(148)=OV/VNT147
20044 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20045 XT2=1D0
20046 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20047 & VINT(149)*(1D0+VINT(149))
20048 ELSE
20049C...Treatment in high b region.
20050 MINT(39)=2
20051 IF(MSTP(82).EQ.3) THEN
20052 B=SQRT(BDIV**2-LOG(PYR(0)))
20053 OV=EXP(-B**2)/PARU(2)
20054 ELSEIF(MSTP(82).EQ.4) THEN
20055 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20056 IF(S4RNDM.LT.S4A) THEN
20057 B=SQRT(BDIV**2-LOG(PYR(0)))
20058 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20059 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20060 ELSE
20061 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20062 ENDIF
20063 OV=(P83A*EXP(-MIN(50D0,B**2))+
20064 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20065 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20066 ELSEIF(PARP(83).GE.1.999D0) THEN
20067 144 B2RPW=B2RPDV-LOG(PYR(0))
20068 ACCIP=(B2RPW/B2RPDV)**RPWIP
20069 IF(ACCIP.LT.PYR(0)) GOTO 144
20070 OV=EXP(-B2RPW)/PARU(2)
20071 B=B2RPW**(1D0/POWIP)
20072 ELSE
20073 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20074 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20075 IF(ACCIP.LT.PYR(0)) GOTO 146
20076 OV=EXP(-B2RPW)/PARU(2)
20077 B=B2RPW**(1D0/POWIP)
20078 ENDIF
20079 VINT(148)=OV/VNT147
20080 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20081 ENDIF
20082 IF(PACC.LT.PYR(0)) GOTO 142
20083 VINT(139)=B/BAVG
20084
20085 ELSEIF(MMUL.EQ.3) THEN
20086C...Low-pT or multiple interactions (first semihard interaction):
20087C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20088C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20089 ISUB=MINT(1)
20090 VINT(145)=VNT145
20091 VINT(146)=VNT146
20092 VINT(147)=VNT147
20093 IF(MSTP(82).LE.0) THEN
20094 XT2=0D0
20095 ELSEIF(MSTP(82).EQ.1) THEN
20096 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20097C...Use with "Sudakov" for low b values when impact parameter dependence.
20098 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20099 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20100 & VINT(149)))).GT.PYR(0)) XT2=1D0
20101 IF(XT2.GE.1D0) THEN
20102 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20103 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20104 & VINT(149)
20105 ELSE
20106 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20107 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20108 & VINT(149)
20109 ENDIF
20110 XT2=MAX(0.01D0*VINT(149),XT2)
20111C...Use without "Sudakov" for high b values when impact parameter dep.
20112 ELSE
20113 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20114 & PYR(0)*(1D0-XC2))-VINT(149)
20115 XT2=MAX(0.01D0*VINT(149),XT2)
20116 ENDIF
20117 VINT(25)=XT2
20118
20119C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20120 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20121 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20122 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20123 ISUB=95
20124 MINT(1)=ISUB
20125 VINT(21)=1D-12*VINT(149)
20126 VINT(22)=0D0
20127 VINT(23)=0D0
20128 VINT(25)=1D-12*VINT(149)
20129
20130 ELSE
20131C...Multiple interactions (first semihard interaction).
20132C...Choose tau and y*. Calculate cos(theta-hat).
20133 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20134 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20135 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20136 ELSE
20137 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20138 ENDIF
20139 VINT(21)=TAU
20140 CALL PYKLIM(2)
20141 RYST=PYR(0)
20142 MYST=1
20143 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20144 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20145 CALL PYKMAP(2,MYST,PYR(0))
20146 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20147 ENDIF
20148 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20149
20150C...Store results of cross-section calculation.
20151 ELSEIF(MMUL.EQ.4) THEN
20152 ISUB=MINT(1)
20153 VINT(145)=VNT145
20154 VINT(146)=VNT146
20155 VINT(147)=VNT147
20156 XTS=VINT(25)
20157 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20158 IF(ISET(ISUB).EQ.2)
20159 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20160 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20161 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20162 & (XTS+VINT(149))))
20163 IRBIN=INT(1D0+20D0*RBIN)
20164 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20165 NMUL(IRBIN)=NMUL(IRBIN)+1
20166 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20167 ENDIF
20168
20169C...Choose impact parameter if not already done.
20170 ELSEIF(MMUL.EQ.5) THEN
20171 ISUB=MINT(1)
20172 VINT(145)=VNT145
20173 VINT(146)=VNT146
20174 VINT(147)=VNT147
20175 150 IF(MINT(39).GT.0) THEN
20176 ELSEIF(MSTP(82).EQ.3) THEN
20177 EXPB2=PYR(0)
20178 B2=-LOG(PYR(0))
20179 VINT(148)=EXPB2/(PARU(2)*VNT147)
20180 VINT(139)=SQRT(B2)/BAVG
20181 ELSEIF(MSTP(82).EQ.4) THEN
20182 RTYPE=PYR(0)
20183 IF(RTYPE.LT.P83A) THEN
20184 B2=-LOG(PYR(0))
20185 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20186 B2=-LOG(PYR(0))/CQ2R
20187 ELSE
20188 B2=-LOG(PYR(0))/CQ2I
20189 ENDIF
20190 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20191 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20192 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20193 VINT(139)=SQRT(B2)/BAVG
20194 ELSEIF(PARP(83).GE.1.999D0) THEN
20195 POWIP=MAX(2D0,PARP(83))
20196 RPWIP=2D0/POWIP-1D0
20197 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20198 160 IF(PYR(0).LT.PROB1) THEN
20199 B2RPW=PYR(0)**(0.5D0*POWIP)
20200 ACCIP=EXP(-B2RPW)
20201 ELSE
20202 B2RPW=1D0-LOG(PYR(0))
20203 ACCIP=B2RPW**RPWIP
20204 ENDIF
20205 IF(ACCIP.LT.PYR(0)) GOTO 160
20206 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20207 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20208 ELSE
20209 POWIP=MAX(0.4D0,PARP(83))
20210 RPWIP=2D0/POWIP-1D0
20211 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20212 170 IF(PYR(0).LT.PROB1) THEN
20213 B2RPW=2D0*RPWIP*PYR(0)
20214 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20215 ELSE
20216 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20217 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20218 ENDIF
20219 IF(ACCIP.LT .PYR(0)) GOTO 170
20220 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20221 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20222 ENDIF
20223
20224C...Multiple interactions (variable impact parameter) : reject with
20225C...probability exp(-overlap*cross-section above pT/normalization).
20226C...Does not apply to low-b region, where "Sudakov" already included.
20227 VINT(150)=1D0
20228 IF(MINT(39).NE.1) THEN
20229 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20230 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20231 DO 180 IBIN=IRBIN+1,20
20232 RNCOR=RNCOR+NMUL(IBIN)
20233 SIGCOR=SIGCOR+SIGM(IBIN)
20234 180 CONTINUE
20235 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20236 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20237 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20238 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20239 ENDIF
20240 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20241 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20242 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20243 IF(VINT(150).LT.PYR(0)) GOTO 150
20244 VINT(150)=1D0
20245 ENDIF
20246
20247C...Generate additional multiple semihard interactions.
20248 ELSEIF(MMUL.EQ.6) THEN
20249
20250C...Save data for hardest initeraction, to be restored.
20251 ISUBSV=MINT(1)
20252 VINT(145)=VNT145
20253 VINT(146)=VNT146
20254 VINT(147)=VNT147
20255 M13SV=MINT(13)
20256 M14SV=MINT(14)
20257 M15SV=MINT(15)
20258 M16SV=MINT(16)
20259 M21SV=MINT(21)
20260 M22SV=MINT(22)
20261 DO 190 J=11,80
20262 VINTSV(J)=VINT(J)
20263 190 CONTINUE
20264 V141SV=VINT(141)
20265 V142SV=VINT(142)
20266
20267C...Store data on hardest interaction.
20268 XMI(1,1)=VINT(141)
20269 XMI(2,1)=VINT(142)
20270 PT2MI(1)=VINT(54)
20271 IMISEP(0)=MINT(84)
20272 IMISEP(1)=N
20273
20274C...Change process to generate; sum of x values so far.
20275 ISUB=96
20276 MINT(1)=96
20277 VINT(143)=1D0-VINT(141)
20278 VINT(144)=1D0-VINT(142)
20279 VINT(151)=0D0
20280 VINT(152)=0D0
20281
20282C...Initialize factors for PDF reshaping.
20283 DO 230 JS=1,2
20284 KFBEAM=MINT(10+JS)
20285 KFABM=IABS(KFBEAM)
20286 KFSBM=ISIGN(1,KFBEAM)
20287
20288C...Zero flavour content of incoming beam particle.
20289 KFIVAL(JS,1)=0
20290 KFIVAL(JS,2)=0
20291 KFIVAL(JS,3)=0
20292C...Flavour content of baryon.
20293 IF(KFABM.GT.1000) THEN
20294 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20295 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20296 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20297C...Flavour content of pi+-, K+-.
20298 ELSEIF(KFABM.EQ.211) THEN
20299 KFIVAL(JS,1)=KFSBM*2
20300 KFIVAL(JS,2)=-KFSBM
20301 ELSEIF(KFABM.EQ.321) THEN
20302 KFIVAL(JS,1)=-KFSBM*3
20303 KFIVAL(JS,2)=KFSBM*2
20304C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20305 ENDIF
20306
20307C...Zero initial valence and companion content.
20308 DO 200 IFL=-6,6
20309 NVC(JS,IFL)=0
20310 200 CONTINUE
20311
20312C...Initiate listing of all incoming partons from two sides.
20313 NMI(JS)=0
20314 DO 210 I=MINT(84)+1,N
20315 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20316 IMI(JS,1,1)=I
20317 IMI(JS,1,2)=0
20318 ENDIF
20319 210 CONTINUE
20320
20321C...Decide whether quarks in hard scattering were valence or sea.
20322 IFL=K(IMI(JS,1,1),2)
20323 IF (IABS(IFL).GT.6) GOTO 230
20324
20325C...Get PDFs at X and Q2 of the parton shower initiator for the
20326C...hard scattering.
20327 X=VINT(140+JS)
20328 IF(MSTP(61).GE.1) THEN
20329 Q2=PARP(62)**2
20330 ELSE
20331 Q2=VINT(54)
20332 ENDIF
20333C...Note: XPSVC = x*pdf.
20334 MINT(30)=JS
20335 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20336 SEA=XPSVC(IFL,-1)
20337 VAL=XPSVC(IFL,0)
20338
20339C...Decide (Extra factor x cancels in the division).
20340 RVCS=PYR(0)*(SEA+VAL)
20341 IVNOW=1
20342 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20343C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20344 IVNOW=0
20345 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20346 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20347 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20348 IF(KFIVAL(JS,1).EQ.0) THEN
20349 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20350 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20351 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20352 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20353 ENDIF
20354 IF(IVNOW.EQ.0) GOTO 220
20355C...Mark valence.
20356 IMI(JS,1,2)=0
20357C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20358 IF(KFIVAL(JS,1).EQ.0) THEN
20359 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20360 KFIVAL(JS,1)=IFL
20361 KFIVAL(JS,2)=-IFL
20362 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20363 KFIVAL(JS,1)=IFL
20364 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20365 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20366 ENDIF
20367 ENDIF
20368
20369C...If sea, add opposite sign companion parton. Store X and I.
20370 ELSE
20371 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20372 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20373C...Set pointer to companion
20374 IMI(JS,1,2)=-NVC(JS,-IFL)
20375 ENDIF
20376 230 CONTINUE
20377
20378C...Update counter number of multiple interactions.
20379 NMI(1)=1
20380 NMI(2)=1
20381
20382C...Set up starting values for iteration in xT2.
20383 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
20384 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
20385 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
20386 & ISUBSV.NE.96)) THEN
20387 XT2=(1D0-VINT(141))*(1D0-VINT(142))
20388 ELSE
20389 XT2=VINT(25)
20390 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
20391 IF(ISET(ISUBSV).EQ.2)
20392 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20393 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
20394 ENDIF
20395 IF(MSTP(82).LE.1) THEN
20396 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20397 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20398 & VINT(317)/(VINT(318)*VINT(320))
20399 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20400 ELSE
20401 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20402 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20403 ENDIF
20404 VINT(63)=0D0
20405 VINT(64)=0D0
20406
20407C...Iterate downwards in xT2.
20408 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
20409 XT2=0D0
20410 GOTO 440
20411 ELSEIF(MSTP(82).LE.1) THEN
20412 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20413 IF(XT2.LT.VINT(149)) GOTO 440
20414 ELSE
20415 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
20416 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20417 & LOG(PYR(0)))-VINT(149)
20418 IF(XT2.LE.0D0) GOTO 440
20419 XT2=MAX(0.01D0*VINT(149),XT2)
20420 ENDIF
20421 VINT(25)=XT2
20422
20423C...Choose tau and y*. Calculate cos(theta-hat).
20424 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20425 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20426 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20427 ELSE
20428 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20429 ENDIF
20430 VINT(21)=TAU
20431C...New: require shat > 1.
20432 IF(TAU*VINT(2).LT.1D0) GOTO 240
20433 CALL PYKLIM(2)
20434 RYST=PYR(0)
20435 MYST=1
20436 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20437 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20438 CALL PYKMAP(2,MYST,PYR(0))
20439 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20440
20441C...Check that x not used up. Accept or reject kinematical variables.
20442 X1M=SQRT(TAU)*EXP(VINT(22))
20443 X2M=SQRT(TAU)*EXP(-VINT(22))
20444 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
20445 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20446 CALL PYSIGH(NCHN,SIGS)
20447 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20448 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
20449 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
20450
20451C...Reset K, P and V vectors.
20452 DO 260 I=N+1,N+4
20453 DO 250 J=1,5
20454 K(I,J)=0
20455 P(I,J)=0D0
20456 V(I,J)=0D0
20457 250 CONTINUE
20458 260 CONTINUE
20459 PT=0.5D0*VINT(1)*SQRT(XT2)
20460
20461C...Choose flavour of reacting partons (and subprocess).
20462 RSIGS=SIGS*PYR(0)
20463 DO 270 ICHN=1,NCHN
20464 KFL1=ISIG(ICHN,1)
20465 KFL2=ISIG(ICHN,2)
20466 ICONMI=ISIG(ICHN,3)
20467 RSIGS=RSIGS-SIGH(ICHN)
20468 IF(RSIGS.LE.0D0) GOTO 280
20469 270 CONTINUE
20470
20471C...Reassign to appropriate process codes.
20472 280 ISUBMI=ICONMI/10
20473 ICONMI=MOD(ICONMI,10)
20474
20475C...Choose new quark flavour for annihilation graphs
20476 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
20477 SH=TAU*VINT(2)
20478 CALL PYWIDT(21,SH,WDTP,WDTE)
20479 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
20480 DO 300 I=1,MDCY(21,3)
20481 KFLF=KFDP(I+MDCY(21,2)-1,1)
20482 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
20483 IF(RKFL.LE.0D0) GOTO 310
20484 300 CONTINUE
20485 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
20486 IF(KFLF.GE.4) GOTO 290
20487 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
20488 KFLF=4
20489 ICONMI=ICONMI-2
20490 ELSEIF(ISUBMI.EQ.53) THEN
20491 KFLF=5
20492 ICONMI=ICONMI-4
20493 ENDIF
20494 ENDIF
20495
20496C...Final state flavours and colour flow: default values
20497 JS=1
20498 KFL3=KFL1
20499 KFL4=KFL2
20500 KCC=20
20501 KCS=ISIGN(1,KFL1)
20502
20503 IF(ISUBMI.EQ.11) THEN
20504C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
20505 KCC=ICONMI
20506 IF(KFL1*KFL2.LT.0) KCC=KCC+2
20507
20508 ELSEIF(ISUBMI.EQ.12) THEN
20509C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
20510 KFL3=ISIGN(KFLF,KFL1)
20511 KFL4=-KFL3
20512 KCC=4
20513
20514 ELSEIF(ISUBMI.EQ.13) THEN
20515C...f + fbar -> g + g; th arbitrary
20516 KFL3=21
20517 KFL4=21
20518 KCC=ICONMI+4
20519
20520 ELSEIF(ISUBMI.EQ.28) THEN
20521C...f + g -> f + g; th = (p(f)-p(f))**2
20522 IF(KFL1.EQ.21) JS=2
20523 KCC=ICONMI+6
20524 IF(KFL1.EQ.21) KCC=KCC+2
20525 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
20526 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
20527
20528 ELSEIF(ISUBMI.EQ.53) THEN
20529C...g + g -> f + fbar; th arbitrary
20530 KCS=(-1)**INT(1.5D0+PYR(0))
20531 KFL3=ISIGN(KFLF,KCS)
20532 KFL4=-KFL3
20533 KCC=ICONMI+10
20534
20535 ELSEIF(ISUBMI.EQ.68) THEN
20536C...g + g -> g + g; th arbitrary
20537 KCC=ICONMI+12
20538 KCS=(-1)**INT(1.5D0+PYR(0))
20539 ENDIF
20540
20541C...Store flavours of scattering.
20542 MINT(13)=KFL1
20543 MINT(14)=KFL2
20544 MINT(15)=KFL1
20545 MINT(16)=KFL2
20546 MINT(21)=KFL3
20547 MINT(22)=KFL4
20548
20549C...Set flavours and mothers of scattering partons.
20550 K(N+1,1)=14
20551 K(N+2,1)=14
20552 K(N+3,1)=3
20553 K(N+4,1)=3
20554 K(N+1,2)=KFL1
20555 K(N+2,2)=KFL2
20556 K(N+3,2)=KFL3
20557 K(N+4,2)=KFL4
20558 K(N+1,3)=MINT(83)+1
20559 K(N+2,3)=MINT(83)+2
20560 K(N+3,3)=N+1
20561 K(N+4,3)=N+2
20562
20563C...Store colour connection indices.
20564 DO 320 J=1,2
20565 JC=J
20566 IF(KCS.EQ.-1) JC=3-J
20567 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
20568 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
20569 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
20570 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
20571 320 CONTINUE
20572
20573C...Store incoming and outgoing partons in their CM-frame.
20574 SHR=SQRT(TAU)*VINT(1)
20575 P(N+1,3)=0.5D0*SHR
20576 P(N+1,4)=0.5D0*SHR
20577 P(N+2,3)=-0.5D0*SHR
20578 P(N+2,4)=0.5D0*SHR
20579 P(N+3,5)=PYMASS(K(N+3,2))
20580 P(N+4,5)=PYMASS(K(N+4,2))
20581 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
20582 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
20583 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
20584 P(N+4,4)=SHR-P(N+3,4)
20585 P(N+4,3)=-P(N+3,3)
20586
20587C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
20588 PHI=PARU(2)*PYR(0)
20589 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
20590
20591C...Set up default values before showers.
20592 MINT(31)=MINT(31)+1
20593 IPU1=N+1
20594 IPU2=N+2
20595 IPU3=N+3
20596 IPU4=N+4
20597 VINT(141)=VINT(41)
20598 VINT(142)=VINT(42)
20599 N=N+4
20600
20601C...Showering of initial state partons (optional).
20602C...Note: no showering of final state partons here; it comes later.
20603 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20604 MINT(51)=0
20605 ALAMSV=PARJ(81)
20606 PARJ(81)=PARP(72)
20607 NSAV=N
20608 DO 340 I=1,4
20609 DO 330 J=1,5
20610 KSAV(I,J)=K(N-4+I,J)
20611 PSAV(I,J)=P(N-4+I,J)
20612 330 CONTINUE
20613 340 CONTINUE
20614 CALL PYSSPA(IPU1,IPU2)
20615 PARJ(81)=ALAMSV
20616C...If shower failed then restore to situation before shower.
20617 IF(MINT(51).GE.1) THEN
20618 N=NSAV
20619 DO 360 I=1,4
20620 DO 350 J=1,5
20621 K(N-4+I,J)=KSAV(I,J)
20622 P(N-4+I,J)=PSAV(I,J)
20623 350 CONTINUE
20624 360 CONTINUE
20625 IPU1=N-3
20626 IPU2=N-2
20627 VINT(141)=VINT(41)
20628 VINT(142)=VINT(42)
20629 ENDIF
20630 ENDIF
20631
20632C...Keep track of loose colour ends and information on scattering.
20633 370 IMI(1,MINT(31),1)=IPU1
20634 IMI(2,MINT(31),1)=IPU2
20635 IMI(1,MINT(31),2)=0
20636 IMI(2,MINT(31),2)=0
20637 XMI(1,MINT(31))=VINT(141)
20638 XMI(2,MINT(31))=VINT(142)
20639 PT2MI(MINT(31))=VINT(54)
20640 IMISEP(MINT(31))=N
20641
20642C...Decide whether quarks in last scattering were valence, companion or
20643C...sea.
20644 DO 430 JS=1,2
20645 KFBEAM=MINT(10+JS)
20646 KFSBM=ISIGN(1,MINT(10+JS))
20647 IFL=K(IMI(JS,MINT(31),1),2)
20648 IMI(JS,MINT(31),2)=0
20649 IF (IABS(IFL).GT.6) GOTO 430
20650
20651C...Get PDFs at X and Q2 of the parton shower initiator for the
20652C...last scattering. At this point VINT(143:144) do not yet
20653C...include the scattered x values VINT(141:142).
20654 X=VINT(140+JS)/VINT(142+JS)
20655 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20656 Q2=PARP(62)**2
20657 ELSE
20658 Q2=VINT(54)
20659 ENDIF
20660C...Note: XPSVC = x*pdf.
20661 MINT(30)=JS
20662 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20663 SEA=XPSVC(IFL,-1)
20664 VAL=XPSVC(IFL,0)
20665 CMP=0D0
20666 DO 380 IVC=1,NVC(JS,IFL)
20667 CMP=CMP+XPSVC(IFL,IVC)
20668 380 CONTINUE
20669
20670C...Decide (Extra factor x cancels in the dvision).
20671 RVCS=PYR(0)*(SEA+VAL+CMP)
20672 IVNOW=1
20673 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20674C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20675 IVNOW=0
20676 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20677 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20678 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20679 IF(KFIVAL(JS,1).EQ.0) THEN
20680 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20681 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20682 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20683 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20684 ELSE
20685 DO 400 I1=1,NMI(JS)
20686 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20687 & IVNOW=IVNOW-1
20688 400 CONTINUE
20689 ENDIF
20690 IF(IVNOW.EQ.0) GOTO 390
20691C...Mark valence.
20692 IMI(JS,MINT(31),2)=0
20693C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20694 IF(KFIVAL(JS,1).EQ.0) THEN
20695 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20696 KFIVAL(JS,1)=IFL
20697 KFIVAL(JS,2)=-IFL
20698 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20699 KFIVAL(JS,1)=IFL
20700 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20701 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20702 ENDIF
20703 ENDIF
20704
20705 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20706C...If sea, add opposite sign companion parton. Store X and I.
20707 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20708 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20709C...Set pointer to companion
20710 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20711 ELSE
20712C...If companion, decide which one.
20713 CMPSUM=VAL+SEA
20714 ISEL=0
20715 410 ISEL=ISEL+1
20716 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20717 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20718C...Find original sea (anti-)quark:
20719 IASSOC=0
20720 DO 420 I1=1,NMI(JS)
20721 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20722 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20723 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20724 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20725 ENDIF
20726 420 CONTINUE
20727C...Change X to what associated companion had, so that the correct
20728C...amount of momentum can be subtracted from the companion sum below.
20729 X=XASSOC(JS,IFL,ISEL)
20730C...Mark companion read.
20731 XASSOC(JS,IFL,ISEL)=0D0
20732 ENDIF
20733 430 CONTINUE
20734
20735C...Global statistics.
20736 MINT(351)=MINT(351)+1
20737 VINT(351)=VINT(351)+PT
20738 IF (MINT(351).EQ.1) VINT(356)=PT
20739
20740C...Update remaining energy and other counters.
20741 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20742 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20743 MINT(51)=1
20744 RETURN
20745 ENDIF
20746 NMI(1)=NMI(1)+1
20747 NMI(2)=NMI(2)+1
20748 VINT(151)=VINT(151)+VINT(41)
20749 VINT(152)=VINT(152)+VINT(42)
20750 VINT(143)=VINT(143)-VINT(141)
20751 VINT(144)=VINT(144)-VINT(142)
20752
20753C...Iterate, with more interactions allowed.
20754 IF(MINT(31).LT.240) GOTO 240
20755 440 CONTINUE
20756
20757C...Restore saved quantities for hardest interaction.
20758 MINT(1)=ISUBSV
20759 MINT(13)=M13SV
20760 MINT(14)=M14SV
20761 MINT(15)=M15SV
20762 MINT(16)=M16SV
20763 MINT(21)=M21SV
20764 MINT(22)=M22SV
20765 DO 450 J=11,80
20766 VINT(J)=VINTSV(J)
20767 450 CONTINUE
20768 VINT(141)=V141SV
20769 VINT(142)=V142SV
20770
20771 ENDIF
20772
20773C...Format statements for printout.
20774 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20775 &'actions for MSTP(82) =',I2,' ******')
20776 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20777 &D9.2,' mb: rejected')
20778 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20779 &D9.2,' mb: accepted')
20780
20781 RETURN
20782 END
20783
20784C*********************************************************************
20785
20786C...PYMIHK
20787C...Finds left-behind remnant flavour content and hooks up
20788C...the colour flow between the hard scattering and remnants
20789
20790 SUBROUTINE PYMIHK
20791
20792C...Double precision and integer declarations.
20793 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20794 IMPLICIT INTEGER(I-N)
20795 INTEGER PYK,PYCHGE,PYCOMP
20796C...The event record
20797 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20798C...Parameters
20799 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20800 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20801 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20802 COMMON/PYINT1/MINT(400),VINT(400)
20803C...The common block of dangling ends
20804 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20805 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20806 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20807 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20808C...Local variables
20809 PARAMETER (NERSIZ=4000)
20810 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20811 & ,MACCPT
20812 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20813 SAVE /PYCBLS/,/PYCTAG/
20814 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20815 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20816 DATA NERRPR/0/
20817 SAVE NERRPR
20818 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)
20819
20820C...Set up error checkers
20821 IBOOST=0
20822
20823C...Initialize colour arrays: MCO (Original) and MCT (New)
20824 DO 110 I=MINT(84)+1,NERSIZ
20825 DO 100 JC=1,2
20826 MCT(I,JC)=0
20827 MCO(I,JC)=0
20828 100 CONTINUE
20829C...Also zero colour tracing information, if existed.
20830 IF (I.LE.N) THEN
20831 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20832 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20833 ENDIF
20834 110 CONTINUE
20835
20836C...Initialize colour tag collapse arrays:
20837C...JCCO (Original) and JCCN (New).
20838 DO 130 MG=MINT(84)+1,NERSIZ
20839 DO 120 JC=1,2
20840 JCCO(MG,JC)=0
20841 JCCN(MG,JC)=0
20842 120 CONTINUE
20843 130 CONTINUE
20844
20845C...Zero gluon insertion array
20846 DO 150 IM=1,1000
20847 DO 140 J=1,3
20848 INSR(IM,J)=0
20849 140 CONTINUE
20850 150 CONTINUE
20851
20852C...Compute hard scattering system rapidities
20853 IF (MSTP(89).EQ.1) THEN
20854 DO 160 IM=1,240
20855 IF (IM.LE.MINT(31)) THEN
20856 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20857 ELSE
20858C...Set (unsigned) rapidity = 100 for beam remnant systems.
20859 YMI(IM)=100D0
20860 ENDIF
20861 160 CONTINUE
20862 ENDIF
20863
20864C...Treat each side separately
20865 DO 290 JS=1,2
20866
20867C...Initialize side.
20868 NG(JS)=0
20869 JV=0
20870 KFS=ISIGN(1,MINT(10+JS))
20871
20872C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20873 IF(KFIVAL(JS,1).EQ.0) THEN
20874 IF(MINT(10+JS).EQ.111) THEN
20875 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20876 KFIVAL(JS,2)=-KFIVAL(JS,1)
20877 ELSEIF(MINT(10+JS).EQ.22) THEN
20878 PYRKF=PYR(0)
20879 KFIVAL(JS,1)=1
20880 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20881 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20882 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20883 KFIVAL(JS,2)=-KFIVAL(JS,1)
20884 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20885 IF(PYR(0).GT.0.5D0) THEN
20886 KFIVAL(JS,1)=1
20887 KFIVAL(JS,2)=-3
20888 ELSE
20889 KFIVAL(JS,1)=3
20890 KFIVAL(JS,2)=-1
20891 ENDIF
20892 ENDIF
20893 ENDIF
20894
20895C...Initialize beam remnant sea and valence content flavour by flavour.
20896 NVSUM(JS)=0
20897 NBRTOT(JS)=0
20898 DO 210 JFA=1,6
20899C...Count up original number of JFA valence quarks and antiquarks.
20900 NVALQ=0
20901 NVALQB=0
20902 NSEA=0
20903 DO 170 J=1,3
20904 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20905 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20906 170 CONTINUE
20907 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20908C...Subtract kicked out valence and determine sea from flavour cons.
20909 DO 180 IM=1,NMI(JS)
20910 IFL = K(IMI(JS,IM,1),2)
20911 IFA = IABS(IFL)
20912 IFS = ISIGN(1,IFL)
20913 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20914C...Subtract K.O. valence quark from remainder.
20915 NVALQ=NVALQ-1
20916 JV=NVSUM(JS)-NVALQ-NVALQB
20917 IV(JS,JV)=IMI(JS,IM,1)
20918 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20919C...Subtract K.O. valence antiquark from remainder.
20920 NVALQB=NVALQB-1
20921 JV=NVSUM(JS)-NVALQ-NVALQB
20922 IV(JS,JV)=IMI(JS,IM,1)
20923 ELSEIF (IFA.EQ.JFA) THEN
20924C...Outside sea without companion: add opposite sea flavour inside.
20925 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20926 ENDIF
20927 180 CONTINUE
20928C...Check if space left in PYJETS for additional BR flavours
20929 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20930 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20931 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20932 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20933 MINT(51)=1
20934 RETURN
20935 ENDIF
20936C...Add required val+sea content to beam remnant.
20937 IF (NFLSUM.GT.0) THEN
20938 DO 200 IA=1,NFLSUM
20939C...Insert beam remnant quark as p.t. symbolic parton in ER.
20940 N=N+1
20941 DO 190 IX=1,5
20942 K(N,IX)=0
20943 P(N,IX)=0D0
20944 V(N,IX)=0D0
20945 190 CONTINUE
20946 K(N,1)=3
20947 K(N,2)=ISIGN(JFA,NSEA)
20948 IF (IA.LE.NVALQ) K(N,2)=JFA
20949 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20950 K(N,3)=MINT(83)+JS
20951C...Also update NMI, IMI, and IV arrays.
20952 NMI(JS)=NMI(JS)+1
20953 IMI(JS,NMI(JS),1)=N
20954 IMI(JS,NMI(JS),2)=-1
20955 IF (IA.LE.NVALQ+NVALQB) THEN
20956 IMI(JS,NMI(JS),2)=0
20957 JV=JV+1
20958 IV(JS,JV)=IMI(JS,NMI(JS),1)
20959 ENDIF
20960 200 CONTINUE
20961 ENDIF
20962 210 CONTINUE
20963
20964 IM=0
20965 220 IM=IM+1
20966 IF (IM.LE.NMI(JS)) THEN
20967 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20968 NG(JS)=NG(JS)+1
20969C...Add fictitious parent gluons for companion pairs.
20970 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20971C...Randomly assign companions to sea quarks which have none.
20972 IF (IMI(JS,IM,2).LT.0) THEN
20973 IMC=PYR(0)*NMI(JS)
20974 230 IMC=MOD(IMC,NMI(JS))+1
20975 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20976 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20977 IMI(JS, IM,2) = IMI(JS,IMC,1)
20978 IMI(JS,IMC,2) = IMI(JS, IM,1)
20979 ENDIF
20980C...Add fictitious parent gluon
20981 N=N+1
20982 DO 240 IX=1,5
20983 K(N,IX)=0
20984 P(N,IX)=0D0
20985 V(N,IX)=0D0
20986 240 CONTINUE
20987 K(N,1)=14
20988 K(N,2)=21
20989 K(N,3)=MINT(83)+JS
20990C...Set gluon (anti-)colour daughter pointers
20991 K(N,4)=IMI(JS, IM,1)
20992 K(N,5)=IMI(JS, IM,2)
20993C...Set quark (anti-)colour parent pointers
20994 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
20995 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
20996C...Add gluon to IMI
20997 NMI(JS)=NMI(JS)+1
20998 IMI(JS,NMI(JS),1)=N
20999 IMI(JS,NMI(JS),2)=0
21000 ENDIF
21001 GOTO 220
21002 ENDIF
21003
21004C...If incoming (anti-)baryon, insert inside (anti-)junction.
21005C...Set up initial v-v-j-v configuration. Otherwise set up
21006C...mesonic v-vbar configuration
21007 IF (IABS(MINT(10+JS)).GT.1000) THEN
21008C...Determine junction type (1: B=1 2: B=-1)
21009 ITJUNC(JS) = (3-KFS)/2
21010C...Insert junction.
21011 N=N+1
21012 DO 250 IX=1,5
21013 K(N,IX)=0
21014 P(N,IX)=0D0
21015 V(N,IX)=0D0
21016 250 CONTINUE
21017C...Set special junction codes:
21018 K(N,1)=42
21019 K(N,2)=88
21020C...Set parent to side.
21021 K(N,3)=MINT(83)+JS
21022 K(N,4)=ITJUNC(JS)*MSTU(5)
21023 K(N,5)=0
21024C...Connect valence quarks to junction.
21025 MOUT(JS)=0
21026 MANTI=ITJUNC(JS)-1
21027C...Set (anti)colour mother = junction.
21028 DO 260 JV=1,3
21029 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21030 & +MSTU(5)*N
21031C...Keep track of partons adjacent to junction:
21032 JST(JS,JV)=IV(JS,JV)
21033 260 CONTINUE
21034 ELSE
21035C...Mesons: set up initial q-qbar topology
21036 ITJUNC(JS)=0
21037 IF (K(IV(JS,1),2).GT.0) THEN
21038 IQ=IV(JS,1)
21039 IQBAR=IV(JS,2)
21040 ELSE
21041 IQ=IV(JS,2)
21042 IQBAR=IV(JS,1)
21043 ENDIF
21044 IV(JS,3)=0
21045 JST(JS,1)=IQ
21046 JST(JS,2)=IQBAR
21047 JST(JS,3)=0
21048 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21049 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21050C...Special for mesons. Insert gluon if BR empty.
21051 IF (NBRTOT(JS).EQ.0) THEN
21052 N=N+1
21053 DO 270 IX=1,5
21054 K(N,IX)=0
21055 P(N,IX)=0D0
21056 V(N,IX)=0D0
21057 270 CONTINUE
21058 K(N,1)=3
21059 K(N,2)=21
21060 K(N,3)=MINT(83)+JS
21061 K(N,4)=0
21062 K(N,5)=0
21063 NBRTOT(JS)=1
21064 NG(JS)=NG(JS)+1
21065C...Add gluon to IMI
21066 NMI(JS)=NMI(JS)+1
21067 IMI(JS,NMI(JS),1)=N
21068 IMI(JS,NMI(JS),2)=0
21069 ENDIF
21070 MOUT(JS)=0
21071 ENDIF
21072
21073C...Count up number of valence quarks outside BR.
21074 DO 280 JV=1,3
21075 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21076 & MOUT(JS)=MOUT(JS)+1
21077 280 CONTINUE
21078
21079 290 CONTINUE
21080
21081C...Now both sides have been prepared in an initial vvjv (baryonic) or
21082C...v(g)vbar (mesonic) configuration.
21083
21084C...Create colour line tags starting from initiators.
21085 NCT=0
21086 DO 320 IM=1,MINT(31)
21087C...Consider each side in turn.
21088 DO 310 JS=1,2
21089 I1=IMI(JS,IM,1)
21090 I2=IMI(3-JS,IM,1)
21091 DO 300 JCS=4,5
21092 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21093 & GOTO 300
21094 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21095
21096 KCS=JCS
21097 CALL PYCTTR(I1,KCS,I2)
21098 IF(MINT(51).NE.0) RETURN
21099
21100 300 CONTINUE
21101 310 CONTINUE
21102 320 CONTINUE
21103
21104 DO 340 JS=1,2
21105C...Create colour tags for beam remnant partons.
21106 DO 330 IM=MINT(31)+1,NMI(JS)
21107 IP=IMI(JS,IM,1)
21108 IF (K(IP,2).NE.21) THEN
21109 JC=(3-ISIGN(1,K(IP,2)))/2
21110 IF (MCT(IP,JC).EQ.0) THEN
21111 NCT=NCT+1
21112 MCT(IP,JC)=NCT
21113 ENDIF
21114 ELSE
21115C...Gluons
21116 ICD=K(IP,4)
21117 IAD=K(IP,5)
21118 IF (ICD.NE.0) THEN
21119C...Fictituous gluons just inherit from their quark daughters.
21120 ICC=MCT(ICD,1)
21121 IAC=MCT(IAD,2)
21122 ELSE
21123C...Real beam remnant gluons get their own colours
21124 ICC=NCT+1
21125 IAC=NCT+2
21126 NCT=NCT+2
21127 ENDIF
21128 MCT(IP,1)=ICC
21129 MCT(IP,2)=IAC
21130 ENDIF
21131 330 CONTINUE
21132 340 CONTINUE
21133
21134C...Create colour tags for colour lines which are detached from the
21135C...initial state.
21136
21137 DO 360 MQGST=1,2
21138 DO 350 I=MINT(84)+1,N
21139
21140C...Look for coloured string endpoint, or (later) leftover gluon.
21141 IF (K(I,1).NE.3) GOTO 350
21142 KC=PYCOMP(K(I,2))
21143 IF(KC.EQ.0) GOTO 350
21144 KQ=KCHG(KC,2)
21145 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21146
21147C...Pick up loose string end with no previous tag.
21148 KCS=4
21149 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21150 IF(MCT(I,KCS-3).NE.0) GOTO 350
21151
21152 CALL PYCTTR(I,KCS,I)
21153 IF(MINT(51).NE.0) RETURN
21154
21155 350 CONTINUE
21156 360 CONTINUE
21157
21158C...Store original colour tags
21159 DO 370 I=MINT(84)+1,N
21160 MCO(I,1)=MCT(I,1)
21161 MCO(I,2)=MCT(I,2)
21162 370 CONTINUE
21163
21164C...Iteratively add gluons to already existing string pieces, enforcing
21165C...various possible orderings, and rejecting insertions that would give
21166C...rise to singlet gluons.
21167C...<kappa tau> normalization.
21168 RM0=1.5D0
21169 MRETRY=0
21170 PARP80=PARP(80)
21171
21172C...Set up simplified kinematics.
21173C...Boost hard interaction systems.
21174 IBOOST=IBOOST+1
21175 DO 380 IM=1,MINT(31)
21176 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21177 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21178 380 CONTINUE
21179C...Assign preliminary beam remnant momenta.
21180 DO 390 I=MINT(53)+1,N
21181 JS=K(I,3)
21182 P(I,1)=0D0
21183 P(I,2)=0D0
21184 IF (K(I,2).NE.88) THEN
21185 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21186 P(I,3)=P(I,4)
21187 IF (JS.EQ.2) P(I,3)=-P(I,3)
21188 ELSE
21189C...Junctions are wildcards for the present.
21190 P(I,4)=0D0
21191 P(I,3)=0D0
21192 ENDIF
21193 390 CONTINUE
21194
21195C...Reset colour processing information.
21196 400 DO 410 I=MINT(84)+1,N
21197 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21198 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21199 410 CONTINUE
21200
21201 NCC=0
21202 DO 430 JS=1,2
21203C...If meson, without gluon in BR, collapse q-qbar colour tags:
21204 IF (ITJUNC(JS).EQ.0) THEN
21205 JC1=MCT(JST(JS,1),1)
21206 JC2=MCT(JST(JS,2),2)
21207 NCC=NCC+1
21208 JCCO(NCC,1)=MAX(JC1,JC2)
21209 JCCO(NCC,2)=MIN(JC1,JC2)
21210C...Collapse colour tags in event record
21211 DO 420 I=MINT(84)+1,N
21212 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21213 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21214 420 CONTINUE
21215 ENDIF
21216 430 CONTINUE
21217
21218 440 JS=1
21219 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21220 IF (NG(JS).GT.0) THEN
21221 NOPT=0
21222 RLOPT=1D9
21223C...Start at random gluon (optimizes speed for random attachments)
21224 NMGL=0
21225 IMGL=PYR(0)*NMI(JS)+1
21226 450 IMGL=MOD(IMGL,NMI(JS))+1
21227 NMGL=NMGL+1
21228C...Only loop through NMI once (with upper limit to save time)
21229 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21230 IGL = IMI(JS,IMGL,1)
21231C...If not gluon or if already connected, try next.
21232 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21233 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21234C...Now loop through all possible insertions of this gluon.
21235 NMP1=0
21236 IMP1=PYR(0)*NMI(JS)+1
21237 460 IMP1=MOD(IMP1,NMI(JS))+1
21238 NMP1=NMP1+1
21239 IF (IMP1.EQ.IMGL) GOTO 460
21240C...Only loop through NMI once (with upper limit to save time).
21241 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21242 IP1 = IMI(JS,IMP1,1)
21243C...Try both colour mother and colour anti-mother.
21244C...Randomly select which one to try first.
21245 NANTI=0
21246 MANTI=PYR(0)*2
21247 470 MANTI=MOD(MANTI+1,2)
21248 NANTI=NANTI+1
21249 IF (NANTI.LE.2) THEN
21250 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21251C...Reject if no appropriate mother (or if mother is fictitious
21252C...parent gluon.)
21253 IF (IP2.LE.0) GOTO 470
21254 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21255C...Also reject if this link has already been tried.
21256 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21257 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21258C...Set flag to indicate that this link has now been tried for this
21259C...gluon. IP2 may be junction, which has several mothers.
21260 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21261 IF (K(IP2,2).NE.88) THEN
21262 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21263 ENDIF
21264
21265C...JCG1: Original colour tag of gluon on IP1 side
21266C...JCG2: Original colour tag of gluon on IP2 side
21267C...JCP1: Original colour tag of IP1 on gluon side
21268C...JCP2: Original colour tag of IP2 on gluon side.
21269 JCG1=MCO(IGL,2-MANTI)
21270 JCG2=MCO(IGL,1+MANTI)
21271 JCP1=MCO(IP1,1+MANTI)
21272 JCP2=MCO(IP2,2-MANTI)
21273
21274 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21275C...Reject gluon attachments that give rise to singlet gluons.
21276 IF (MACCPT.EQ.0) GOTO 470
21277
21278C...Update colours
21279 JCG1=MCT(IGL,2-MANTI)
21280 JCG2=MCT(IGL,1+MANTI)
21281 JCP1=MCT(IP1,1+MANTI)
21282 JCP2=MCT(IP2,2-MANTI)
21283
21284C...Select whether to accept this insertion
21285 IF (MSTP(89).EQ.0) THEN
21286C...Random insertions: no measure.
21287 RL=1D0
21288C...For random ordering, we want to suppress beam remnant breakups
21289C...already at this point.
21290 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21291 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21292 NMP1=0
21293 NMGL=0
21294 GOTO 470
21295 ENDIF
21296 ELSEIF (MSTP(89).EQ.1) THEN
21297C...Rapidity ordering:
21298C...YGL = Rapidity of gluon.
21299 YGL=YMI(IMGL)
21300C...If fictitious gluon
21301 IF (YGL.EQ.100D0) THEN
21302 YGL=(3-2*JS)*100D0
21303 IDA1=MOD(K(IGL,4),MSTU(5))
21304 IDA2=MOD(K(IGL,5),MSTU(5))
21305 DO 480 IMT=1,NMI(JS)
21306C...Select (arbitrarily) the most central daughter.
21307 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21308 & THEN
21309 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21310 ENDIF
21311 480 CONTINUE
21312 ENDIF
21313C...YP1 = Rapidity IP1
21314 YP1=YMI(IMP1)
21315C...If fictitious gluon
21316 IF (YP1.EQ.100D0) THEN
21317 YP1=(3-2*JS)*YP1
21318 IDA1=MOD(K(IP1,4),MSTU(5))
21319 IDA2=MOD(K(IP1,5),MSTU(5))
21320 DO 490 IMT=1,NMI(JS)
21321C...Select (arbitrarily) the most central daughter.
21322 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21323 & THEN
21324 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21325 ENDIF
21326 490 CONTINUE
21327 ENDIF
21328C...YP2 = Rapidity of mother system
21329 IF (K(IP2,2).NE.88) THEN
21330 DO 500 IMT=1,NMI(JS)
21331 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21332 500 CONTINUE
21333C...If fictitious gluon
21334 IF (YP2.EQ.100D0) THEN
21335 YP2=(3-2*JS)*YP2
21336 IDA1=MOD(K(IP2,4),MSTU(5))
21337 IDA2=MOD(K(IP2,5),MSTU(5))
21338 DO 510 IMT=1,NMI(JS)
21339C...Select (arbitrarily) the most central daughter.
21340 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21341 & ) THEN
21342 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21343 ENDIF
21344 510 CONTINUE
21345 ENDIF
21346C...Assign (arbitrarily) 100D0 to junction also
21347 ELSE
21348 YP2=(3-2*JS)*100D0
21349 ENDIF
21350 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21351 ELSEIF (MSTP(89).EQ.2) THEN
21352C...Lambda ordering:
21353C...Compute lambda measure for this insertion.
21354 RL=1D0
21355 DO 520 IST=1,6
21356 ISTR(IST)=0
21357 520 CONTINUE
21358C...If IP2 is junction, not caught below.
21359 IF (JCP2.EQ.0) THEN
21360 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
21361C...Anti-junction is colour endpoint et vv., always on JCG2.
21362 ISTR(5-ITJU)=IP2
21363 ENDIF
21364 DO 530 I=MINT(84)+1,N
21365 IF (K(I,1).LT.10) THEN
21366C...The new string pieces
21367 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
21368 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
21369 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
21370 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
21371 ENDIF
21372 530 CONTINUE
21373C...Also identify junctions as string endpoints.
21374 DO 540 I=MINT(84)+1,N
21375 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
21376 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
21377C...Find partons adjacent to junctions.
21378 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
21379 & .EQ.0) ISTR(2) = ICMO
21380 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
21381 & .EQ.0) ISTR(1) = IAMO
21382 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
21383 & .EQ.0) ISTR(4) = ICMO
21384 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
21385 & .EQ.0) ISTR(3) = IAMO
21386 540 CONTINUE
21387C...The old string piece
21388 ISTR(5)=ISTR(1+2*MANTI)
21389 ISTR(6)=ISTR(4-2*MANTI)
21390 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
21391 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
21392 RL=LOG(RL)
21393 ENDIF
21394C...Allow some breadth to speed things up.
21395 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
21396 NOPT=NOPT+1
21397 ELSEIF (RL.GT.RLOPT) THEN
21398 GOTO 470
21399 ELSE
21400 NOPT=1
21401 RLOPT=RL
21402 ENDIF
21403C...INSR(NOPT,1)=Gluon colour mother
21404C...INSR(NOPT,2)=Gluon
21405C...INSR(NOPT,3)=Gluon anticolour mother
21406 IF (NOPT.GT.1000) GOTO 470
21407 INSR(NOPT,1+2*MANTI)=IP2
21408 INSR(NOPT,2)=IGL
21409 INSR(NOPT,3-2*MANTI)=IP1
21410 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
21411 ENDIF
21412 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
21413 ENDIF
21414C...Reset link test information.
21415 DO 550 I=MINT(84)+1,N
21416 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21417 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21418 550 CONTINUE
21419 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
21420 ENDIF
21421C...Now we have a list of best gluon insertions, none of which cause
21422C...singlets to arise. If list is empty, try again a few times. Note:
21423C...this should never happen if we have a meson with a gluon inserted
21424C...in the beam remnant, since that breaks up the colour line.
21425 IF (NOPT.EQ.0) THEN
21426C...Abandon BR-g-BR suppression for retries. This is not serious, it
21427C...just means we happened to start with trying a bad sequence.
21428 PARP80=1D0
21429 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
21430 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
21431 MRETRY=MRETRY+1
21432 DO 590 JS=1,2
21433 IF (ITJUNC(JS).NE.0) THEN
21434 JST(JS,1)=IV(JS,1)
21435 JST(JS,2)=IV(JS,2)
21436 JST(JS,3)=IV(JS,3)
21437C...Reset valence quark parent pointers
21438 DO 560 I=MINT(53)+1,N
21439 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
21440 560 CONTINUE
21441 MANTI=ITJUNC(JS)-1
21442C...Set (anti)colour mother = junction.
21443 DO 570 JV=1,3
21444 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21445 & +MSTU(5)*IJU
21446 570 CONTINUE
21447 ELSE
21448C...Same for mesons. JST unchanged, so needn't be restored.
21449 IQ=JST(JS,1)
21450 IQBAR=JST(JS,2)
21451 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21452 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21453 ENDIF
21454C...Also reset gluon parent pointers.
21455 NG(JS)=0
21456 DO 580 IM=1,NMI(JS)
21457 I=IMI(JS,IM,1)
21458 IF (K(I,2).EQ.21) THEN
21459 K(I,4)=MOD(K(I,4),MSTU(5))
21460 K(I,5)=MOD(K(I,5),MSTU(5))
21461 NG(JS)=NG(JS)+1
21462 ENDIF
21463 580 CONTINUE
21464 590 CONTINUE
21465C...Reset colour tags
21466 DO 600 I=MINT(84)+1,N
21467 MCT(I,1)=MCO(I,1)
21468 MCT(I,2)=MCO(I,2)
21469 600 CONTINUE
21470 GOTO 400
21471 ELSE
21472 IF(NERRPR.LT.5) THEN
21473 NERRPR=NERRPR+1
21474 CALL PYLIST(4)
21475 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
21476 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
21477 ENDIF
21478C...Kill event and start another.
21479 MINT(51)=1
21480 RETURN
21481 ENDIF
21482 ELSE
21483C...Select between insertions, suppressing insertions wholly in the BR.
21484 IIN=PYR(0)*NOPT+1
21485 610 IIN=MOD(IIN,NOPT)+1
21486 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
21487 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
21488 ENDIF
21489
21490C...Now we know which gluon to insert where. Colour tags in JCCO and
21491C...colour connection information should be updated, NG(JS) should be
21492C...counted down, and a new loop performed if there are still gluons
21493C...left on any side.
21494 ICM=INSR(IIN,1)
21495 IACM=INSR(IIN,3)
21496 IGL=INSR(IIN,2)
21497C...JCG : Original gluon colour tag
21498C...JCAG: Original gluon anticolour tag.
21499C...JCM : Original anticolour tag of gluon colour mother
21500C...JACM: Original colour tag of gluon anticolour mother
21501 JCG=MCO(IGL,1)
21502 JCM=MCO(ICM,2)
21503 JACG=MCO(IGL,2)
21504 JACM=MCO(IACM,1)
21505
21506 CALL PYMIHG(JACM,JACG,JCM,JCG)
21507 IF (MACCPT.EQ.0) THEN
21508 IF(NERRPR.LT.5) THEN
21509 NERRPR=NERRPR+1
21510 CALL PYLIST(4)
21511 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
21512 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
21513 ENDIF
21514C...Kill event and start another.
21515 MINT(51)=1
21516 RETURN
21517 ELSE
21518C...If everything went fine, store new JCCN in JCCO.
21519 NCC=NCC+1
21520 DO 620 ICC=1,NCC
21521 JCCO(ICC,1)=JCCN(ICC,1)
21522 JCCO(ICC,2)=JCCN(ICC,2)
21523 620 CONTINUE
21524 ENDIF
21525
21526C...One gluon attached is counted as equivalent to one end outside.
21527 MOUT(JS)=1
21528C...Set IGL colour mother = ICM.
21529 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
21530C...Set ICM anticolour mother = IGL colour.
21531 IF (K(ICM,2).NE.88) THEN
21532 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
21533 ELSE
21534C...If ICM is junction, just update JST array for now.
21535 DO 630 MSJ=1,3
21536 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
21537 630 CONTINUE
21538 ENDIF
21539C...Set IGL anticolour mother = IACM.
21540 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
21541C...Set IACM anticolour mother = IGL anticolour.
21542 IF (K(IACM,2).NE.88) THEN
21543 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
21544 ELSE
21545C...If IACM is junction, just update JST array for now.
21546 DO 640 MSJ=1,3
21547 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
21548 640 CONTINUE
21549 ENDIF
21550C...Count down # unconnected gluons.
21551 NG(JS)=NG(JS)-1
21552 ENDIF
21553 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
21554
21555 DO 840 JS=1,2
21556C...Collapse fictitious gluons.
21557 DO 670 IGL=MINT(53)+1,N
21558 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
21559 & K(IGL,1).EQ.14) THEN
21560 ICM=K(IGL,4)/MSTU(5)
21561 IAM=K(IGL,5)/MSTU(5)
21562 ICD=MOD(K(IGL,4),MSTU(5))
21563 IAD=MOD(K(IGL,5),MSTU(5))
21564C...Set gluon daughters pointing to gluon mothers
21565 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
21566 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
21567C...Set gluon mothers pointing to gluon daughters.
21568 IF (K(ICM,2).NE.88) THEN
21569 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
21570 ELSE
21571C...Special case: mother=junction. Just update JST array for now.
21572 DO 650 MSJ=1,3
21573 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
21574 650 CONTINUE
21575 ENDIF
21576 IF (K(IAM,2).NE.88) THEN
21577 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
21578 ELSE
21579 DO 660 MSJ=1,3
21580 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
21581 660 CONTINUE
21582 ENDIF
21583 ENDIF
21584 670 CONTINUE
21585
21586C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
21587 IM=NMI(JS)+1
21588 680 IM=IM-1
21589 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
21590 IF (IM.GT.MINT(31)) THEN
21591 NMI(JS)=NMI(JS)-1
21592 DO 690 IMR=IM,NMI(JS)
21593 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21594 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21595 690 CONTINUE
21596 GOTO 680
21597 ENDIF
21598
21599C...Finally, connect junction.
21600 IF (ITJUNC(JS).NE.0) THEN
21601 DO 700 I=MINT(53)+1,N
21602 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21603 700 CONTINUE
21604C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21605 NBRJQ =0
21606 NBRVQ =0
21607 DO 720 MSJ=1,3
21608 IDQ(MSJ)=0
21609C...Find jq with no glue inbetween inside beam remnant.
21610 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21611 & THEN
21612 NBRJQ=NBRJQ+1
21613C...Set IDQ = -I if q non-valence and = +I if q valence.
21614 IDQ(NBRJQ)=-JST(JS,MSJ)
21615 DO 710 JV=1,3
21616 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21617 IDQ(NBRJQ)=JST(JS,MSJ)
21618 NBRVQ=NBRVQ+1
21619 ENDIF
21620 710 CONTINUE
21621 ENDIF
21622 I12=MOD(MSJ+1,2)
21623 I45=5
21624 IF (MSJ.EQ.3) I45=4
21625 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21626 720 CONTINUE
21627
21628C...Check if diquark can be formed.
21629 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21630 & .GE.1)) THEN
21631C...If there is less than 2 valence quarks connected to junction
21632C...and MSTP(88)>1, use random non-valence quarks to fill up.
21633 IF (NBRVQ.LE.1) THEN
21634 NDIQ=NBRVQ
21635 730 JFLIP=NBRJQ*PYR(0)+1
21636 IF (IDQ(JFLIP).LT.0) THEN
21637 IDQ(JFLIP)=-IDQ(JFLIP)
21638 NDIQ=NDIQ+1
21639 ENDIF
21640 IF (NDIQ.LE.1) GOTO 730
21641 ENDIF
21642C...Place selected quarks first in IDQ, ordered in flavour.
21643 DO 740 JDQ=1,3
21644 IF (IDQ(JDQ).LE.0) THEN
21645 ITEMP1 = IDQ(JDQ)
21646 IDQ(JDQ)= IDQ(3)
21647 IDQ(3) = -ITEMP1
21648 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21649 ITEMP1 = IDQ(1)
21650 IDQ(1) = IDQ(2)
21651 IDQ(2) = ITEMP1
21652 ENDIF
21653 ENDIF
21654 740 CONTINUE
21655C...Choose diquark spin.
21656 IF (NBRVQ.EQ.2) THEN
21657C...If the selected quarks are both valence, we may use SU(6) rules
21658C...to figure out which spin the diquark has, by a subdivision of the
21659C...original beam hadron into the selected diquark system plus a kicked
21660C...out quark, IKO.
21661 JKO=6
21662 DO 760 JDQ=1,2
21663 DO 750 JV=1,3
21664 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21665 750 CONTINUE
21666 760 CONTINUE
21667 IKO=IV(JS,JKO)
21668 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21669 ELSE
21670C...If one or more of the selected quarks are not valence, we cannot use
21671C...SU(6) subdivisions of the original beam hadron. Instead, with the
21672C...flavours of the diquark already selected, we assume for now
21673C...50:50 spin-1:spin-0 (where spin-0 possible).
21674 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21675 IS=3
21676 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21677 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21678 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21679 ENDIF
21680
21681C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21682C...Note: third quark can per definition not also be valence,
21683C...therefore we can only do this if we are allowed to use sea quarks.
21684 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21685 NTRY=0
21686 780 NTRY=NTRY+1
21687 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21688 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21689 GOTO 780
21690 ELSEIF(NTRY.GT.100) THEN
21691C...If no baryon can be found, give up and form diquark.
21692 IDQ(3)=0
21693 GOTO 770
21694 ELSE
21695C...Replace junction by baryon.
21696 K(IJU,1)=1
21697 K(IJU,2)=KFBAR
21698 K(IJU,3)=MINT(83)+JS
21699 K(IJU,4)=0
21700 K(IJU,5)=0
21701 P(IJU,5)=PYMASS(KFBAR)
21702 DO 790 MSJ=1,3
21703C...Prepare removal of participating quarks from ER.
21704 K(JST(JS,MSJ),1)=-1
21705 790 CONTINUE
21706 ENDIF
21707 ELSE
21708C...If collapse to baryon not possible or not allowed, replace junction
21709C...by diquark. This way, collapsed gluons that were pointing at the
21710C...junction will now point (correctly) at diquark.
21711 MANTI=ITJUNC(JS)-1
21712 K(IJU,1)=3
21713 K(IJU,2)=KFDQ
21714 K(IJU,3)=MINT(83)+JS
21715 K(IJU,4)=0
21716 K(IJU,5)=0
21717 DO 800 MSJ=1,3
21718 IP=JST(JS,MSJ)
21719 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21720 K(IJU,4+MANTI)=0
21721 K(IJU,5-MANTI)=IP*MSTU(5)
21722 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21723 & MSTU(5)*IJU
21724 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21725 ELSE
21726C...Prepare removal of participating quarks from ER.
21727 K(IP,1)=-1
21728 ENDIF
21729 800 CONTINUE
21730 ENDIF
21731
21732C...Update so ER pointers to collapsed quarks
21733C...now go to collapsed object.
21734 DO 820 I=MINT(84)+1,N
21735 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21736 & .K(I,1).GT.0) THEN
21737 DO 810 ISID=4,5
21738 IMO=K(I,ISID)/MSTU(5)
21739 IDA=MOD(K(I,ISID),MSTU(5))
21740 IF (IMO.GT.0) THEN
21741 IF (K(IMO,1).EQ.-1) IMO=IJU
21742 ENDIF
21743 IF (IDA.GT.0) THEN
21744 IF (K(IDA,1).EQ.-1) IDA=IJU
21745 ENDIF
21746 K(I,ISID)=IDA+MSTU(5)*IMO
21747 810 CONTINUE
21748 ENDIF
21749 820 CONTINUE
21750 ENDIF
21751 ENDIF
21752
21753C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21754C...(this only happens for baryons, where we want to force the gluon
21755C...to sit next to the junction. Mesons handled above.)
21756 IF (NBRTOT(JS).EQ.0) THEN
21757 N=N+1
21758 DO 830 IX=1,5
21759 K(N,IX)=0
21760 P(N,IX)=0D0
21761 V(N,IX)=0D0
21762 830 CONTINUE
21763 IGL=N
21764 K(IGL,1)=3
21765 K(IGL,2)=21
21766 K(IGL,3)=MINT(83)+JS
21767 IF (ITJUNC(JS).NE.0) THEN
21768C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21769 JLEG=PYR(0)*NVSUM(JS)+1
21770 I1=JST(JS,JLEG)
21771 JST(JS,JLEG)=IGL
21772 JCT=MCT(I1,ITJUNC(JS))
21773 MCT(IGL,3-ITJUNC(JS))=JCT
21774 NCT=NCT+1
21775 MCT(IGL,ITJUNC(JS))=NCT
21776 MANTI=ITJUNC(JS)-1
21777 ELSE
21778C...Meson. Should not happen.
21779 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21780 IF(NERRPR.LT.5) THEN
21781 WRITE(MSTU(11),*) 'This should not have been possible!'
21782 CALL PYLIST(4)
21783 NERRPR=NERRPR+1
21784 ENDIF
21785 MINT(51)=1
21786 RETURN
21787 ENDIF
21788 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21789 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21790 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21791 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21792 IF (K(I2,2).NE.88) THEN
21793 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21794 ELSE
21795 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21796 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21797 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21798 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21799 ELSE
21800 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21801 ENDIF
21802 ENDIF
21803 ENDIF
21804 840 CONTINUE
21805
21806C...Remove collapsed quarks and junctions from ER and update IMI.
21807 CALL PYEDIT(11)
21808
21809C...Also update beam remnant part of IMI.
21810 NMI(1)=MINT(31)
21811 NMI(2)=MINT(31)
21812 DO 850 I=MINT(53)+1,N
21813 IF (K(I,1).LE.0) GOTO 850
21814C...Restore BR quark/diquark/baryon pointers in IMI.
21815 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21816 JS=K(I,3)-MINT(83)
21817 NMI(JS)=NMI(JS)+1
21818 IMI(JS,NMI(JS),1)=I
21819 IMI(JS,NMI(JS),2)=0
21820 ENDIF
21821 850 CONTINUE
21822
21823C...Restore companion information from collapsed gluons.
21824 DO 870 I=MINT(53)+1,N
21825 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21826 JS=K(I,3)-MINT(83)
21827 JCD=MOD(K(I,4),MSTU(5))
21828 JAD=MOD(K(I,5),MSTU(5))
21829 DO 860 IM=1,NMI(JS)
21830 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21831 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21832 860 CONTINUE
21833 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21834 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21835 ENDIF
21836 870 CONTINUE
21837
21838C...Renumber colour lines (since some have disappeared)
21839 JCT=0
21840 JCD=0
21841 880 JCT=JCT+1
21842 MFOUND=0
21843 I=MINT(84)
21844 890 I=I+1
21845 IF (I.EQ.N+1) THEN
21846 IF (MFOUND.EQ.0) JCD=JCD+1
21847 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21848 MCT(I,1)=JCT-JCD
21849 MFOUND=1
21850 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21851 MCT(I,2)=JCT-JCD
21852 MFOUND=1
21853 ENDIF
21854 IF (I.LE.N) GOTO 890
21855 IF (JCT.LT.NCT) GOTO 880
21856 NCT=JCT-JCD
21857
21858C...Reset hard interaction subsystems to their CM frames.
21859 IF (IBOOST.EQ.1) THEN
21860 DO 900 IM=1,MINT(31)
21861 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21862 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21863 900 CONTINUE
21864C...Zero beam remnant longitudinal momenta and energies
21865 DO 910 I=MINT(53)+1,N
21866 P(I,3)=0D0
21867 P(I,4)=0D0
21868 910 CONTINUE
21869 ELSE
21870 CALL PYERRM(9
21871 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21872C...Kill event and start another.
21873 MINT(51)=1
21874 RETURN
21875 ENDIF
21876
21877 9999 RETURN
21878 END
21879C*********************************************************************
21880
21881C...PYCTTR
21882C...Adapted from PYPREP.
21883C...Assigns LHA1 colour tags to coloured partons based on
21884C...K(I,4) and K(I,5) colour connection record.
21885C...KCS negative signifies that a previous tracing should be continued.
21886C...(in case the tag to be continued is empty, the routine exits)
21887C...Starts at I and ends at I or IEND.
21888C...Special considerations for systems with junctions.
21889
21890 SUBROUTINE PYCTTR(I,KCS,IEND)
21891C...Double precision and integer declarations.
21892 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21893 INTEGER PYK,PYCHGE,PYCOMP
21894C...Commonblocks.
21895 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21896 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21897 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21898 COMMON/PYINT1/MINT(400),VINT(400)
21899C...The common block of colour tags.
21900 COMMON/PYCTAG/NCT,MCT(4000,2)
21901 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21902 DATA NERRPR/0/
21903 SAVE NERRPR
21904
21905C...Skip if parton not existing or does not have KCS
21906 IF (K(I,1).LE.0) GOTO 120
21907 KC=PYCOMP(K(I,2))
21908 IF (KC.EQ.0) GOTO 120
21909 KQ=KCHG(KC,2)
21910 IF (KQ.EQ.0) GOTO 120
21911 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21912 & GOTO 120
21913
21914 IF (KCS.GT.0) THEN
21915 NCT=NCT+1
21916C...Set colour tag of first parton.
21917 MCT(I,KCS-3)=NCT
21918 NCS=NCT
21919 ELSE
21920 KCS=-KCS
21921 NCS=MCT(I,KCS-3)
21922 IF (NCS.EQ.0) GOTO 120
21923 ENDIF
21924
21925 IA=I
21926 NSTP=0
21927 100 NSTP=NSTP+1
21928 IF(NSTP.GT.4*N) THEN
21929 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21930 GOTO 120
21931 ENDIF
21932
21933C...Finished if reached final-state triplet.
21934 IF(K(IA,1).EQ.3) THEN
21935 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21936 ENDIF
21937
21938C...Also finished if reached junction.
21939 IF(K(IA,1).EQ.42) THEN
21940 GOTO 120
21941 ENDIF
21942
21943C...GOTO next parton in colour space.
21944 110 IB=IA
21945C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21946 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21947 & .NE.0) THEN
21948 IA=MOD(K(IB,KCS),MSTU(5))
21949 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21950 MREV=0
21951 ELSE
21952C...If KCS mother traced or KCS mother nonexistent, switch colour.
21953 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21954 & MSTU(5)).EQ.0) THEN
21955 KCS=9-KCS
21956 NCT=NCT+1
21957 NCS=NCT
21958C...Assign new colour tag on other side of old parton.
21959 MCT(IB,KCS-3)=NCT
21960 ENDIF
21961C...Goto (new) KCS mother, set mother traced tag
21962 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21963 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21964 MREV=1
21965 ENDIF
21966 IF(IA.LE.0.OR.IA.GT.N) THEN
21967 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21968 IF(NERRPR.LT.5) THEN
21969 write(*,*) 'began at ',I
21970 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
21971 & ' NCS=',NCS,' MREV=',MREV
21972 CALL PYLIST(4)
21973 NERRPR=NERRPR+1
21974 ENDIF
21975 MINT(51)=1
21976 RETURN
21977 ENDIF
21978 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21979 & MSTU(5)).EQ.IB) THEN
21980 IF(MREV.EQ.1) KCS=9-KCS
21981 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21982C...Set KSC mother traced tag for IA
21983 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21984 ELSE
21985 IF(MREV.EQ.0) KCS=9-KCS
21986 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
21987C...Set KCS daughter traced tag for IA
21988 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
21989 ENDIF
21990C...Assign new colour tag
21991 MCT(IA,KCS-3)=NCS
21992 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
21993
21994 120 RETURN
21995 END
21996
21997*********************************************************************
21998
21999C...PYMIHG
22000C...Collapse JCP1 and connecting tags to JCG1.
22001C...Collapse JCP2 and connecting tags to JCG2.
22002
22003 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22004C...Double precision and integer declarations.
22005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22006 IMPLICIT INTEGER(I-N)
22007 INTEGER PYK,PYCHGE,PYCOMP
22008C...The event record
22009 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22010C...Parameters
22011 COMMON/PYINT1/MINT(400),VINT(400)
22012 SAVE /PYJETS/,/PYINT1/
22013C...Local variables
22014 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22015 COMMON /PYCTAG/NCT,MCT(4000,2)
22016 SAVE /PYCBLS/,/PYCTAG/
22017
22018C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22019C...in temporary tag collapse array JCCN. Only break up one connection.
22020 MACCPT=1
22021 MCLPS=0
22022 DO 100 ICC=1,NCC
22023 JCCN(ICC,1)=JCCO(ICC,1)
22024 JCCN(ICC,2)=JCCO(ICC,2)
22025C...If there was a mother, it was previously connected to JCP1.
22026C...Should be changed to JCP2.
22027 IF (MCLPS.EQ.0) THEN
22028 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22029 & ,JCP2)) THEN
22030 JCCN(ICC,1)=MAX(JCG2,JCP2)
22031 JCCN(ICC,2)=MIN(JCG2,JCP2)
22032 MCLPS=1
22033 ENDIF
22034 ENDIF
22035 100 CONTINUE
22036C...Also collapse colours on JCP1 side of JCG1
22037 IF (JCP1.NE.0) THEN
22038 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22039 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22040 ELSE
22041 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22042 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22043 ENDIF
22044
22045C...Initialize event record colour tag array MCT array to MCO.
22046 DO 110 I=MINT(84)+1,N
22047 MCT(I,1)=MCO(I,1)
22048 MCT(I,2)=MCO(I,2)
22049 110 CONTINUE
22050
22051C...Collapse tags:
22052C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22053C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22054C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22055C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22056 DO 160 IS=1,4
22057C...Skip if junction.
22058 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22059C...Define starting point in tag space.
22060C...JCA = previous tag
22061C...JCO = present tag
22062C...JCN = new tag
22063 IF (MOD(IS,2).EQ.1) THEN
22064 JCO=JCP1
22065 JCN=JCG1
22066 JCALL=JCG1
22067 ELSEIF (MOD(IS,2).EQ.0) THEN
22068 JCO=JCP2
22069 JCN=JCG2
22070 JCALL=JCG2
22071 ENDIF
22072 ITRACE=0
22073 120 ITRACE=ITRACE+1
22074 IF (ITRACE.GT.1000) THEN
22075C...NB: Proper error message should be defined here.
22076 CALL PYERRM(14
22077 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22078 MINT(57)=MINT(57)+1
22079 MINT(51)=1
22080 RETURN
22081 ENDIF
22082C...Collapse all JCN tags to JCALL
22083 DO 130 I=MINT(84)+1,N
22084 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22085 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22086 130 CONTINUE
22087C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22088 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22089 JCA=JCN
22090 JCN=JCO
22091 ELSE
22092 JCA=JCO
22093 JCO=JCN
22094 ENDIF
22095C...If possible, step from JCO to new tag JCN not equal to JCA.
22096 DO 140 ICC=1,NCC+1
22097 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22098 & JCCN(ICC,2)
22099 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22100 & JCCN(ICC,1)
22101 140 CONTINUE
22102C...Iterate if new colour was arrived at, but don't go in circles.
22103 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22104C...Change all JCN tags in MCO to JCALL in MCT.
22105 DO 150 I=MINT(84)+1,N
22106 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22107 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22108C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22109 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22110 & .NE.0) MACCPT=0
22111 150 CONTINUE
22112 160 CONTINUE
22113
22114 DO 200 JCL=NCT,1,-1
22115 JCA=0
22116 JCN=JCL
22117 170 JCO=JCN
22118 DO 180 ICC=1,NCC+1
22119 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22120 & =JCCN(ICC,2)
22121 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22122 & =JCCN(ICC,1)
22123 180 CONTINUE
22124C...Overpaint all JCN with JCL
22125 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22126 DO 190 I=MINT(84)+1,N
22127 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22128 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22129C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22130 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22131 & .NE.0) MACCPT=0
22132 190 CONTINUE
22133 JCA=JCO
22134 GOTO 170
22135 ENDIF
22136 200 CONTINUE
22137
22138 RETURN
22139 END
22140
22141C*********************************************************************
22142
22143C...PYMIRM
22144C...Picks primordial kT and shares longitudinal momentum among
22145C...beam remnants.
22146
22147 SUBROUTINE PYMIRM
22148
22149C...Double precision and integer declarations.
22150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22151 IMPLICIT INTEGER(I-N)
22152 INTEGER PYK,PYCHGE,PYCOMP
22153C...The event record
22154 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22155C...Parameters
22156 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22157 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22158 COMMON/PYINT1/MINT(400),VINT(400)
22159C...The common block of colour tags.
22160 COMMON/PYCTAG/NCT,MCT(4000,2)
22161C...The common block of dangling ends
22162 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22163 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22164 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22165 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22166C...Local variables
22167 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22168C...W(I,J)| J=0 | 1 | 2 |
22169C... I=0 | Wrem**2 | W+ | W- |
22170C... 1 | W1**2 | W1+ | W1- |
22171C... 2 | W2**2 | W2+ | W2- |
22172C...4-product
22173 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)
22174C...Tentative parametrization of <kT> as a function of Q.
22175 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22176C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22177C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22178 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22179C...Lambda kinematic function.
22180 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22181
22182C...Beginning and end of beam remnant partons
22183 NOUT=MINT(53)
22184 ISUB=MINT(1)
22185
22186C...Loopback point if kinematic choices gives impossible configuration.
22187 NTRY=0
22188 100 NTRY=NTRY+1
22189
22190C...Assign kT values on each side separately.
22191 DO 180 JS=1,2
22192
22193C...First zero all kT on this side. Skip if no kT to generate.
22194 DO 110 IM=1,NMI(JS)
22195 P(IMI(JS,IM,1),1)=0D0
22196 P(IMI(JS,IM,1),2)=0D0
22197 110 CONTINUE
22198 IF(MSTP(91).LE.0) GOTO 180
22199
22200C...Now assign kT to each (non-collapsed) parton in IMI.
22201 DO 170 IM=1,NMI(JS)
22202 I=IMI(JS,IM,1)
22203C...Select kT according to truncated gaussian or 1/kt6 tails.
22204C...For first interaction, either use rms width = PARP(91) or fitted.
22205 IF (IM.EQ.1) THEN
22206 SIGMA=PARP(91)
22207 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22208 Q=SQRT(PT2MI(IM))
22209 SIGMA=SIGPT(Q)
22210 ENDIF
22211 ELSE
22212C...For subsequent interactions and BR partons use fragmentation width.
22213 SIGMA=PARJ(21)
22214 ENDIF
22215 PHI=PARU(2)*PYR(0)
22216 PT=0D0
22217 IF(NTRY.LE.100) THEN
22218 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22219 PT=GETPT(Q,SIGMA)
22220 PTX=PT*COS(PHI)
22221 PTY=PT*SIN(PHI)
22222 ELSEIF (MSTP(91).EQ.2) THEN
22223 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22224 & 'available, using MSTP(91)=1.')
22225 CALL PYGIVE('MSTP(91)=1')
22226 GOTO 111
22227 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22228C...Use distribution with kt**6 tails, rms width = PARP(91).
22229 EPS=SQRT(3D0/2D0)*SIGMA
22230C...Generate PTX and PTY separately, each propto 1/KT**6
22231 DO 119 IXY=1,2
22232C...Decide which interval to try
22233 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22234 IF (PYR(0).LT.P12) THEN
22235C...Use flat approx with accept/reject up to EPS.
22236 PT=PYR(0)*EPS
22237 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22238 IF (PYR(0).GT.WT) GOTO 112
22239 ELSE
22240C...Above EPS, use 1/kt**6 approx with accept/reject.
22241 PT=EPS/(PYR(0)**(1D0/5D0))
22242 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22243 IF (PYR(0).GT.WT) GOTO 112
22244 ENDIF
22245 MSIGN=1
22246 IF (PYR(0).GT.0.5D0) MSIGN=-1
22247 IF (IXY.EQ.1) PTX=MSIGN*PT
22248 IF (IXY.EQ.2) PTY=MSIGN*PT
22249 119 CONTINUE
22250 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22251 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22252 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22253 ENDIF
22254C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22255 PT=SQRT(PTX**2+PTY**2)
22256 WT=1D0
22257 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22258 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22259 PTX=PTX*WT
22260 PTY=PTY*WT
22261 PT=SQRT(PTX**2+PTY**2)
22262 ENDIF
22263
22264 P(I,1)=P(I,1)+PTX
22265 P(I,2)=P(I,2)+PTY
22266
22267C...Compensation kicks, with varying degree of local anticorrelations.
22268 MCORR=MSTP(90)
22269 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22270 PTCX=-PTX/(NMI(JS)-1)
22271 PTCY=-PTY/(NMI(JS)-1)
22272 IF(ISUB.EQ.95) THEN
22273 PTCX=-PTX/(NMI(JS)-2)
22274 PTCY=-PTY/(NMI(JS)-2)
22275 ENDIF
22276 DO 120 IMC=1,NMI(JS)
22277 IF (IMC.EQ.IM) GOTO 120
22278 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22279 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22280 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22281 120 CONTINUE
22282 ELSEIF (MCORR.GE.1) THEN
22283 DO 140 MSID=4,5
22284 NNXT(MSID-3)=0
22285C...Count up # of neighbours on either side
22286 IMO=I
22287 130 IMO=K(IMO,MSID)/MSTU(5)
22288 IF (IMO.EQ.0) GOTO 140
22289 NNXT(MSID-3)=NNXT(MSID-3)+1
22290C...Stop at quarks and junctions
22291 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22292 140 CONTINUE
22293C...How should compensation be shared when unequal numbers on the
22294C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22295 NSUM=NNXT(1)+NNXT(2)
22296 T1=0
22297 DO 160 MSID=4,5
22298C...Total momentum to be compensated on this side
22299 IF (NNXT(MSID-3).EQ.0) GOTO 160
22300 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22301 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22302C...RS: compensation supression factor as we go out from parton I.
22303C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22304C...since (for now) MSTP(90) provides enough variability.
22305 RS=0.5D0
22306 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22307 IMO=I
22308 150 IDA=IMO
22309 IMO=K(IMO,MSID)/MSTU(5)
22310 IF (IMO.EQ.0) GOTO 160
22311 FAC=FAC*RS
22312 IF (K(IMO,2).NE.88) THEN
22313 P(IMO,1)=P(IMO,1)+FAC*PTCX
22314 P(IMO,2)=P(IMO,2)+FAC*PTCY
22315 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22316C...If we reach junction, divide out the kT that would have been
22317C...assigned to the junction on each of its other legs.
22318 ELSE
22319 L1=MOD(K(IMO,4),MSTU(5))
22320 L2=K(IMO,5)/MSTU(5)
22321 L3=MOD(K(IMO,5),MSTU(5))
22322 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22323 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22324 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22325 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22326 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22327 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22328 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22329 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22330 ENDIF
22331
22332 160 CONTINUE
22333 ENDIF
22334 170 CONTINUE
22335C...End assignment of kT values to initiators and remnants.
22336 180 CONTINUE
22337
22338C...Check kinematics constraints for non-BR partons.
22339 DO 190 IM=1,MINT(31)
22340 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
22341 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
22342 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
22343 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
22344 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
22345 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
22346 IF(NTRY.GE.100) THEN
22347C...Kill this event and start another.
22348 CALL PYERRM(11,
22349 & '(PYMIRM:) No consistent (x,kT) sets found')
22350 MINT(51)=1
22351 RETURN
22352 ENDIF
22353 GOTO 100
22354 ENDIF
22355 190 CONTINUE
22356
22357C...Calculate W+ and W- available for combined remnant system.
22358 W(0,1)=VINT(1)
22359 W(0,2)=VINT(1)
22360 DO 200 IM=1,MINT(31)
22361 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
22362 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
22363 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
22364 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
22365 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
22366 200 CONTINUE
22367C...Also store Wrem**2 = W+ * W-
22368 W(0,0)=W(0,1)*W(0,2)
22369
22370 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
22371 IF(NTRY.GE.100) THEN
22372C...Kill this event and start another.
22373 CALL PYERRM(11,
22374 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22375 MINT(51)=1
22376 RETURN
22377 ENDIF
22378 GOTO 100
22379 ENDIF
22380
22381C...Assign unscaled x values to partons/hadrons in each of the
22382C...beam remnants and calculate unscaled W+ and W- from them.
22383 NTRYX=0
22384 210 NTRYX=NTRYX+1
22385 DO 280 JS=1,2
22386 W(JS,1)=0D0
22387 W(JS,2)=0D0
22388 DO 270 IM=MINT(31)+1,NMI(JS)
22389 I=IMI(JS,IM,1)
22390 KF=K(I,2)
22391 KFA=IABS(KF)
22392 ICOMP=IMI(JS,IM,2)
22393
22394C...Skip collapsed gluons and junctions. Reset.
22395 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
22396 IF (KFA.EQ.88) GOTO 270
22397 X=0D0
22398 IVALQ(1)=0
22399 IVALQ(2)=0
22400 ICOMQ(1)=0
22401 ICOMQ(2)=0
22402
22403C...If gluon then only beam remnant, so takes all.
22404 IF(KFA.EQ.21) THEN
22405 X=1D0
22406C...If valence quark then use parametrized valence distribution.
22407 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
22408 IVALQ(1)=KF
22409C...If companion quark then derive from companion x.
22410 ELSEIF(KFA.LE.6) THEN
22411 ICOMQ(1)=ICOMP
22412C...If valence diquark then use two parametrized valence distributions.
22413 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22414 & ICOMP.EQ.0) THEN
22415 IVALQ(1)=ISIGN(KFA/1000,KF)
22416 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
22417C...If valence+sea diquark then combine valence + companion choices.
22418 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22419 & ICOMP.LT.MSTU(5)) THEN
22420 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
22421 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
22422 ELSE
22423 IVALQ(1)=ISIGN(KFA/1000,KF)
22424 ENDIF
22425 ICOMQ(1)=ICOMP
22426C...Extra code: workaround for diquark made out of two sea
22427C...quarks, but where not (yet) ICOMP > MSTU(5).
22428 DO 220 IM1=1,MINT(31)
22429 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
22430 ICOMQ(2)=IMI(JS,IM1,1)
22431 IVALQ(1)=0
22432 ENDIF
22433 220 CONTINUE
22434C...If sea diquark then sum of two derived from companion x.
22435 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
22436 ICOMQ(1)=MOD(ICOMP,MSTU(5))
22437 ICOMQ(2)=ICOMP/MSTU(5)
22438C...If meson or baryon then use fragmentation function.
22439C...Somewhat arbitrary split into old and new flavour, but OK normally.
22440 ELSE
22441 KFL3=MOD(KFA/10,10)
22442 IF(MOD(KFA/1000,10).EQ.0) THEN
22443 KFL1=MOD(KFA/100,10)
22444 ELSE
22445 KFL1=MOD(KFA,10000)-10*KFL3-1
22446 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
22447 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
22448 ENDIF
22449 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
22450 CALL PYZDIS(KFL1,KFL3,PR,X)
22451 ENDIF
22452
22453 DO 260 IQ=1,2
22454C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
22455C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
22456C...In other baryons combine u and d from proton appropriately.
22457 IF(IVALQ(IQ).NE.0) THEN
22458 NVAL=0
22459 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
22460 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
22461 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
22462C...Meson.
22463 IF(KFIVAL(JS,3).EQ.0) THEN
22464 MDU=0
22465C...Baryon with three identical quarks: mix u and d forms.
22466 ELSEIF(NVAL.EQ.3) THEN
22467 MDU=INT(PYR(0)+5D0/3D0)
22468C...Baryon, one of two identical quarks: u form.
22469 ELSEIF(NVAL.EQ.2) THEN
22470 MDU=2
22471C...Baryon with two identical quarks, but not the one picked: d form.
22472 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
22473 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
22474 MDU=1
22475C...Baryon with three nonidentical quarks: mix u and d forms.
22476 ELSE
22477 MDU=INT(PYR(0)+5D0/3D0)
22478 ENDIF
22479 XPOW=0.8D0
22480 IF(MDU.EQ.1) XPOW=3.5D0
22481 IF(MDU.EQ.2) XPOW=2D0
22482 230 XX=PYR(0)**2
22483 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
22484 X=X+XX
22485 ENDIF
22486
22487C...Calculation of x of companion quark.
22488 IF(ICOMQ(IQ).NE.0) THEN
22489 XCOMP=1D-4
22490 DO 240 IM1=1,MINT(31)
22491 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
22492 240 CONTINUE
22493 NPOW=MAX(0,MIN(4,MSTP(87)))
22494 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
22495 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
22496 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
22497 IF(CORR.LT.PYR(0)) GOTO 250
22498 X=X+XX
22499 ENDIF
22500 260 CONTINUE
22501
22502C...Optionally enchance x of composite systems (e.g. diquarks)
22503 IF (KFA.GT.100) X=PARP(79)*X
22504
22505C...Store x. Also calculate light cone energies of each system.
22506 XMI(JS,IM)=X
22507 W(JS,JS)=W(JS,JS)+X
22508 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
22509 270 CONTINUE
22510 W(JS,JS)=W(JS,JS)*W(0,JS)
22511 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
22512 W(JS,0)=W(JS,1)*W(JS,2)
22513 280 CONTINUE
22514
22515C...Check W1 W2 < Wrem (can be done before rescaling, since W
22516C...insensitive to global rescalings of the BR x values).
22517 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
22518 & THEN
22519 GOTO 210
22520 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
22521 GOTO 100
22522 ELSEIF (NTRYX.GT.100) THEN
22523 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
22524 MINT(57)=MINT(57)+1
22525 MINT(51)=1
22526 RETURN
22527 ENDIF
22528
22529C...Compute x rescaling factors
22530 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
22531 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
22532 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
22533
22534 IF (R1.LT.0.OR.R2.LT.0) THEN
22535 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
22536 MINT(57)=MINT(57)+1
22537 MINT(51)=1
22538 ENDIF
22539
22540C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
22541 W(1,1)=W(1,1)*R1
22542 W(1,2)=W(1,2)/R1
22543 W(2,1)=W(2,1)/R2
22544 W(2,2)=W(2,2)*R2
22545
22546C...Rescale BR x values.
22547 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
22548 XMI(1,IM)=XMI(1,IM)*R1
22549 XMI(2,IM)=XMI(2,IM)*R2
22550 290 CONTINUE
22551
22552C...Now we have a consistent set of x and kT values.
22553C...First set up the initiators and their daughters correctly.
22554 DO 300 IM=1,MINT(31)
22555 I1=IMI(1,IM,1)
22556 I2=IMI(2,IM,1)
22557 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
22558 & (P(I1,2)+P(I2,2))**2
22559 PT12=P(I1,1)**2+P(I1,2)**2
22560 PT22=P(I2,1)**2+P(I2,2)**2
22561C...p_z
22562 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
22563 P(I2,3)=-P(I1,3)
22564C...Energies (masses should be zero at this stage)
22565 P(I1,4)=SQRT(PT12+P(I1,3)**2)
22566 P(I2,4)=SQRT(PT22+P(I2,3)**2)
22567
22568C...Transverse 12 system initiator velocity:
22569 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
22570 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
22571C...Boost to overall initiator system rest frame
22572 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
22573 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
22574
22575C...Compute phi,theta coordinates of I1 and rotate z axis.
22576 PHI=PYANGL(P(I1,1),P(I1,2))
22577 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
22578 IMIN=IMISEP(IM-1)+1
22579C...(include documentation lines if MI = 1)
22580 IF (IM.EQ.1) IMIN=MINT(83)+5
22581 IMAX=IMISEP(IM)
22582C...Rotate entire system in phi
22583 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
22584C...Only rotate 12 system in theta
22585 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
22586 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
22587
22588C...Now boost entire system back to LAB
22589 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22590 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
22591 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
22592
22593 300 CONTINUE
22594
22595
22596C...For the beam remnant partons/hadrons, we only need to set pz and E.
22597 DO 320 JS=1,2
22598 DO 310 IM=MINT(31)+1,NMI(JS)
22599 I=IMI(JS,IM,1)
22600C...Skip collapsed gluons and junctions.
22601 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22602 IF (KFA.EQ.88) GOTO 310
22603 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22604 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22605 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22606 IF (JS.EQ.2) P(I,3)=-P(I,3)
22607 310 CONTINUE
22608 320 CONTINUE
22609
22610
22611C...Documentation lines
22612 DO 340 JS=1,2
22613 IN=MINT(83)+JS+2
22614 IO=IMI(JS,1,1)
22615 K(IN,1)=21
22616 K(IN,2)=K(IO,2)
22617 K(IN,3)=MINT(83)+JS
22618 K(IN,4)=0
22619 K(IN,5)=0
22620 DO 330 J=1,5
22621 P(IN,J)=P(IO,J)
22622 V(IN,J)=V(IO,J)
22623 330 CONTINUE
22624 MCT(IN,1)=MCT(IO,1)
22625 MCT(IN,2)=MCT(IO,2)
22626 340 CONTINUE
22627
22628C...Final state colour reconnections.
22629 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22630
22631C...Number of colour tags for which a recoupling will be tried.
22632 NTOT=NCT
22633C...Number of recouplings to try
22634 MINT(34)=0
22635 NRECP=0
22636 NITER=0
22637 350 NRECP=MINT(34)
22638 NITER=NITER+1
22639 IITER=0
22640 360 IITER=IITER+1
22641 IF (IITER.LE.PARP(78)*NTOT) THEN
22642C...Select two colour tags at random
22643C...NB: jj strings do not have colour tags assigned to them,
22644C...thus they are as yet not affected by anything done here.
22645 JCT=PYR(0)*NCT+1
22646 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22647 IJ1=0
22648 IJ2=0
22649 IK1=0
22650 IK2=0
22651C...Find final state partons with this (anti)colour
22652 DO 370 I=MINT(84)+1,N
22653 IF (K(I,1).EQ.3) THEN
22654 IF (MCT(I,1).EQ.JCT) IJ1=I
22655 IF (MCT(I,2).EQ.JCT) IJ2=I
22656 IF (MCT(I,1).EQ.KCT) IK1=I
22657 IF (MCT(I,2).EQ.KCT) IK2=I
22658 ENDIF
22659 370 CONTINUE
22660C...Only consider recouplings not involving junctions for now.
22661 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22662
22663 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22664 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22665 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22666 MCT(IJ2,2)=KCT
22667 MCT(IK2,2)=JCT
22668C...Count up number of reconnections
22669 MINT(34)=MINT(34)+1
22670 ENDIF
22671 IF (MINT(34).LE.1000) THEN
22672 GOTO 360
22673 ELSE
22674 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22675 GOTO 380
22676 ENDIF
22677 ENDIF
22678 IF (NRECP.LT.MINT(34)) GOTO 350
22679
22680C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22681 380 MINT(33)=1
22682
22683 RETURN
22684 END
22685
22686C*********************************************************************
22687
22688C...PYFSCR
22689C...Performs colour annealing.
22690C...MSTP(95) : CR Type
22691C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22692C... = 2 : Type I(no gg loops); hadron-hadron only
22693C... = 3 : Type I(no gg loops); all beams
22694C... = 4 : Type II(gg loops) ; hadron-hadron only
22695C... = 5 : Type II(gg loops) ; all beams
22696C... = 6 : Type S ; hadron-hadron only
22697C... = 7 : Type S ; all beams
22698C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22699C...Type S is driven by starting only from free triplets, not octets.
22700C...A string piece remains unchanged with probability
22701C... PKEEP = (1-PARP(78))**N
22702C...This scaling corresponds to each string piece having to go through
22703C...N other ones, each with probability PARP(78) for reconnection, where
22704C...N is here chosen simply as the number of multiple interactions,
22705C...for a rough scaling with the general level of activity.
22706
22707 SUBROUTINE PYFSCR(IP)
22708C...Double precision and integer declarations.
22709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22710 INTEGER PYK,PYCHGE,PYCOMP
22711C...Commonblocks.
22712 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22713 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22714 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22715 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22716 COMMON/PYINT1/MINT(400),VINT(400)
22717C...The common block of colour tags.
22718 COMMON/PYCTAG/NCT,MCT(4000,2)
22719 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22720 &/PYPARS/
22721C...MCN: Temporary storage of new colour tags
22722 DOUBLE PRECISION MCN(4000,2)
22723
22724C...Function to give four-product.
22725 FOUR(I,J)=P(I,4)*P(J,4)
22726 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22727
22728C...Check valid range of MSTP(95), local copy
22729 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22730 MSTP95=MOD(MSTP(95),10)
22731C...Set whether CR allowed inside resonance systems or not
22732C...(not implemented yet)
22733C MRESCR=1
22734C IF (MSTP(95).GE.10) MRESCR=0
22735
22736C...Check whether colour tags already defined
22737 IF (MINT(33).EQ.0) THEN
22738C...Erase any existing colour tags for this event
22739 DO 100 I=1,N
22740 MCT(I,1)=0
22741 MCT(I,2)=0
22742 100 CONTINUE
22743C...Create colour tags for this event
22744 DO 120 I=1,N
22745 IF (K(I,1).EQ.3) THEN
22746 DO 110 KCS=4,5
22747 KCSIN=KCS
22748 IF (MCT(I,KCSIN-3).EQ.0) THEN
22749 CALL PYCTTR(I,KCSIN,I)
22750 ENDIF
22751 110 CONTINUE
22752 ENDIF
22753 120 CONTINUE
22754C...Instruct PYPREP to use colour tags
22755 MINT(33)=1
22756 ENDIF
22757
22758C...For MSTP(95) even, only apply to hadron-hadron
22759 IF (MOD(MSTP(95),2).EQ.0) THEN
22760 KA1=IABS(MINT(11))
22761 KA2=IABS(MINT(12))
22762 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22763 ENDIF
22764
22765C...Initialize new tag array (but do not delete old yet)
22766 LCT=NCT
22767 DO 130 I=MAX(1,IP),N
22768 MCN(I,1)=0
22769 MCN(I,2)=0
22770 130 CONTINUE
22771
22772C...For each final-state dipole, check whether string should be
22773C...preserved.
22774 DO 150 ICT=1,NCT
22775 IC=0
22776 IA=0
22777 DO 140 I=MAX(1,IP),N
22778 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22779 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22780 140 CONTINUE
22781 IF (IC.NE.0.AND.IA.NE.0) THEN
22782C...Chiefly consider large strings.
22783 PKEEP=(1D0-PARP(78))**MINT(31)
22784 IF (PYR(0).LE.PKEEP) THEN
22785 LCT=LCT+1
22786 MCN(IC,1)=LCT
22787 MCN(IA,2)=LCT
22788 ENDIF
22789 ENDIF
22790 150 CONTINUE
22791
22792C...Loop over event record, starting from IP
22793C...(Ignore junctions for now.)
22794 NLOOP=0
22795 160 NLOOP=NLOOP+1
22796 MCIMAX=0
22797 MCJMAX=0
22798 RLMAX=0D0
22799 ILMAX=0
22800 JLMAX=0
22801 DO 230 I=MAX(1,IP),N
22802 IF (K(I,1).NE.3) GOTO 230
22803C...Check colour charge
22804 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22805 IF (MCI.EQ.0) GOTO 230
22806C...For Seattle algorithm, only start from partons with one dangling
22807C...colour tag
22808 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22809 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22810 ENDIF
22811C... Find optimal partner
22812 JLOPT=0
22813 MCJOPT=0
22814 MBROPT=0
22815 MGGOPT=0
22816 RLOPT=1D19
22817C...Loop over I colour/anticolour, check whether already connected
22818 170 DO 220 ICL=1,2
22819 IF (MCN(I,ICL).NE.0) GOTO 220
22820 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22821 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22822C...Check whether this is a dangling colour tag (ie to junction!)
22823 IFOUND=0
22824 DO 180 J=MAX(1,IP),N
22825 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22826 180 CONTINUE
22827 IF (IFOUND.EQ.0) GOTO 220
22828 DO 210 J=MAX(1,IP),N
22829 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22830C...Do not make direct connections between partons in same Beam Remnant
22831 MBRSTR=0
22832 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22833 & MBRSTR=1
22834C...Check colour charge
22835 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22836 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22837C...Check for gluon loops
22838 MGGSTR=0
22839 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22840 ICLA=3-ICL
22841 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22842 & MCN(I,ICLA).NE.0) MGGSTR=1
22843 ENDIF
22844C...Loop over J colour/anticolour, check whether already connected
22845 DO 200 JCL=1,2
22846 IF (MCN(J,JCL).NE.0) GOTO 200
22847 IF (JCL.EQ.ICL) GOTO 200
22848 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22849 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22850C...Check whether this is a dangling colour tag (ie to junction!)
22851 IFOUND=0
22852 DO 190 J2=MAX(1,IP),N
22853 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22854 & IFOUND=1
22855 190 CONTINUE
22856 IF (IFOUND.EQ.0) GOTO 200
22857C...Save connection with smallest lambda measure
22858C...If best so far was a BR string and this is not, also save.
22859C...If best so far was a gg string and this is not, also save.
22860 RL=FOUR(I,J)
22861 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22862 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22863 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22864 RLOPT=RL
22865 JLOPT=J
22866 ICOPT=ICL
22867 JCOPT=JCL
22868 MCJOPT=MCJ
22869 MBROPT=MBRSTR
22870 MGGOPT=MGGSTR
22871 ENDIF
22872 200 CONTINUE
22873 210 CONTINUE
22874 220 CONTINUE
22875 IF (JLOPT.NE.0) THEN
22876C...Save pair with largest RLOPT so far
22877 IF (RLOPT.GE.RLMAX) THEN
22878 RLMAX=RLOPT
22879 ILMAX=I
22880 JLMAX=JLOPT
22881 ICMAX=ICOPT
22882 JCMAX=JCOPT
22883 MCJMAX=MCJOPT
22884 MCIMAX=MCI
22885 ENDIF
22886 ENDIF
22887 230 CONTINUE
22888C...Save and iterate
22889 IF (ILMAX.GT.0) THEN
22890 LCT=LCT+1
22891 MCN(ILMAX,ICMAX)=LCT
22892 MCN(JLMAX,JCMAX)=LCT
22893 IF (NLOOP.LE.2*(N-IP)) THEN
22894 GOTO 160
22895 ELSE
22896 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
22897 CALL PYSTOP(11)
22898 ENDIF
22899 ELSE
22900C...Save and exit. First check for leftover gluon(s)
22901 DO 260 I=MAX(1,IP),N
22902C...Check colour charge
22903 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22904 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22905 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22906C...Decide where to put left-over gluon (minimal insertion)
22907 ILMAX=0
22908 RLMAX=1D19
22909 DO 250 KCT=NCT+1,LCT
22910 DO 240 IT=MAX(1,IP),N
22911 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22912 IF (MCN(IT,1).EQ.KCT) IC=IT
22913 IF (MCN(IT,2).EQ.KCT) IA=IT
22914 240 CONTINUE
22915 RL=FOUR(IC,I)*FOUR(IA,I)
22916 IF (RL.LT.RLMAX) THEN
22917 RLMAX=RL
22918 ICMAX=IC
22919 IAMAX=IA
22920 ENDIF
22921 250 CONTINUE
22922 LCT=LCT+1
22923 MCN(I,1)=MCN(ICMAX,1)
22924 MCN(I,2)=LCT
22925 MCN(ICMAX,1)=LCT
22926 ENDIF
22927 260 CONTINUE
22928 DO 270 I=MAX(1,IP),N
22929C...Do not erase parton shower colour history
22930 IF (K(I,1).NE.3) GOTO 270
22931C...Check colour charge
22932 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22933 IF (MCI.EQ.0) GOTO 270
22934 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22935 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22936 270 CONTINUE
22937 ENDIF
22938
22939 9999 RETURN
22940 END
22941
22942C*********************************************************************
22943
22944C...PYDIFF
22945C...Handles diffractive and elastic scattering.
22946
22947 SUBROUTINE PYDIFF
22948
22949C...Double precision and integer declarations.
22950 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22951 IMPLICIT INTEGER(I-N)
22952 INTEGER PYK,PYCHGE,PYCOMP
22953C...Commonblocks.
22954 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22957 COMMON/PYINT1/MINT(400),VINT(400)
22958 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22959
22960C...Reset K, P and V vectors. Store incoming particles.
22961 DO 110 JT=1,MSTP(126)+10
22962 I=MINT(83)+JT
22963 DO 100 J=1,5
22964 K(I,J)=0
22965 P(I,J)=0D0
22966 V(I,J)=0D0
22967 100 CONTINUE
22968 110 CONTINUE
22969 N=MINT(84)
22970 MINT(3)=0
22971 MINT(21)=0
22972 MINT(22)=0
22973 MINT(23)=0
22974 MINT(24)=0
22975 MINT(4)=4
22976 DO 130 JT=1,2
22977 I=MINT(83)+JT
22978 K(I,1)=21
22979 K(I,2)=MINT(10+JT)
22980 DO 120 J=1,5
22981 P(I,J)=VINT(285+5*JT+J)
22982 120 CONTINUE
22983 130 CONTINUE
22984 MINT(6)=2
22985
22986C...Subprocess; kinematics.
22987 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
22988 PZ=SQRT(SQLAM)/(2D0*VINT(1))
22989 DO 200 JT=1,2
22990 I=MINT(83)+JT
22991 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
22992 KFH=MINT(102+JT)
22993
22994C...Elastically scattered particle. (Except elastic GVMD states.)
22995 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
22996 & MINT(106+JT).NE.3)) THEN
22997 N=N+1
22998 K(N,1)=1
22999 K(N,2)=KFH
23000 K(N,3)=I+2
23001 P(N,3)=PZ*(-1)**(JT+1)
23002 P(N,4)=PE
23003 P(N,5)=SQRT(VINT(62+JT))
23004
23005C...Decay rho from elastic scattering of gamma with sin**2(theta)
23006C...distribution of decay products (in rho rest frame).
23007 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23008 NSAV=N
23009 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23010 P(N,3)=0D0
23011 P(N,4)=P(N,5)
23012 CALL PYDECY(NSAV)
23013 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23014 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23015 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23016 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23017 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23018 140 CTHE=2D0*PYR(0)-1D0
23019 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23020 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23021 ENDIF
23022 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23023 ENDIF
23024
23025C...Diffracted particle: low-mass system to two particles.
23026 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23027 N=N+2
23028 K(N-1,1)=1
23029 K(N,1)=1
23030 K(N-1,3)=I+2
23031 K(N,3)=I+2
23032 PMMAS=SQRT(VINT(62+JT))
23033 NTRY=0
23034 150 NTRY=NTRY+1
23035 IF(NTRY.LT.20) THEN
23036 MINT(105)=MINT(102+JT)
23037 MINT(109)=MINT(106+JT)
23038 CALL PYSPLI(KFH,21,KFL1,KFL2)
23039 CALL PYKFDI(KFL1,0,KFL3,KF1)
23040 IF(KF1.EQ.0) GOTO 150
23041 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23042 IF(KF2.EQ.0) GOTO 150
23043 ELSE
23044 KF1=KFH
23045 KF2=111
23046 ENDIF
23047 PM1=PYMASS(KF1)
23048 PM2=PYMASS(KF2)
23049 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23050 K(N-1,2)=KF1
23051 K(N,2)=KF2
23052 P(N-1,5)=PM1
23053 P(N,5)=PM2
23054 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23055 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23056 P(N-1,3)=PZP
23057 P(N,3)=-PZP
23058 P(N-1,4)=SQRT(PM1**2+PZP**2)
23059 P(N,4)=SQRT(PM2**2+PZP**2)
23060 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23061 & 0D0,0D0,0D0)
23062 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23063 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23064
23065C...Diffracted particle: valence quark kicked out.
23066 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23067 & PARP(101))) THEN
23068 N=N+2
23069 K(N-1,1)=2
23070 K(N,1)=1
23071 K(N-1,3)=I+2
23072 K(N,3)=I+2
23073 MINT(105)=MINT(102+JT)
23074 MINT(109)=MINT(106+JT)
23075 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23076 P(N-1,5)=PYMASS(K(N-1,2))
23077 P(N,5)=PYMASS(K(N,2))
23078 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23079 & 4D0*P(N-1,5)**2*P(N,5)**2
23080 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23081 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23082 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23083 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23084 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23085
23086C...Diffracted particle: gluon kicked out.
23087 ELSE
23088 N=N+3
23089 K(N-2,1)=2
23090 K(N-1,1)=2
23091 K(N,1)=1
23092 K(N-2,3)=I+2
23093 K(N-1,3)=I+2
23094 K(N,3)=I+2
23095 MINT(105)=MINT(102+JT)
23096 MINT(109)=MINT(106+JT)
23097 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23098 K(N-1,2)=21
23099 P(N-2,5)=PYMASS(K(N-2,2))
23100 P(N-1,5)=0D0
23101 P(N,5)=PYMASS(K(N,2))
23102C...Energy distribution for particle into two jets.
23103 160 IMB=1
23104 IF(MOD(KFH/1000,10).NE.0) IMB=2
23105 CHIK=PARP(92+2*IMB)
23106 IF(MSTP(92).LE.1) THEN
23107 IF(IMB.EQ.1) CHI=PYR(0)
23108 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23109 ELSEIF(MSTP(92).EQ.2) THEN
23110 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23111 ELSEIF(MSTP(92).EQ.3) THEN
23112 CUT=2D0*0.3D0/VINT(1)
23113 170 CHI=PYR(0)**2
23114 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23115 & PYR(0)) GOTO 170
23116 ELSEIF(MSTP(92).EQ.4) THEN
23117 CUT=2D0*0.3D0/VINT(1)
23118 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23119 180 CHIR=CUT*CUTR**PYR(0)
23120 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23121 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23122 ELSE
23123 CUT=2D0*0.3D0/VINT(1)
23124 CUTA=CUT**(1D0-PARP(98))
23125 CUTB=(1D0+CUT)**(1D0-PARP(98))
23126 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23127 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23128 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23129 ENDIF
23130 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23131 & VINT(62+JT)) GOTO 160
23132 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23133 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23134 & (2D0*VINT(62+JT))
23135 PEI=SQRT(PZI**2+SQM)
23136 PQQP=(1D0-CHI)*(PEI+PZI)
23137 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23138 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23139 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23140 P(N-1,3)=P(N-1,4)*(-1)**JT
23141 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23142 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23143 ENDIF
23144
23145C...Documentation lines.
23146 K(I+2,1)=21
23147 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23148 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23149 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23150 K(I+2,3)=I
23151 P(I+2,3)=PZ*(-1)**(JT+1)
23152 P(I+2,4)=PE
23153 P(I+2,5)=SQRT(VINT(62+JT))
23154 200 CONTINUE
23155
23156C...Rotate outgoing partons/particles using cos(theta).
23157 IF(VINT(23).LT.0.9D0) THEN
23158 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23159 ELSE
23160 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23161 ENDIF
23162
23163 RETURN
23164 END
23165
23166C*********************************************************************
23167
23168C...PYDISG
23169C...Set up a DIS process as gamma* + f -> f, with beam remnant
23170C...and showering added consecutively. Photon flux by the PYGAGA
23171C...routine (if at all).
23172
23173 SUBROUTINE PYDISG
23174
23175C...Double precision and integer declarations.
23176 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23177 IMPLICIT INTEGER(I-N)
23178 INTEGER PYK,PYCHGE,PYCOMP
23179C...Parameter statement to help give large particle numbers.
23180 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23181 &KEXCIT=4000000,KDIMEN=5000000)
23182C...Commonblocks.
23183 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23184 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23185 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23186 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23188 COMMON/PYINT1/MINT(400),VINT(400)
23189 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23190C...Local arrays.
23191 DIMENSION PMS(4)
23192
23193C...Choice of subprocess, number of documentation lines
23194 IDOC=7
23195 MINT(3)=IDOC-6
23196 MINT(4)=IDOC
23197 IPU1=MINT(84)+1
23198 IPU2=MINT(84)+2
23199 IPU3=MINT(84)+3
23200 ISIDE=1
23201 IF(MINT(107).EQ.4) ISIDE=2
23202
23203C...Reset K, P and V vectors. Store incoming particles
23204 DO 110 JT=1,MSTP(126)+20
23205 I=MINT(83)+JT
23206 DO 100 J=1,5
23207 K(I,J)=0
23208 P(I,J)=0D0
23209 V(I,J)=0D0
23210 100 CONTINUE
23211 110 CONTINUE
23212 DO 130 JT=1,2
23213 I=MINT(83)+JT
23214 K(I,1)=21
23215 K(I,2)=MINT(10+JT)
23216 DO 120 J=1,5
23217 P(I,J)=VINT(285+5*JT+J)
23218 120 CONTINUE
23219 130 CONTINUE
23220 MINT(6)=2
23221
23222C...Store incoming partons in hadronic CM-frame
23223 DO 140 JT=1,2
23224 I=MINT(84)+JT
23225 K(I,1)=14
23226 K(I,2)=MINT(14+JT)
23227 K(I,3)=MINT(83)+2+JT
23228 140 CONTINUE
23229 IF(MINT(15).EQ.22) THEN
23230 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23231 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23232 P(MINT(84)+1,5)=-SQRT(VINT(307))
23233 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23234 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23235 KFRES=MINT(16)
23236 ISIDE=2
23237 ELSE
23238 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23239 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23240 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23241 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23242 P(MINT(84)+1,5)=-SQRT(VINT(308))
23243 KFRES=MINT(15)
23244 ISIDE=1
23245 ENDIF
23246 SIDESG=(-1D0)**(ISIDE-1)
23247
23248C...Copy incoming partons to documentation lines.
23249 DO 170 JT=1,2
23250 I1=MINT(83)+4+JT
23251 I2=MINT(84)+JT
23252 K(I1,1)=21
23253 K(I1,2)=K(I2,2)
23254 K(I1,3)=I1-2
23255 DO 150 J=1,5
23256 P(I1,J)=P(I2,J)
23257 150 CONTINUE
23258
23259C...Second copy for partons before ISR shower, since no such.
23260 I1=MINT(83)+2+JT
23261 K(I1,1)=21
23262 K(I1,2)=K(I2,2)
23263 K(I1,3)=I1-2
23264 DO 160 J=1,5
23265 P(I1,J)=P(I2,J)
23266 160 CONTINUE
23267 170 CONTINUE
23268
23269C...Define initial partons.
23270 NTRY=0
23271 180 NTRY=NTRY+1
23272 IF(NTRY.GT.100) THEN
23273 MINT(51)=1
23274 RETURN
23275 ENDIF
23276
23277C...Scattered quark in hadronic CM frame.
23278 I=MINT(83)+7
23279 K(IPU3,1)=3
23280 K(IPU3,2)=KFRES
23281 K(IPU3,3)=I
23282 P(IPU3,5)=PYMASS(KFRES)
23283 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
23284 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
23285 P(IPU3,5)=0D0
23286 K(I,1)=21
23287 K(I,2)=KFRES
23288 K(I,3)=MINT(83)+4+ISIDE
23289 P(I,3)=P(IPU3,3)
23290 P(I,4)=P(IPU3,4)
23291 P(I,5)=P(IPU3,5)
23292 N=IPU3
23293 MINT(21)=KFRES
23294 MINT(22)=0
23295
23296C...No primordial kT, or chosen according to truncated Gaussian or
23297C...exponential, or (for photon) predetermined or power law.
23298 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
23299 IF(MSTP(91).LE.0) THEN
23300 PT=0D0
23301 ELSEIF(MSTP(91).EQ.1) THEN
23302 PT=PARP(91)*SQRT(-LOG(PYR(0)))
23303 ELSE
23304 RPT1=PYR(0)
23305 RPT2=PYR(0)
23306 PT=-PARP(92)*LOG(RPT1*RPT2)
23307 ENDIF
23308 IF(PT.GT.PARP(93)) GOTO 190
23309 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
23310 PTA=SQRT(VINT(282+ISIDE))
23311 PTB=0D0
23312 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
23313 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
23314 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
23315 RPT1=PYR(0)
23316 RPT2=PYR(0)
23317 PTB=-PARP(99)*LOG(RPT1*RPT2)
23318 ENDIF
23319 IF(PTB.GT.PARP(100)) GOTO 190
23320 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
23321 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
23322 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
23323 IF(MSTP(93).LE.0) THEN
23324 PT=0D0
23325 ELSEIF(MSTP(93).EQ.1) THEN
23326 PT=PARP(99)*SQRT(-LOG(PYR(0)))
23327 ELSEIF(MSTP(93).EQ.2) THEN
23328 RPT1=PYR(0)
23329 RPT2=PYR(0)
23330 PT=-PARP(99)*LOG(RPT1*RPT2)
23331 ELSEIF(MSTP(93).EQ.3) THEN
23332 HA=PARP(99)**2
23333 HB=PARP(100)**2
23334 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
23335 ELSE
23336 HA=PARP(99)**2
23337 HB=PARP(100)**2
23338 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
23339 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
23340 ENDIF
23341 IF(PT.GT.PARP(100)) GOTO 190
23342 ELSE
23343 PT=0D0
23344 ENDIF
23345 VINT(156+ISIDE)=PT
23346 PHI=PARU(2)*PYR(0)
23347 P(IPU3,1)=PT*COS(PHI)
23348 P(IPU3,2)=PT*SIN(PHI)
23349 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
23350 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
23351 PCP=P(IPU3,4)+ABS(P(IPU3,3))
23352
23353C...Find one or two beam remnants.
23354 MINT(105)=MINT(102+ISIDE)
23355 MINT(109)=MINT(106+ISIDE)
23356 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
23357 IF(MINT(51).NE.0) THEN
23358 MINT(51)=0
23359 GOTO 180
23360 ENDIF
23361
23362C...Store first remnant parton, with colour info and kinematics.
23363 I=N+1
23364 K(I,1)=1
23365 K(I,2)=KFLSP
23366 K(I,3)=MINT(83)+ISIDE
23367 P(I,5)=PYMASS(K(I,2))
23368 KCOL=KCHG(PYCOMP(KFLSP),2)
23369 IF(KCOL.NE.0) THEN
23370 K(I,1)=3
23371 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
23372 K(I,KFLS+3)=MSTU(5)*IPU3
23373 K(IPU3,6-KFLS)=MSTU(5)*I
23374 ICOLR=I
23375 ENDIF
23376 IF(KFLCH.EQ.0) THEN
23377 P(I,1)=-P(IPU3,1)
23378 P(I,2)=-P(IPU3,2)
23379 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23380 P(I,3)=-P(IPU3,3)
23381 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
23382 PRP=P(I,4)+ABS(P(I,3))
23383
23384C...When extra remnant parton or hadron: store extra remnant.
23385 ELSE
23386 I=I+1
23387 K(I,1)=1
23388 K(I,2)=KFLCH
23389 K(I,3)=MINT(83)+ISIDE
23390 P(I,5)=PYMASS(K(I,2))
23391 KCOL=KCHG(PYCOMP(KFLCH),2)
23392 IF(KCOL.NE.0) THEN
23393 K(I,1)=3
23394 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
23395 K(I,KFLS+3)=MSTU(5)*IPU3
23396 K(IPU3,6-KFLS)=MSTU(5)*I
23397 ICOLR=I
23398 ENDIF
23399
23400C...Relative transverse momentum when two remnants.
23401 LOOP=0
23402 200 LOOP=LOOP+1
23403 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
23404 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
23405 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
23406 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
23407 P(I,1)=-P(IPU3,1)-P(I-1,1)
23408 P(I,2)=-P(IPU3,2)-P(I-1,2)
23409 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23410
23411C...Relative distribution of energy for particle into jet plus particle.
23412 IMB=1
23413 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
23414 IF(MSTP(94).LE.1) THEN
23415 IF(IMB.EQ.1) CHI=PYR(0)
23416 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23417 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23418 ELSEIF(MSTP(94).EQ.2) THEN
23419 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
23420 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23421 ELSEIF(MSTP(94).EQ.3) THEN
23422 CALL PYZDIS(1,0,PMS(4),ZZ)
23423 CHI=ZZ
23424 ELSE
23425 CALL PYZDIS(1000,0,PMS(4),ZZ)
23426 CHI=ZZ
23427 ENDIF
23428
23429C...Construct total transverse mass; reject if too large.
23430 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
23431 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
23432 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
23433 IF(LOOP.LT.10) GOTO 200
23434 GOTO 180
23435 ENDIF
23436 VINT(158+ISIDE)=CHI
23437
23438C...Subdivide longitudinal momentum according to value selected above.
23439 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
23440 PW1=(1D0-CHI)*PRP
23441 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
23442 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
23443 PW2=CHI*PRP
23444 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
23445 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
23446 ENDIF
23447 N=I
23448
23449C...Boost current and remnant systems to correct frame.
23450 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
23451 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
23452 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
23453 &(2D0*VINT(1)*PCP)
23454 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
23455 &(2D0*VINT(1)*PRP)
23456 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
23457 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
23458 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
23459 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
23460
23461C...Let current quark shower; recoil but no showering by colour partner.
23462 QMAX=2D0*SQRT(VINT(309-ISIDE))
23463 MSTJ48=MSTJ(48)
23464 MSTJ(48)=1
23465 PARJ86=PARJ(86)
23466 PARJ(86)=0D0
23467 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
23468 MSTJ(48)=MSTJ48
23469 PARJ(86)=PARJ86
23470
23471 RETURN
23472 END
23473
23474C*********************************************************************
23475
23476C...PYDOCU
23477C...Handles the documentation of the process in MSTI and PARI,
23478C...and also computes cross-sections based on accumulated statistics.
23479
23480 SUBROUTINE PYDOCU
23481
23482C...Double precision and integer declarations.
23483 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23484 IMPLICIT INTEGER(I-N)
23485 INTEGER PYK,PYCHGE,PYCOMP
23486C...Commonblocks.
23487 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23489 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23490 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23491 COMMON/PYINT1/MINT(400),VINT(400)
23492 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23493 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
23494 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
23495 &/PYINT5/
23496
23497C...Calculate Monte Carlo estimates of cross-sections.
23498 ISUB=MINT(1)
23499 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
23500 NGEN(0,3)=NGEN(0,3)+1
23501 XSEC(0,3)=0D0
23502 DO 100 I=1,500
23503 IF(I.EQ.96.OR.I.EQ.97) THEN
23504 XSEC(I,3)=0D0
23505 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
23506 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
23507 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23508 & DBLE(NGEN(96,2)))
23509 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
23510 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23511 & DBLE(NGEN(96,2)))
23512 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
23513 XSEC(I,3)=0D0
23514 ELSEIF(NGEN(I,2).EQ.0) THEN
23515 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
23516 & DBLE(NGEN(0,2)))
23517 ELSE
23518 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
23519 & DBLE(NGEN(I,2)))
23520 ENDIF
23521 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
23522 100 CONTINUE
23523
23524C...Rescale to known low-pT cross-section for standard QCD processes.
23525 IF(MSUB(95).EQ.1) THEN
23526 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
23527 & XSEC(68,3)+XSEC(95,3)
23528 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
23529 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
23530 FAC=XSECW/XSECH
23531 XSEC(11,3)=FAC*XSEC(11,3)
23532 XSEC(12,3)=FAC*XSEC(12,3)
23533 XSEC(13,3)=FAC*XSEC(13,3)
23534 XSEC(28,3)=FAC*XSEC(28,3)
23535 XSEC(53,3)=FAC*XSEC(53,3)
23536 XSEC(68,3)=FAC*XSEC(68,3)
23537 XSEC(95,3)=FAC*XSEC(95,3)
23538 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
23539 ENDIF
23540 ENDIF
23541
23542C...Save information for gamma-p and gamma-gamma.
23543 IF(MINT(121).GT.1) THEN
23544 IGA=MINT(122)
23545 CALL PYSAVE(2,IGA)
23546 CALL PYSAVE(5,0)
23547 ENDIF
23548
23549C...Reset information on hard interaction.
23550 DO 110 J=1,200
23551 MSTI(J)=0
23552 PARI(J)=0D0
23553 110 CONTINUE
23554
23555C...Copy integer valued information from MINT into MSTI.
23556 DO 120 J=1,32
23557 MSTI(J)=MINT(J)
23558 120 CONTINUE
23559 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
23560
23561C...Store cross-section variables in PARI.
23562 PARI(1)=XSEC(0,3)
23563 PARI(2)=XSEC(0,3)/MINT(5)
23564 PARI(7)=VINT(97)
23565 PARI(9)=VINT(99)
23566 PARI(10)=VINT(100)
23567 VINT(98)=VINT(98)+VINT(100)
23568 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
23569
23570C...Store kinematics variables in PARI.
23571 PARI(11)=VINT(1)
23572 PARI(12)=VINT(2)
23573 IF(ISUB.NE.95) THEN
23574 DO 130 J=13,26
23575 PARI(J)=VINT(30+J)
23576 130 CONTINUE
23577 PARI(29)=VINT(39)
23578 PARI(30)=VINT(40)
23579 PARI(31)=VINT(141)
23580 PARI(32)=VINT(142)
23581 PARI(33)=VINT(41)
23582 PARI(34)=VINT(42)
23583 PARI(35)=PARI(33)-PARI(34)
23584 PARI(36)=VINT(21)
23585 PARI(37)=VINT(22)
23586 PARI(38)=VINT(26)
23587 PARI(39)=VINT(157)
23588 PARI(40)=VINT(158)
23589 PARI(41)=VINT(23)
23590 PARI(42)=2D0*VINT(47)/VINT(1)
23591 ENDIF
23592
23593C...Store information on scattered partons in PARI.
23594 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
23595 DO 140 IS=7,8
23596 I=MINT(IS)
23597 PARI(36+IS)=P(I,3)/VINT(1)
23598 PARI(38+IS)=P(I,4)/VINT(1)
23599 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23600 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23601 & SQRT(PR),1D20)),P(I,3))
23602 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23603 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23604 & SQRT(PR),1D20)),P(I,3))
23605 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23606 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23607 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23608 140 CONTINUE
23609 ENDIF
23610
23611C...Store sum up transverse and longitudinal momenta.
23612 PARI(65)=2D0*PARI(17)
23613 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23614 DO 150 I=MSTP(126)+1,N
23615 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23616 PT=SQRT(P(I,1)**2+P(I,2)**2)
23617 PARI(69)=PARI(69)+PT
23618 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23619 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23620 150 CONTINUE
23621 PARI(67)=PARI(68)
23622 PARI(71)=VINT(151)
23623 PARI(72)=VINT(152)
23624 PARI(73)=VINT(151)
23625 PARI(74)=VINT(152)
23626 ELSE
23627 PARI(66)=PARI(65)
23628 PARI(69)=PARI(65)
23629 ENDIF
23630
23631C...Store various other pieces of information into PARI.
23632 PARI(61)=VINT(148)
23633 PARI(75)=VINT(155)
23634 PARI(76)=VINT(156)
23635 PARI(77)=VINT(159)
23636 PARI(78)=VINT(160)
23637 PARI(81)=VINT(138)
23638
23639C...Store information on lepton -> lepton + gamma in PYGAGA.
23640 MSTI(71)=MINT(141)
23641 MSTI(72)=MINT(142)
23642 PARI(101)=VINT(301)
23643 PARI(102)=VINT(302)
23644 DO 160 I=103,114
23645 PARI(I)=VINT(I+202)
23646 160 CONTINUE
23647
23648C...Set information for PYTABU.
23649 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23650 MSTU(161)=MINT(21)
23651 MSTU(162)=0
23652 ELSEIF(ISET(ISUB).EQ.5) THEN
23653 MSTU(161)=MINT(23)
23654 MSTU(162)=0
23655 ELSE
23656 MSTU(161)=MINT(21)
23657 MSTU(162)=MINT(22)
23658 ENDIF
23659
23660 RETURN
23661 END
23662
23663C*********************************************************************
23664
23665C...PYFRAM
23666C...Performs transformations between different coordinate frames.
23667
23668 SUBROUTINE PYFRAM(IFRAME)
23669
23670C...Double precision and integer declarations.
23671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23672 IMPLICIT INTEGER(I-N)
23673 INTEGER PYK,PYCHGE,PYCOMP
23674C...Commonblocks.
23675 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23676 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23677 COMMON/PYINT1/MINT(400),VINT(400)
23678 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23679
23680C...Check that transformation can and should be done.
23681 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23682 &MINT(91).EQ.1)) THEN
23683 IF(IFRAME.EQ.MINT(6)) RETURN
23684 ELSE
23685 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23686 RETURN
23687 ENDIF
23688
23689 IF(MINT(6).EQ.1) THEN
23690C...Transform from fixed target or user specified frame to
23691C...overall CM frame.
23692 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23693 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23694 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23695 ELSEIF(MINT(6).EQ.3) THEN
23696C...Transform from hadronic CM frame in DIS to overall CM frame.
23697 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23698 & -VINT(225))
23699 ENDIF
23700
23701 IF(IFRAME.EQ.1) THEN
23702C...Transform from overall CM frame to fixed target or user specified
23703C...frame.
23704 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23705 ELSEIF(IFRAME.EQ.3) THEN
23706C...Transform from overall CM frame to hadronic CM frame in DIS.
23707 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23708 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23709 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23710 ENDIF
23711
23712C...Set information about new frame.
23713 MINT(6)=IFRAME
23714 MSTI(6)=IFRAME
23715
23716 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23717 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23718 &1X,I5)
23719
23720 RETURN
23721 END
23722
23723C*********************************************************************
23724
23725C...PYWIDT
23726C...Calculates full and partial widths of resonances.
23727
23728 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23729
23730C...Double precision and integer declarations.
23731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23732 IMPLICIT INTEGER(I-N)
23733 INTEGER PYK,PYCHGE,PYCOMP
23734C...Parameter statement to help give large particle numbers.
23735 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23736 &KEXCIT=4000000,KDIMEN=5000000)
23737C...Commonblocks.
23738 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23739 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23740 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23741 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23742 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23743 COMMON/PYINT1/MINT(400),VINT(400)
23744 COMMON/PYINT4/MWID(500),WIDS(500,5)
23745 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23746 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23747 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23748 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23749 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23750 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23751C...Local arrays and saved variables.
23752 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23753 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23754 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23755 SAVE MOFSV,WIDWSV,WID2SV
23756 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23757
23758C...Compressed code and sign; mass.
23759 KFLA=IABS(KFLR)
23760 KFLS=ISIGN(1,KFLR)
23761 KC=PYCOMP(KFLA)
23762 SHR=SQRT(SH)
23763 PMR=PMAS(KC,1)
23764
23765C...Reset width information.
23766 DO 110 I=0,MDCY(KC,3)
23767 WDTP(I)=0D0
23768 DO 100 J=0,5
23769 WDTE(I,J)=0D0
23770 100 CONTINUE
23771 110 CONTINUE
23772
23773C...Allow for fudge factor to rescale resonance width.
23774 FUDGE=1D0
23775 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23776 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23777 IF(MSTP(110).EQ.KFLA) THEN
23778 FUDGE=PARP(110)
23779 ELSEIF(MSTP(110).EQ.-1) THEN
23780 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23781 ELSEIF(MSTP(110).EQ.-2) THEN
23782 FUDGE=PARP(110)
23783 ENDIF
23784 ENDIF
23785
23786C...Not to be treated as a resonance: return.
23787 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23788 &KFLA.NE.22) THEN
23789 WDTP(0)=1D0
23790 WDTE(0,0)=1D0
23791 MINT(61)=0
23792 MINT(62)=0
23793 MINT(63)=0
23794 RETURN
23795
23796C...Treatment as a resonance based on tabulated branching ratios.
23797 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23798C...Loop over possible decay channels; skip irrelevant ones.
23799 DO 120 I=1,MDCY(KC,3)
23800 IDC=I+MDCY(KC,2)-1
23801 IF(MDME(IDC,1).LT.0) GOTO 120
23802
23803C...Read out decay products and nominal masses.
23804 KFD1=KFDP(IDC,1)
23805 KFC1=PYCOMP(KFD1)
23806 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23807 PM1=PMAS(KFC1,1)
23808 KFD2=KFDP(IDC,2)
23809 KFC2=PYCOMP(KFD2)
23810 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23811 PM2=PMAS(KFC2,1)
23812 KFD3=KFDP(IDC,3)
23813 PM3=0D0
23814 IF(KFD3.NE.0) THEN
23815 KFC3=PYCOMP(KFD3)
23816 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23817 PM3=PMAS(KFC3,1)
23818 ENDIF
23819
23820C...Naive partial width and alternative threshold factors.
23821 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23822 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23823 & PM1+PM2+PM3.GE.SHR) THEN
23824 WDTP(I)=0D0
23825 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23826 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23827 & 4D0*PM1**2*PM2**2))/SH
23828 ELSEIF(MDME(IDC,2).EQ.52) THEN
23829 PMA=MAX(PM1,PM2,PM3)
23830 PMC=MIN(PM1,PM2,PM3)
23831 PMB=PM1+PM2+PM3-PMA-PMC
23832 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23833 PMAN=PMA**2/SH
23834 PMBN=PMB**2/SH
23835 PMCN=PMC**2/SH
23836 PMBCN=PMBC**2/SH
23837 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23838 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23839 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23840 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23841 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23842 & ((1D0-PMBCN)*PMBCN*SH)
23843 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23844 WDTP(I)=WDTP(I)*SQRT(
23845 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23846 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23847 ELSEIF(MDME(IDC,2).EQ.53) THEN
23848 PMA=MAX(PM1,PM2,PM3)
23849 PMC=MIN(PM1,PM2,PM3)
23850 PMB=PM1+PM2+PM3-PMA-PMC
23851 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23852 PMAN=PMA**2/SH
23853 PMBN=PMB**2/SH
23854 PMCN=PMC**2/SH
23855 PMBCN=PMBC**2/SH
23856 FACACT=SQRT(MAX(0D0,
23857 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23858 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23859 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23860 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23861 & ((1D0-PMBCN)*PMBCN*SH)
23862 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23863 PMAN=PMA**2/PMR**2
23864 PMBN=PMB**2/PMR**2
23865 PMCN=PMC**2/PMR**2
23866 PMBCN=PMBC**2/PMR**2
23867 FACNOM=SQRT(MAX(0D0,
23868 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23869 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23870 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23871 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23872 & ((1D0-PMBCN)*PMBCN*PMR**2)
23873 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23874 ENDIF
23875 WDTP(I)=FUDGE*WDTP(I)
23876 WDTP(0)=WDTP(0)+WDTP(I)
23877
23878C...Calculate secondary width (at most two identical/opposite).
23879 WID2=1D0
23880 IF(MDME(IDC,1).GT.0) THEN
23881 IF(KFD2.EQ.KFD1) THEN
23882 IF(KCHG(KFC1,3).EQ.0) THEN
23883 WID2=WIDS(KFC1,1)
23884 ELSEIF(KFD1.GT.0) THEN
23885 WID2=WIDS(KFC1,4)
23886 ELSE
23887 WID2=WIDS(KFC1,5)
23888 ENDIF
23889 IF(KFD3.GT.0) THEN
23890 WID2=WID2*WIDS(KFC3,2)
23891 ELSEIF(KFD3.LT.0) THEN
23892 WID2=WID2*WIDS(KFC3,3)
23893 ENDIF
23894 ELSEIF(KFD2.EQ.-KFD1) THEN
23895 WID2=WIDS(KFC1,1)
23896 IF(KFD3.GT.0) THEN
23897 WID2=WID2*WIDS(KFC3,2)
23898 ELSEIF(KFD3.LT.0) THEN
23899 WID2=WID2*WIDS(KFC3,3)
23900 ENDIF
23901 ELSEIF(KFD3.EQ.KFD1) THEN
23902 IF(KCHG(KFC1,3).EQ.0) THEN
23903 WID2=WIDS(KFC1,1)
23904 ELSEIF(KFD1.GT.0) THEN
23905 WID2=WIDS(KFC1,4)
23906 ELSE
23907 WID2=WIDS(KFC1,5)
23908 ENDIF
23909 IF(KFD2.GT.0) THEN
23910 WID2=WID2*WIDS(KFC2,2)
23911 ELSEIF(KFD2.LT.0) THEN
23912 WID2=WID2*WIDS(KFC2,3)
23913 ENDIF
23914 ELSEIF(KFD3.EQ.-KFD1) THEN
23915 WID2=WIDS(KFC1,1)
23916 IF(KFD2.GT.0) THEN
23917 WID2=WID2*WIDS(KFC2,2)
23918 ELSEIF(KFD2.LT.0) THEN
23919 WID2=WID2*WIDS(KFC2,3)
23920 ENDIF
23921 ELSEIF(KFD3.EQ.KFD2) THEN
23922 IF(KCHG(KFC2,3).EQ.0) THEN
23923 WID2=WIDS(KFC2,1)
23924 ELSEIF(KFD2.GT.0) THEN
23925 WID2=WIDS(KFC2,4)
23926 ELSE
23927 WID2=WIDS(KFC2,5)
23928 ENDIF
23929 IF(KFD1.GT.0) THEN
23930 WID2=WID2*WIDS(KFC1,2)
23931 ELSEIF(KFD1.LT.0) THEN
23932 WID2=WID2*WIDS(KFC1,3)
23933 ENDIF
23934 ELSEIF(KFD3.EQ.-KFD2) THEN
23935 WID2=WIDS(KFC2,1)
23936 IF(KFD1.GT.0) THEN
23937 WID2=WID2*WIDS(KFC1,2)
23938 ELSEIF(KFD1.LT.0) THEN
23939 WID2=WID2*WIDS(KFC1,3)
23940 ENDIF
23941 ELSE
23942 IF(KFD1.GT.0) THEN
23943 WID2=WIDS(KFC1,2)
23944 ELSE
23945 WID2=WIDS(KFC1,3)
23946 ENDIF
23947 IF(KFD2.GT.0) THEN
23948 WID2=WID2*WIDS(KFC2,2)
23949 ELSE
23950 WID2=WID2*WIDS(KFC2,3)
23951 ENDIF
23952 IF(KFD3.GT.0) THEN
23953 WID2=WID2*WIDS(KFC3,2)
23954 ELSEIF(KFD3.LT.0) THEN
23955 WID2=WID2*WIDS(KFC3,3)
23956 ENDIF
23957 ENDIF
23958
23959C...Store effective widths according to case.
23960 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23961 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23962 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23963 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23964 ENDIF
23965 120 CONTINUE
23966C...Return.
23967 MINT(61)=0
23968 MINT(62)=0
23969 MINT(63)=0
23970 RETURN
23971 ENDIF
23972
23973C...Here begins detailed dynamical calculation of resonance widths.
23974C...Shared treatment of Higgs states.
23975 KFHIGG=25
23976 IHIGG=1
23977 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23978 KFHIGG=KFLA
23979 IHIGG=KFLA-33
23980 ENDIF
23981
23982C...Common electroweak and strong constants.
23983 XW=PARU(102)
23984 XWV=XW
23985 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
23986 XW1=1D0-XW
23987 AEM=PYALEM(SH)
23988 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
23989 AS=PYALPS(SH)
23990 RADC=1D0+AS/PARU(1)
23991
23992 IF(KFLA.EQ.6) THEN
23993C...t quark.
23994 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23995 RADCT=1D0-2.5D0*AS/PARU(1)
23996 DO 140 I=1,MDCY(KC,3)
23997 IDC=I+MDCY(KC,2)-1
23998 IF(MDME(IDC,1).LT.0) GOTO 140
23999 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24000 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24001 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24002 WID2=1D0
24003 IF(I.GE.4.AND.I.LE.7) THEN
24004C...t -> W + q; including approximate QCD correction factor.
24005 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24006 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24007 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24008 IF(KFLR.GT.0) THEN
24009 WID2=WIDS(24,2)
24010 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24011 ELSE
24012 WID2=WIDS(24,3)
24013 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24014 ENDIF
24015 ELSEIF(I.EQ.9) THEN
24016C...t -> H + b.
24017 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24018 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24019 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24020 & 4D0*SQRT(RM2R*RM2))
24021 WID2=WIDS(37,2)
24022 IF(KFLR.LT.0) WID2=WIDS(37,3)
24023CMRENNA++
24024 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24025C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24026 BETA=ATAN(RMSS(5))
24027 SINB=SIN(BETA)
24028 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24029 ET=KCHG(6,1)/3D0
24030 T3L=SIGN(0.5D0,ET)
24031 KFC1=PYCOMP(KFDP(IDC,1))
24032 KFC2=PYCOMP(KFDP(IDC,2))
24033 PMNCHI=PMAS(KFC1,1)
24034 PMSTOP=PMAS(KFC2,1)
24035 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24036 IZ=I-9
24037 DO 130 IK=1,4
24038 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24039 130 CONTINUE
24040 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24041 AR=-ET*ZMIXC(IZ,1)*TANW
24042 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24043 BR=AL
24044 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24045 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24046 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24047 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24048 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24049 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24050 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24051 IF(KFLR.GT.0) THEN
24052 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24053 ELSE
24054 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24055 ENDIF
24056 ENDIF
24057 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24058C...t -> ~g + ~t
24059 KFC1=PYCOMP(KFDP(IDC,1))
24060 KFC2=PYCOMP(KFDP(IDC,2))
24061 PMNCHI=PMAS(KFC1,1)
24062 PMSTOP=PMAS(KFC2,1)
24063 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24064 RL=SFMIX(6,1)
24065 RR=-SFMIX(6,2)
24066 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24067 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24068 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24069 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24070 IF(KFLR.GT.0) THEN
24071 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24072 ELSE
24073 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24074 ENDIF
24075 ENDIF
24076 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24077C...t -> ~gravitino + ~t
24078 XMP2=RMSS(29)**2
24079 KFC1=PYCOMP(KFDP(IDC,1))
24080 XMGR2=PMAS(KFC1,1)**2
24081 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24082 KFC2=PYCOMP(KFDP(IDC,2))
24083 WID2=WIDS(KFC2,2)
24084 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24085CMRENNA--
24086 ENDIF
24087 WDTP(I)=FUDGE*WDTP(I)
24088 WDTP(0)=WDTP(0)+WDTP(I)
24089 IF(MDME(IDC,1).GT.0) THEN
24090 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24091 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24092 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24093 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24094 ENDIF
24095 140 CONTINUE
24096
24097 ELSEIF(KFLA.EQ.7) THEN
24098C...b' quark.
24099 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24100 DO 150 I=1,MDCY(KC,3)
24101 IDC=I+MDCY(KC,2)-1
24102 IF(MDME(IDC,1).LT.0) GOTO 150
24103 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24104 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24105 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24106 WID2=1D0
24107 IF(I.GE.4.AND.I.LE.7) THEN
24108C...b' -> W + q.
24109 WDTP(I)=FAC*VCKM(I-3,4)*
24110 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24111 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24112 IF(KFLR.GT.0) THEN
24113 WID2=WIDS(24,3)
24114 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24115 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24116 ELSE
24117 WID2=WIDS(24,2)
24118 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24119 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24120 ENDIF
24121 WID2=WIDS(24,3)
24122 IF(KFLR.LT.0) WID2=WIDS(24,2)
24123 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24124C...b' -> H + q.
24125 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24126 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24127 IF(KFLR.GT.0) THEN
24128 WID2=WIDS(37,3)
24129 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24130 ELSE
24131 WID2=WIDS(37,2)
24132 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24133 ENDIF
24134 ENDIF
24135 WDTP(I)=FUDGE*WDTP(I)
24136 WDTP(0)=WDTP(0)+WDTP(I)
24137 IF(MDME(IDC,1).GT.0) THEN
24138 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24139 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24140 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24141 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24142 ENDIF
24143 150 CONTINUE
24144
24145 ELSEIF(KFLA.EQ.8) THEN
24146C...t' quark.
24147 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24148 DO 160 I=1,MDCY(KC,3)
24149 IDC=I+MDCY(KC,2)-1
24150 IF(MDME(IDC,1).LT.0) GOTO 160
24151 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24152 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24153 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24154 WID2=1D0
24155 IF(I.GE.4.AND.I.LE.7) THEN
24156C...t' -> W + q.
24157 WDTP(I)=FAC*VCKM(4,I-3)*
24158 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24159 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24160 IF(KFLR.GT.0) THEN
24161 WID2=WIDS(24,2)
24162 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24163 ELSE
24164 WID2=WIDS(24,3)
24165 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24166 ENDIF
24167 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24168C...t' -> H + q.
24169 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24170 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24171 IF(KFLR.GT.0) THEN
24172 WID2=WIDS(37,2)
24173 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24174 ELSE
24175 WID2=WIDS(37,3)
24176 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24177 ENDIF
24178 ENDIF
24179 WDTP(I)=FUDGE*WDTP(I)
24180 WDTP(0)=WDTP(0)+WDTP(I)
24181 IF(MDME(IDC,1).GT.0) THEN
24182 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24183 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24184 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24185 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24186 ENDIF
24187 160 CONTINUE
24188
24189 ELSEIF(KFLA.EQ.17) THEN
24190C...tau' lepton.
24191 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24192 DO 170 I=1,MDCY(KC,3)
24193 IDC=I+MDCY(KC,2)-1
24194 IF(MDME(IDC,1).LT.0) GOTO 170
24195 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24196 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24197 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24198 WID2=1D0
24199 IF(I.EQ.3) THEN
24200C...tau' -> W + nu'_tau.
24201 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24202 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24203 IF(KFLR.GT.0) THEN
24204 WID2=WIDS(24,3)
24205 WID2=WID2*WIDS(18,2)
24206 ELSE
24207 WID2=WIDS(24,2)
24208 WID2=WID2*WIDS(18,3)
24209 ENDIF
24210 ELSEIF(I.EQ.5) THEN
24211C...tau' -> H + nu'_tau.
24212 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24213 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24214 IF(KFLR.GT.0) THEN
24215 WID2=WIDS(37,3)
24216 WID2=WID2*WIDS(18,2)
24217 ELSE
24218 WID2=WIDS(37,2)
24219 WID2=WID2*WIDS(18,3)
24220 ENDIF
24221 ENDIF
24222 WDTP(I)=FUDGE*WDTP(I)
24223 WDTP(0)=WDTP(0)+WDTP(I)
24224 IF(MDME(IDC,1).GT.0) THEN
24225 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24226 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24227 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24228 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24229 ENDIF
24230 170 CONTINUE
24231
24232 ELSEIF(KFLA.EQ.18) THEN
24233C...nu'_tau neutrino.
24234 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24235 DO 180 I=1,MDCY(KC,3)
24236 IDC=I+MDCY(KC,2)-1
24237 IF(MDME(IDC,1).LT.0) GOTO 180
24238 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24239 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24240 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24241 WID2=1D0
24242 IF(I.EQ.2) THEN
24243C...nu'_tau -> W + tau'.
24244 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24245 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24246 IF(KFLR.GT.0) THEN
24247 WID2=WIDS(24,2)
24248 WID2=WID2*WIDS(17,2)
24249 ELSE
24250 WID2=WIDS(24,3)
24251 WID2=WID2*WIDS(17,3)
24252 ENDIF
24253 ELSEIF(I.EQ.3) THEN
24254C...nu'_tau -> H + tau'.
24255 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24256 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24257 IF(KFLR.GT.0) THEN
24258 WID2=WIDS(37,2)
24259 WID2=WID2*WIDS(17,2)
24260 ELSE
24261 WID2=WIDS(37,3)
24262 WID2=WID2*WIDS(17,3)
24263 ENDIF
24264 ENDIF
24265 WDTP(I)=FUDGE*WDTP(I)
24266 WDTP(0)=WDTP(0)+WDTP(I)
24267 IF(MDME(IDC,1).GT.0) THEN
24268 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24269 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24270 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24271 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24272 ENDIF
24273 180 CONTINUE
24274
24275 ELSEIF(KFLA.EQ.21) THEN
24276C...QCD:
24277C***Note that widths are not given in dimensional quantities here.
24278 DO 190 I=1,MDCY(KC,3)
24279 IDC=I+MDCY(KC,2)-1
24280 IF(MDME(IDC,1).LT.0) GOTO 190
24281 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24282 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24283 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
24284 WID2=1D0
24285 IF(I.LE.8) THEN
24286C...QCD -> q + qbar
24287 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24288 IF(I.EQ.6) WID2=WIDS(6,1)
24289 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24290 ENDIF
24291 WDTP(I)=FUDGE*WDTP(I)
24292 WDTP(0)=WDTP(0)+WDTP(I)
24293 IF(MDME(IDC,1).GT.0) THEN
24294 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24295 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24296 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24297 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24298 ENDIF
24299 190 CONTINUE
24300
24301 ELSEIF(KFLA.EQ.22) THEN
24302C...QED photon.
24303C***Note that widths are not given in dimensional quantities here.
24304 DO 200 I=1,MDCY(KC,3)
24305 IDC=I+MDCY(KC,2)-1
24306 IF(MDME(IDC,1).LT.0) GOTO 200
24307 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24308 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24309 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
24310 WID2=1D0
24311 IF(I.LE.8) THEN
24312C...QED -> q + qbar.
24313 EF=KCHG(I,1)/3D0
24314 FCOF=3D0*RADC
24315 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24316 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24317 IF(I.EQ.6) WID2=WIDS(6,1)
24318 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24319 ELSEIF(I.LE.12) THEN
24320C...QED -> l+ + l-.
24321 EF=KCHG(9+2*(I-8),1)/3D0
24322 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24323 IF(I.EQ.12) WID2=WIDS(17,1)
24324 ENDIF
24325 WDTP(I)=FUDGE*WDTP(I)
24326 WDTP(0)=WDTP(0)+WDTP(I)
24327 IF(MDME(IDC,1).GT.0) THEN
24328 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24329 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24330 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24331 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24332 ENDIF
24333 200 CONTINUE
24334
24335 ELSEIF(KFLA.EQ.23) THEN
24336C...Z0:
24337 ICASE=1
24338 XWC=1D0/(16D0*XW*XW1)
24339 FAC=(AEM*XWC/3D0)*SHR
24340 210 CONTINUE
24341 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24342 VINT(111)=0D0
24343 VINT(112)=0D0
24344 VINT(114)=0D0
24345 ENDIF
24346 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24347 KFI=IABS(MINT(15))
24348 IF(KFI.GT.20) KFI=IABS(MINT(16))
24349 EI=KCHG(KFI,1)/3D0
24350 AI=SIGN(1D0,EI)
24351 VI=AI-4D0*EI*XWV
24352 SQMZ=PMAS(23,1)**2
24353 HZ=SHR*WDTP(0)
24354 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
24355 IF(MSTP(43).EQ.3) VINT(112)=
24356 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24357 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24358 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24359 ENDIF
24360 DO 220 I=1,MDCY(KC,3)
24361 IDC=I+MDCY(KC,2)-1
24362 IF(MDME(IDC,1).LT.0) GOTO 220
24363 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24364 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24365 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
24366 WID2=1D0
24367 IF(I.LE.8) THEN
24368C...Z0 -> q + qbar
24369 EF=KCHG(I,1)/3D0
24370 AF=SIGN(1D0,EF+0.1D0)
24371 VF=AF-4D0*EF*XWV
24372 FCOF=3D0*RADC
24373 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24374 IF(I.EQ.6) WID2=WIDS(6,1)
24375 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24376 ELSEIF(I.LE.16) THEN
24377C...Z0 -> l+ + l-, nu + nubar
24378 EF=KCHG(I+2,1)/3D0
24379 AF=SIGN(1D0,EF+0.1D0)
24380 VF=AF-4D0*EF*XWV
24381 FCOF=1D0
24382 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24383 ENDIF
24384 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24385 IF(ICASE.EQ.1) THEN
24386 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
24387 & BE34
24388 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24389 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24390 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
24391 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
24392 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24393 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24394 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24395 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24396 ENDIF
24397 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
24398 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
24399 IF(MDME(IDC,1).GT.0) THEN
24400 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24401 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24402 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24403 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24404 & WDTE(I,MDME(IDC,1))
24405 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24406 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24407 ENDIF
24408 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24409 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
24410 & VINT(111)+FGGF*WID2
24411 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
24412 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24413 & VINT(114)+FZZF*WID2
24414 ENDIF
24415 ENDIF
24416 220 CONTINUE
24417 IF(MINT(61).GE.1) ICASE=3-ICASE
24418 IF(ICASE.EQ.2) GOTO 210
24419
24420 ELSEIF(KFLA.EQ.24) THEN
24421C...W+/-:
24422 FAC=(AEM/(24D0*XW))*SHR
24423 DO 230 I=1,MDCY(KC,3)
24424 IDC=I+MDCY(KC,2)-1
24425 IF(MDME(IDC,1).LT.0) GOTO 230
24426 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24427 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24428 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
24429 WID2=1D0
24430 IF(I.LE.16) THEN
24431C...W+/- -> q + qbar'
24432 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
24433 IF(KFLR.GT.0) THEN
24434 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24435 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24436 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24437 ELSE
24438 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24439 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24440 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24441 ENDIF
24442 ELSEIF(I.LE.20) THEN
24443C...W+/- -> l+/- + nu
24444 FCOF=1D0
24445 IF(KFLR.GT.0) THEN
24446 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24447 ELSE
24448 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24449 ENDIF
24450 ENDIF
24451 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24452 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24453 WDTP(I)=FUDGE*WDTP(I)
24454 WDTP(0)=WDTP(0)+WDTP(I)
24455 IF(MDME(IDC,1).GT.0) THEN
24456 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24457 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24458 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24459 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24460 ENDIF
24461 230 CONTINUE
24462
24463 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24464C...h0 (or H0, or A0):
24465 SHFS=SH
24466 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24467 DO 270 I=1,MDCY(KFHIGG,3)
24468 IDC=I+MDCY(KFHIGG,2)-1
24469 IF(MDME(IDC,1).LT.0) GOTO 270
24470 KFC1=PYCOMP(KFDP(IDC,1))
24471 KFC2=PYCOMP(KFDP(IDC,2))
24472 RM1=PMAS(KFC1,1)**2/SH
24473 RM2=PMAS(KFC2,1)**2/SH
24474 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
24475 & GOTO 270
24476 WID2=1D0
24477
24478 IF(I.LE.8) THEN
24479C...h0 -> q + qbar
24480 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
24481 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
24482C...A0 behaves like beta, ho and H0 like beta**3.
24483 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24484 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24485 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
24486 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
24487 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
24488 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
24489 IF(IHIGG.NE.3) THEN
24490 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24491 & PARU(151+10*IHIGG))**2
24492 ENDIF
24493 ENDIF
24494 ENDIF
24495 IF(I.EQ.6) WID2=WIDS(6,1)
24496 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24497 ELSEIF(I.LE.12) THEN
24498C...h0 -> l+ + l-
24499 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
24500C...A0 behaves like beta, ho and H0 like beta**3.
24501 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24502 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24503 & PARU(153+10*IHIGG)**2
24504 IF(I.EQ.12) WID2=WIDS(17,1)
24505
24506 ELSEIF(I.EQ.13) THEN
24507C...h0 -> g + g; quark loop contribution only
24508 ETARE=0D0
24509 ETAIM=0D0
24510 DO 240 J=1,2*MSTP(1)
24511 EPS=(2D0*PMAS(J,1))**2/SH
24512C...Loop integral; function of eps=4m^2/shat; different for A0.
24513 IF(EPS.LE.1D0) THEN
24514 IF(EPS.GT.1D-4) THEN
24515 ROOT=SQRT(1D0-EPS)
24516 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24517 ELSE
24518 RLN=LOG(4D0/EPS-2D0)
24519 ENDIF
24520 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24521 PHIIM=0.5D0*PARU(1)*RLN
24522 ELSE
24523 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24524 PHIIM=0D0
24525 ENDIF
24526 IF(IHIGG.LE.2) THEN
24527 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24528 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
24529 ELSE
24530 ETAREJ=-0.5D0*EPS*PHIRE
24531 ETAIMJ=-0.5D0*EPS*PHIIM
24532 ENDIF
24533C...Couplings (=1 for standard model Higgs).
24534 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24535 IF(MOD(J,2).EQ.1) THEN
24536 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
24537 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
24538 ELSE
24539 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
24540 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
24541 ENDIF
24542 ENDIF
24543 ETARE=ETARE+ETAREJ
24544 ETAIM=ETAIM+ETAIMJ
24545 240 CONTINUE
24546 ETA2=ETARE**2+ETAIM**2
24547 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
24548
24549 ELSEIF(I.EQ.14) THEN
24550C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
24551 ETARE=0D0
24552 ETAIM=0D0
24553 JMAX=3*MSTP(1)+1
24554 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24555 DO 250 J=1,JMAX
24556 IF(J.LE.2*MSTP(1)) THEN
24557 EJ=KCHG(J,1)/3D0
24558 EPS=(2D0*PMAS(J,1))**2/SH
24559 ELSEIF(J.LE.3*MSTP(1)) THEN
24560 JL=2*(J-2*MSTP(1))-1
24561 EJ=KCHG(10+JL,1)/3D0
24562 EPS=(2D0*PMAS(10+JL,1))**2/SH
24563 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24564 EPS=(2D0*PMAS(24,1))**2/SH
24565 ELSE
24566 EPS=(2D0*PMAS(37,1))**2/SH
24567 ENDIF
24568C...Loop integral; function of eps=4m^2/shat.
24569 IF(EPS.LE.1D0) THEN
24570 IF(EPS.GT.1D-4) THEN
24571 ROOT=SQRT(1D0-EPS)
24572 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24573 ELSE
24574 RLN=LOG(4D0/EPS-2D0)
24575 ENDIF
24576 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24577 PHIIM=0.5D0*PARU(1)*RLN
24578 ELSE
24579 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24580 PHIIM=0D0
24581 ENDIF
24582 IF(J.LE.3*MSTP(1)) THEN
24583C...Fermion loops: loop integral different for A0; charges.
24584 IF(IHIGG.LE.2) THEN
24585 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24586 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
24587 ELSE
24588 PHIPRE=-0.5D0*EPS*PHIRE
24589 PHIPIM=-0.5D0*EPS*PHIIM
24590 ENDIF
24591 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24592 EJC=3D0*EJ**2
24593 EJH=PARU(151+10*IHIGG)
24594 ELSEIF(J.LE.2*MSTP(1)) THEN
24595 EJC=3D0*EJ**2
24596 EJH=PARU(152+10*IHIGG)
24597 ELSE
24598 EJC=EJ**2
24599 EJH=PARU(153+10*IHIGG)
24600 ENDIF
24601 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24602 ETAREJ=EJC*EJH*PHIPRE
24603 ETAIMJ=EJC*EJH*PHIPIM
24604 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24605C...W loops: loop integral and charges.
24606 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24607 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24608 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24609 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24610 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24611 ENDIF
24612 ELSE
24613C...Charged H loops: loop integral and charges.
24614 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24615 & PARU(158+10*IHIGG+2*(IHIGG/3))
24616 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24617 ETAIMJ=-EPS**2*PHIIM*FACHHH
24618 ENDIF
24619 ETARE=ETARE+ETAREJ
24620 ETAIM=ETAIM+ETAIMJ
24621 250 CONTINUE
24622 ETA2=ETARE**2+ETAIM**2
24623 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24624
24625 ELSEIF(I.EQ.15) THEN
24626C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24627 ETARE=0D0
24628 ETAIM=0D0
24629 JMAX=3*MSTP(1)+1
24630 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24631 DO 260 J=1,JMAX
24632 IF(J.LE.2*MSTP(1)) THEN
24633 EJ=KCHG(J,1)/3D0
24634 AJ=SIGN(1D0,EJ+0.1D0)
24635 VJ=AJ-4D0*EJ*XWV
24636 EPS=(2D0*PMAS(J,1))**2/SH
24637 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24638 ELSEIF(J.LE.3*MSTP(1)) THEN
24639 JL=2*(J-2*MSTP(1))-1
24640 EJ=KCHG(10+JL,1)/3D0
24641 AJ=SIGN(1D0,EJ+0.1D0)
24642 VJ=AJ-4D0*EJ*XWV
24643 EPS=(2D0*PMAS(10+JL,1))**2/SH
24644 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24645 ELSE
24646 EPS=(2D0*PMAS(24,1))**2/SH
24647 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24648 ENDIF
24649C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24650 IF(EPS.LE.1D0) THEN
24651 ROOT=SQRT(1D0-EPS)
24652 IF(EPS.GT.1D-4) THEN
24653 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24654 ELSE
24655 RLN=LOG(4D0/EPS-2D0)
24656 ENDIF
24657 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24658 PHIIM=0.5D0*PARU(1)*RLN
24659 PSIRE=0.5D0*ROOT*RLN
24660 PSIIM=-0.5D0*ROOT*PARU(1)
24661 ELSE
24662 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24663 PHIIM=0D0
24664 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24665 PSIIM=0D0
24666 ENDIF
24667 IF(EPSP.LE.1D0) THEN
24668 ROOT=SQRT(1D0-EPSP)
24669 IF(EPSP.GT.1D-4) THEN
24670 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24671 ELSE
24672 RLN=LOG(4D0/EPSP-2D0)
24673 ENDIF
24674 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24675 PHIIMP=0.5D0*PARU(1)*RLN
24676 PSIREP=0.5D0*ROOT*RLN
24677 PSIIMP=-0.5D0*ROOT*PARU(1)
24678 ELSE
24679 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24680 PHIIMP=0D0
24681 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24682 PSIIMP=0D0
24683 ENDIF
24684 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24685 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24686 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24687 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24688 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24689 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24690 IF(J.LE.3*MSTP(1)) THEN
24691C...Fermion loops: loop integral different for A0; charges.
24692 IF(IHIGG.EQ.3) FXYRE=0D0
24693 IF(IHIGG.EQ.3) FXYIM=0D0
24694 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24695 EJC=-3D0*EJ*VJ
24696 EJH=PARU(151+10*IHIGG)
24697 ELSEIF(J.LE.2*MSTP(1)) THEN
24698 EJC=-3D0*EJ*VJ
24699 EJH=PARU(152+10*IHIGG)
24700 ELSE
24701 EJC=-EJ*VJ
24702 EJH=PARU(153+10*IHIGG)
24703 ENDIF
24704 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24705 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24706 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24707 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24708C...W loops: loop integral and charges.
24709 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24710 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24711 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24712 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24713 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24714 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24715 ENDIF
24716 ELSE
24717C...Charged H loops: loop integral and charges.
24718 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24719 & PARU(158+10*IHIGG+2*(IHIGG/3))
24720 ETAREJ=FACHHH*FXYRE
24721 ETAIMJ=FACHHH*FXYIM
24722 ENDIF
24723 ETARE=ETARE+ETAREJ
24724 ETAIM=ETAIM+ETAIMJ
24725 260 CONTINUE
24726 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24727 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24728 WID2=WIDS(23,2)
24729
24730 ELSEIF(I.LE.17) THEN
24731C...h0 -> Z0 + Z0, W+ + W-
24732 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24733 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24734 IF(MINT(62).GE.1) THEN
24735 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24736 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24737 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24738 MOFSV(IHIGG,I-15)=0
24739 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24740 & 1D0-4D0*RM1))
24741 WID2=1D0
24742 ELSE
24743 MOFSV(IHIGG,I-15)=1
24744 RMAS=SQRT(MAX(0D0,SH))
24745 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24746 & WID2)
24747 WIDWSV(IHIGG,I-15)=WIDW
24748 WID2SV(IHIGG,I-15)=WID2
24749 ENDIF
24750 ELSE
24751 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24752 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24753 & 1D0-4D0*RM1))
24754 WID2=1D0
24755 ELSE
24756 WIDW=WIDWSV(IHIGG,I-15)
24757 WID2=WID2SV(IHIGG,I-15)
24758 ENDIF
24759 ENDIF
24760 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24761 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24762 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24763 & PARU(138+I+10*IHIGG)**2
24764 WID2=WID2*WIDS(7+I,1)
24765
24766 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24767C...H0 -> Z0 + h0, A0-> Z0 + h0
24768 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24769 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24770 IF(IHIGG.EQ.2) THEN
24771 WDTP(I)=WDTP(I)*PARU(179)**2
24772 ELSEIF(IHIGG.EQ.3) THEN
24773 WDTP(I)=WDTP(I)*PARU(186)**2
24774 ENDIF
24775 WID2=WIDS(23,2)*WIDS(25,2)
24776
24777 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24778C...H0 -> h0 + h0, A0-> h0 + h0
24779 WDTP(I)=FAC*0.25D0*
24780 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24781 IF(IHIGG.EQ.2) THEN
24782 WDTP(I)=WDTP(I)*PARU(176)**2
24783 ELSEIF(IHIGG.EQ.3) THEN
24784 WDTP(I)=WDTP(I)*PARU(169)**2
24785 ENDIF
24786 WID2=WIDS(25,1)
24787 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24788C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24789 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24790 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24791 & *PARU(195+IHIGG)**2
24792 IF(I.EQ.20) THEN
24793 WID2=WIDS(24,2)*WIDS(37,3)
24794 ELSEIF(I.EQ.21) THEN
24795 WID2=WIDS(24,3)*WIDS(37,2)
24796 ENDIF
24797
24798 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24799C...H0 -> Z0 + A0.
24800 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24801 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24802 WID2=WIDS(36,2)*WIDS(23,2)
24803
24804 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24805C...H0 -> h0 + A0.
24806 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24807 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24808 WID2=WIDS(25,2)*WIDS(36,2)
24809
24810 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24811C...H0 -> A0 + A0
24812 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24813 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24814 WID2=WIDS(36,1)
24815
24816CMRENNA++
24817 ELSE
24818C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24819 RM10=RM1*SH/PMR**2
24820 RM20=RM2*SH/PMR**2
24821 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24822 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24823 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24824 WFAC=0D0
24825 ELSE
24826 WFAC=WFAC/WFAC0
24827 ENDIF
24828 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24829CMRENNA--
24830 IF(KFC2.EQ.KFC1) THEN
24831 WID2=WIDS(KFC1,1)
24832 ELSE
24833 KSGN1=2
24834 IF(KFDP(IDC,1).LT.0) KSGN1=3
24835 KSGN2=2
24836 IF(KFDP(IDC,2).LT.0) KSGN2=3
24837 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24838 ENDIF
24839 ENDIF
24840 WDTP(I)=FUDGE*WDTP(I)
24841 WDTP(0)=WDTP(0)+WDTP(I)
24842 IF(MDME(IDC,1).GT.0) THEN
24843 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24844 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24845 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24846 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24847 ENDIF
24848 270 CONTINUE
24849
24850 ELSEIF(KFLA.EQ.32) THEN
24851C...Z'0:
24852 ICASE=1
24853 XWC=1D0/(16D0*XW*XW1)
24854 FAC=(AEM*XWC/3D0)*SHR
24855 VINT(117)=0D0
24856 280 CONTINUE
24857 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24858 VINT(111)=0D0
24859 VINT(112)=0D0
24860 VINT(113)=0D0
24861 VINT(114)=0D0
24862 VINT(115)=0D0
24863 VINT(116)=0D0
24864 ENDIF
24865 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24866 KFAI=IABS(MINT(15))
24867 EI=KCHG(KFAI,1)/3D0
24868 AI=SIGN(1D0,EI+0.1D0)
24869 VI=AI-4D0*EI*XWV
24870 KFAIC=1
24871 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24872 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24873 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24874 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24875 VPI=PARU(119+2*KFAIC)
24876 API=PARU(120+2*KFAIC)
24877 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24878 VPI=PARJ(178+2*KFAIC)
24879 API=PARJ(179+2*KFAIC)
24880 ELSE
24881 VPI=PARJ(186+2*KFAIC)
24882 API=PARJ(187+2*KFAIC)
24883 ENDIF
24884 SQMZ=PMAS(23,1)**2
24885 HZ=SHR*VINT(117)
24886 SQMZP=PMAS(32,1)**2
24887 HZP=SHR*WDTP(0)
24888 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24889 & MSTP(44).EQ.7) VINT(111)=1D0
24890 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24891 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24892 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24893 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24894 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24895 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24896 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24897 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24898 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24899 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24900 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24901 ENDIF
24902 DO 290 I=1,MDCY(KC,3)
24903 IDC=I+MDCY(KC,2)-1
24904 IF(MDME(IDC,1).LT.0) GOTO 290
24905 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24906 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24907 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24908 WID2=1D0
24909 IF(I.LE.16) THEN
24910 IF(I.LE.8) THEN
24911C...Z'0 -> q + qbar
24912 EF=KCHG(I,1)/3D0
24913 AF=SIGN(1D0,EF+0.1D0)
24914 VF=AF-4D0*EF*XWV
24915 IF(I.LE.2) THEN
24916 VPF=PARU(123-2*MOD(I,2))
24917 APF=PARU(124-2*MOD(I,2))
24918 ELSEIF(I.LE.4) THEN
24919 VPF=PARJ(182-2*MOD(I,2))
24920 APF=PARJ(183-2*MOD(I,2))
24921 ELSE
24922 VPF=PARJ(190-2*MOD(I,2))
24923 APF=PARJ(191-2*MOD(I,2))
24924 ENDIF
24925 FCOF=3D0*RADC
24926 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24927 & PYHFTH(SH,SH*RM1,1D0)
24928 IF(I.EQ.6) WID2=WIDS(6,1)
24929 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24930 ELSEIF(I.LE.16) THEN
24931C...Z'0 -> l+ + l-, nu + nubar
24932 EF=KCHG(I+2,1)/3D0
24933 AF=SIGN(1D0,EF+0.1D0)
24934 VF=AF-4D0*EF*XWV
24935 IF(I.LE.10) THEN
24936 VPF=PARU(127-2*MOD(I,2))
24937 APF=PARU(128-2*MOD(I,2))
24938 ELSEIF(I.LE.12) THEN
24939 VPF=PARJ(186-2*MOD(I,2))
24940 APF=PARJ(187-2*MOD(I,2))
24941 ELSE
24942 VPF=PARJ(194-2*MOD(I,2))
24943 APF=PARJ(195-2*MOD(I,2))
24944 ENDIF
24945 FCOF=1D0
24946 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24947 ENDIF
24948 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24949 IF(ICASE.EQ.1) THEN
24950 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24951 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24952 & APF**2*(1D0-4D0*RM1))*BE34
24953 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24954 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24955 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24956 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24957 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24958 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24959 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24960 ELSEIF(MINT(61).EQ.2) THEN
24961 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24962 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24963 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24964 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24965 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24966 & BE34
24967 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24968 & BE34
24969 ENDIF
24970 ELSEIF(I.EQ.17) THEN
24971C...Z'0 -> W+ + W-
24972 WDTPZP=PARU(129)**2*XW1**2*
24973 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24974 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24975 IF(ICASE.EQ.1) THEN
24976 WDTPZ=0D0
24977 WDTP(I)=FAC*WDTPZP
24978 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24979 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24980 ELSEIF(MINT(61).EQ.2) THEN
24981 FGGF=0D0
24982 FGZF=0D0
24983 FGZPF=0D0
24984 FZZF=0D0
24985 FZZPF=0D0
24986 FZPZPF=WDTPZP
24987 ENDIF
24988 WID2=WIDS(24,1)
24989 ELSEIF(I.EQ.18) THEN
24990C...Z'0 -> H+ + H-
24991 CZC=2D0*(1D0-2D0*XW)
24992 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24993 IF(ICASE.EQ.1) THEN
24994 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
24995 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
24996 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24997 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
24998 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
24999 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25000 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25001 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25002 ELSEIF(MINT(61).EQ.2) THEN
25003 FGGF=0.25D0*BE34C
25004 FGZF=0.25D0*PARU(142)*CZC*BE34C
25005 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25006 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25007 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25008 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25009 ENDIF
25010 WID2=WIDS(37,1)
25011 ELSEIF(I.EQ.19) THEN
25012C...Z'0 -> Z0 + gamma.
25013 ELSEIF(I.EQ.20) THEN
25014C...Z'0 -> Z0 + h0
25015 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25016 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25017 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25018 IF(ICASE.EQ.1) THEN
25019 WDTPZ=0D0
25020 WDTP(I)=FAC*WDTPZP
25021 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25022 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25023 ELSEIF(MINT(61).EQ.2) THEN
25024 FGGF=0D0
25025 FGZF=0D0
25026 FGZPF=0D0
25027 FZZF=0D0
25028 FZZPF=0D0
25029 FZPZPF=WDTPZP
25030 ENDIF
25031 WID2=WIDS(23,2)*WIDS(25,2)
25032 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25033C...Z' -> h0 + A0 or H0 + A0.
25034 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25035 IF(I.EQ.21) THEN
25036 CZAH=PARU(186)
25037 CZPAH=PARU(188)
25038 ELSE
25039 CZAH=PARU(187)
25040 CZPAH=PARU(189)
25041 ENDIF
25042 IF(ICASE.EQ.1) THEN
25043 WDTPZ=CZAH**2*BE34C
25044 WDTP(I)=FAC*CZPAH**2*BE34C
25045 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25046 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25047 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25048 & VINT(116))*BE34C
25049 ELSEIF(MINT(61).EQ.2) THEN
25050 FGGF=0D0
25051 FGZF=0D0
25052 FGZPF=0D0
25053 FZZF=CZAH**2*BE34C
25054 FZZPF=CZAH*CZPAH*BE34C
25055 FZPZPF=CZPAH**2*BE34C
25056 ENDIF
25057 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25058 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25059 ENDIF
25060 IF(ICASE.EQ.1) THEN
25061 VINT(117)=VINT(117)+FAC*WDTPZ
25062 WDTP(I)=FUDGE*WDTP(I)
25063 WDTP(0)=WDTP(0)+WDTP(I)
25064 ENDIF
25065 IF(MDME(IDC,1).GT.0) THEN
25066 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25067 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25068 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25069 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25070 & WDTE(I,MDME(IDC,1))
25071 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25072 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25073 ENDIF
25074 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25075 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25076 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25077 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25078 & FGZF*WID2
25079 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25080 & FGZPF*WID2
25081 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25082 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25083 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25084 & FZZPF*WID2
25085 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25086 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25087 ENDIF
25088 ENDIF
25089 290 CONTINUE
25090 IF(MINT(61).GE.1) ICASE=3-ICASE
25091 IF(ICASE.EQ.2) GOTO 280
25092
25093 ELSEIF(KFLA.EQ.34) THEN
25094C...W'+/-:
25095 FAC=(AEM/(24D0*XW))*SHR
25096 DO 300 I=1,MDCY(KC,3)
25097 IDC=I+MDCY(KC,2)-1
25098 IF(MDME(IDC,1).LT.0) GOTO 300
25099 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25100 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25101 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25102 WID2=1D0
25103 IF(I.LE.20) THEN
25104 IF(I.LE.16) THEN
25105C...W'+/- -> q + qbar'
25106 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25107 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25108 IF(KFLR.GT.0) THEN
25109 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25110 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25111 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25112 ELSE
25113 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25114 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25115 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25116 ENDIF
25117 ELSEIF(I.LE.20) THEN
25118C...W'+/- -> l+/- + nu
25119 FCOF=PARU(133)**2+PARU(134)**2
25120 IF(KFLR.GT.0) THEN
25121 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25122 ELSE
25123 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25124 ENDIF
25125 ENDIF
25126 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25127 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25128 ELSEIF(I.EQ.21) THEN
25129C...W'+/- -> W+/- + Z0
25130 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25131 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25132 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25133 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25134 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25135 ELSEIF(I.EQ.23) THEN
25136C...W'+/- -> W+/- + h0
25137 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25138 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25139 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25140 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25141 ENDIF
25142 WDTP(I)=FUDGE*WDTP(I)
25143 WDTP(0)=WDTP(0)+WDTP(I)
25144 IF(MDME(IDC,1).GT.0) THEN
25145 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25146 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25147 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25148 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25149 ENDIF
25150 300 CONTINUE
25151
25152 ELSEIF(KFLA.EQ.37) THEN
25153C...H+/-:
25154C IF(MSTP(49).EQ.0) THEN
25155 SHFS=SH
25156C ELSE
25157C SHFS=PMAS(37,1)**2
25158C ENDIF
25159 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25160 DO 310 I=1,MDCY(KC,3)
25161 IDC=I+MDCY(KC,2)-1
25162 IF(MDME(IDC,1).LT.0) GOTO 310
25163 KFC1=PYCOMP(KFDP(IDC,1))
25164 KFC2=PYCOMP(KFDP(IDC,2))
25165 RM1=PMAS(KFC1,1)**2/SH
25166 RM2=PMAS(KFC2,1)**2/SH
25167 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25168 WID2=1D0
25169 IF(I.LE.4) THEN
25170C...H+/- -> q + qbar'
25171 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25172 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25173 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25174 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25175 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25176 IF(KFLR.GT.0) THEN
25177 IF(I.EQ.3) WID2=WIDS(6,2)
25178 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25179 ELSE
25180 IF(I.EQ.3) WID2=WIDS(6,3)
25181 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25182 ENDIF
25183 ELSEIF(I.LE.8) THEN
25184C...H+/- -> l+/- + nu
25185 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25186 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25187 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25188 IF(KFLR.GT.0) THEN
25189 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25190 ELSE
25191 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25192 ENDIF
25193 ELSEIF(I.EQ.9) THEN
25194C...H+/- -> W+/- + h0.
25195 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25196 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25197 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25198 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25199
25200CMRENNA++
25201 ELSE
25202C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25203 RM10=RM1*SH/PMR**2
25204 RM20=RM2*SH/PMR**2
25205 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25206 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25207 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25208 WFAC=0D0
25209 ELSE
25210 WFAC=WFAC/WFAC0
25211 ENDIF
25212 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25213CMRENNA--
25214 KSGN1=2
25215 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25216 KSGN2=2
25217 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25218 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25219 ENDIF
25220 WDTP(I)=FUDGE*WDTP(I)
25221 WDTP(0)=WDTP(0)+WDTP(I)
25222 IF(MDME(IDC,1).GT.0) THEN
25223 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25224 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25225 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25226 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25227 ENDIF
25228 310 CONTINUE
25229
25230 ELSEIF(KFLA.EQ.41) THEN
25231C...R:
25232 FAC=(AEM/(12D0*XW))*SHR
25233 DO 320 I=1,MDCY(KC,3)
25234 IDC=I+MDCY(KC,2)-1
25235 IF(MDME(IDC,1).LT.0) GOTO 320
25236 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25237 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25238 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25239 WID2=1D0
25240 IF(I.LE.6) THEN
25241C...R -> q + qbar'
25242 FCOF=3D0*RADC
25243 ELSEIF(I.LE.9) THEN
25244C...R -> l+ + l'-
25245 FCOF=1D0
25246 ENDIF
25247 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25248 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25249 IF(KFLR.GT.0) THEN
25250 IF(I.EQ.4) WID2=WIDS(6,3)
25251 IF(I.EQ.5) WID2=WIDS(7,3)
25252 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
25253 IF(I.EQ.9) WID2=WIDS(17,3)
25254 ELSE
25255 IF(I.EQ.4) WID2=WIDS(6,2)
25256 IF(I.EQ.5) WID2=WIDS(7,2)
25257 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
25258 IF(I.EQ.9) WID2=WIDS(17,2)
25259 ENDIF
25260 WDTP(I)=FUDGE*WDTP(I)
25261 WDTP(0)=WDTP(0)+WDTP(I)
25262 IF(MDME(IDC,1).GT.0) THEN
25263 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25264 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25265 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25266 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25267 ENDIF
25268 320 CONTINUE
25269
25270 ELSEIF(KFLA.EQ.42) THEN
25271C...LQ (leptoquark).
25272 FAC=(AEM/4D0)*PARU(151)*SHR
25273 DO 330 I=1,MDCY(KC,3)
25274 IDC=I+MDCY(KC,2)-1
25275 IF(MDME(IDC,1).LT.0) GOTO 330
25276 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25277 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25278 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
25279 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25280 WID2=1D0
25281 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
25282 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
25283 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
25284 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
25285 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
25286 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
25287 WDTP(I)=FUDGE*WDTP(I)
25288 WDTP(0)=WDTP(0)+WDTP(I)
25289 IF(MDME(IDC,1).GT.0) THEN
25290 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25291 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25292 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25293 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25294 ENDIF
25295 330 CONTINUE
25296
25297 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
25298C...Techni-pi0 and techni-pi0':
25299 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25300 DO 340 I=1,MDCY(KC,3)
25301 IDC=I+MDCY(KC,2)-1
25302 IF(MDME(IDC,1).LT.0) GOTO 340
25303 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25304 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25305 RM1=PM1**2/SH
25306 RM2=PM2**2/SH
25307 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
25308 WID2=1D0
25309C...pi_tc -> g + g
25310 IF(I.EQ.8) THEN
25311 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
25312 & /(8D0*PARU(1))*SH*SHR
25313 IF(KFLA.EQ.KTECHN+111) THEN
25314 FACP=FACP*RTCM(9)
25315 ELSE
25316 FACP=FACP*RTCM(10)
25317 ENDIF
25318 WDTP(I)=FACP
25319 ELSE
25320C...pi_tc -> f + fbar.
25321 FCOF=1D0
25322 IKA=IABS(KFDP(IDC,1))
25323 IF(IKA.LT.10) FCOF=3D0*RADC
25324 HM1=PM1
25325 HM2=PM2
25326 IF(IKA.GE.4.AND.IKA.LE.6) THEN
25327 FCOF=FCOF*RTCM(1+IKA)**2
25328 HM1=PYMRUN(KFDP(IDC,1),SH)
25329 HM2=PYMRUN(KFDP(IDC,2),SH)
25330 ELSEIF(IKA.EQ.15) THEN
25331 FCOF=FCOF*RTCM(8)**2
25332 ENDIF
25333 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25334 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25335 ENDIF
25336 WDTP(I)=FUDGE*WDTP(I)
25337 WDTP(0)=WDTP(0)+WDTP(I)
25338 IF(MDME(IDC,1).GT.0) THEN
25339 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25340 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25341 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25342 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25343 ENDIF
25344 340 CONTINUE
25345
25346 ELSEIF(KFLA.EQ.KTECHN+211) THEN
25347C...pi+_tc
25348 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25349 DO 350 I=1,MDCY(KC,3)
25350 IDC=I+MDCY(KC,2)-1
25351 IF(MDME(IDC,1).LT.0) GOTO 350
25352 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25353 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25354 PM3=0D0
25355 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25356 RM1=PM1**2/SH
25357 RM2=PM2**2/SH
25358 RM3=PM3**2/SH
25359 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
25360 WID2=1D0
25361C...pi_tc -> f + f'.
25362 FCOF=1D0
25363 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
25364C...pi_tc+ -> W b b~
25365 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
25366 FCOF=3D0*RADC
25367 XMT2=PMAS(6,1)**2/SH
25368 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
25369 KFC3=PYCOMP(KFDP(IDC,3))
25370 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
25371 CHECK = SQRT(RM1)
25372 T0 = (1D0-CHECK**2)*
25373 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
25374 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
25375 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
25376 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
25377 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
25378 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
25379 & +T3*LOG(CHECK))
25380 IF(KFLR.GT.0) THEN
25381 WID2=WIDS(24,2)
25382 ELSE
25383 WID2=WIDS(24,3)
25384 ENDIF
25385 ELSE
25386 FCOF=1D0
25387 IKA=IABS(KFDP(IDC,1))
25388 IF(IKA.LT.10) FCOF=3D0*RADC
25389 HM1=PM1
25390 HM2=PM2
25391 IF(I.GE.1.AND.I.LE.5) THEN
25392 IF(I.LE.2) THEN
25393 FCOF=FCOF*RTCM(5)**2
25394 ELSEIF(I.LE.4) THEN
25395 FCOF=FCOF*RTCM(6)**2
25396 ELSEIF(I.EQ.5) THEN
25397 FCOF=FCOF*RTCM(7)**2
25398 ENDIF
25399 HM1=PYMRUN(KFDP(IDC,1),SH)
25400 HM2=PYMRUN(KFDP(IDC,2),SH)
25401 ELSEIF(I.EQ.8) THEN
25402 FCOF=FCOF*RTCM(8)**2
25403 ENDIF
25404 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25405 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25406 ENDIF
25407 WDTP(I)=FUDGE*WDTP(I)
25408 WDTP(0)=WDTP(0)+WDTP(I)
25409 IF(MDME(IDC,1).GT.0) THEN
25410 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25411 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25412 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25413 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25414 ENDIF
25415 350 CONTINUE
25416
25417 ELSEIF(KFLA.EQ.KTECHN+331) THEN
25418C...Techni-eta.
25419 FAC=(SH/PARP(46)**2)*SHR
25420 DO 360 I=1,MDCY(KC,3)
25421 IDC=I+MDCY(KC,2)-1
25422 IF(MDME(IDC,1).LT.0) GOTO 360
25423 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25424 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25425 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
25426 WID2=1D0
25427 IF(I.LE.2) THEN
25428 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
25429 IF(I.EQ.2) WID2=WIDS(6,1)
25430 ELSE
25431 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
25432 ENDIF
25433 WDTP(I)=FUDGE*WDTP(I)
25434 WDTP(0)=WDTP(0)+WDTP(I)
25435 IF(MDME(IDC,1).GT.0) THEN
25436 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25437 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25438 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25439 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25440 ENDIF
25441 360 CONTINUE
25442
25443 ELSEIF(KFLA.EQ.KTECHN+113) THEN
25444C...Techni-rho0:
25445 ALPRHT=2.16D0*(3D0/ITCM(1))
25446 FAC=(ALPRHT/12D0)*SHR
25447 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
25448 SQMZ=PMAS(23,1)**2
25449 SQMW=PMAS(24,1)**2
25450 SHP=SH
25451 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25452 GMMZ=SHR*WDTPP(0)
25453 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25454 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25455 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25456 DO 370 I=1,MDCY(KC,3)
25457 IDC=I+MDCY(KC,2)-1
25458 IF(MDME(IDC,1).LT.0) GOTO 370
25459 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25460 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25461 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
25462 WID2=1D0
25463 IF(I.EQ.1) THEN
25464C...rho_tc0 -> W+ + W-.
25465C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25466 WDTP(I)=FAC*RTCM(3)**4*
25467 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25468 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25469 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25470 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
25471 WID2=WIDS(24,1)
25472 ELSEIF(I.EQ.2) THEN
25473C...rho_tc0 -> W+ + pi_tc-.
25474C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
25475 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25476 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25477 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25478 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
25479 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25480 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25481 ELSEIF(I.EQ.3) THEN
25482C...rho_tc0 -> pi_tc+ + W-.
25483 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25484 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25485 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25486 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
25487 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25488 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
25489 ELSEIF(I.EQ.4) THEN
25490C...rho_tc0 -> pi_tc+ + pi_tc-.
25491 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25492 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25493 WID2=WIDS(PYCOMP(KTECHN+211),1)
25494 ELSEIF(I.EQ.5) THEN
25495C...rho_tc0 -> gamma + pi_tc0
25496 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25497 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25498 & SHR**3
25499 WID2=WIDS(PYCOMP(KTECHN+111),2)
25500 ELSEIF(I.EQ.6) THEN
25501C...rho_tc0 -> gamma + pi_tc0'
25502 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25503 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
25504 WID2=WIDS(PYCOMP(KTECHN+221),2)
25505 ELSEIF(I.EQ.7) THEN
25506C...rho_tc0 -> Z0 + pi_tc0
25507 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25508 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25509 & XW/XW1*SHR**3
25510 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25511 ELSEIF(I.EQ.8) THEN
25512C...rho_tc0 -> Z0 + pi_tc0'
25513 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25514 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25515 & XW/XW1*SHR**3
25516 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25517 ELSEIF(I.EQ.9) THEN
25518C...rho_tc0 -> gamma + Z0
25519 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25520 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25521 WID2=WIDS(23,2)
25522 ELSEIF(I.EQ.10) THEN
25523C...rho_tc0 -> Z0 + Z0
25524 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25525 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
25526 & SHR**3
25527 WID2=WIDS(23,1)
25528 ELSE
25529C...rho_tc0 -> f + fbar.
25530 WID2=1D0
25531 IF(I.LE.18) THEN
25532 IA=I-10
25533 FCOF=3D0*RADC
25534 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25535 ELSE
25536 IA=I-6
25537 FCOF=1D0
25538 IF(IA.GE.17) WID2=WIDS(IA,1)
25539 ENDIF
25540 EI=KCHG(IA,1)/3D0
25541 AI=SIGN(1D0,EI+0.1D0)
25542 VI=AI-4D0*EI*XWV
25543 VALI=0.5D0*(VI+AI)
25544 VARI=0.5D0*(VI-AI)
25545 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25546 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25547 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25548 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25549 ENDIF
25550 WDTP(I)=FUDGE*WDTP(I)
25551 WDTP(0)=WDTP(0)+WDTP(I)
25552 IF(MDME(IDC,1).GT.0) THEN
25553 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25554 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25555 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25556 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25557 ENDIF
25558 370 CONTINUE
25559
25560 ELSEIF(KFLA.EQ.KTECHN+213) THEN
25561C...Techni-rho+/-:
25562 ALPRHT=2.16D0*(3D0/ITCM(1))
25563 FAC=(ALPRHT/12D0)*SHR
25564 SQMZ=PMAS(23,1)**2
25565 SQMW=PMAS(24,1)**2
25566 SHP=SH
25567 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
25568 GMMW=SHR*WDTPP(0)
25569 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
25570 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25571 DO 380 I=1,MDCY(KC,3)
25572 IDC=I+MDCY(KC,2)-1
25573 IF(MDME(IDC,1).LT.0) GOTO 380
25574 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25575 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25576 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
25577 WID2=1D0
25578 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25579c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25580c & /3D0*SHR**3
25581 IF(I.EQ.1) THEN
25582C...rho_tc+ -> W+ + Z0.
25583C......Goldstone
25584 WDTP(I)=FAC*RTCM(3)**4*
25585 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25586 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
25587 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
25588C......W_L Z_T
25589 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
25590 & /3D0*SHR**3
25591 VA2=0D0
25592 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
25593C......W_T Z_L
25594 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25595 & /3D0*SHR**3
25596 IF(KFLR.GT.0) THEN
25597 WID2=WIDS(24,2)*WIDS(23,2)
25598 ELSE
25599 WID2=WIDS(24,3)*WIDS(23,2)
25600 ENDIF
25601 ELSEIF(I.EQ.2) THEN
25602C...rho_tc+ -> W+ + pi_tc0.
25603 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25604 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25605 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25606 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25607 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25608 IF(KFLR.GT.0) THEN
25609 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
25610 ELSE
25611 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
25612 ENDIF
25613 ELSEIF(I.EQ.3) THEN
25614C...rho_tc+ -> pi_tc+ + Z0.
25615 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25616 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25617 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25618 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
25619 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
25620 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25621 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25622 & SHR**3*XW/XW1
25623 IF(KFLR.GT.0) THEN
25624 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
25625 ELSE
25626 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
25627 ENDIF
25628 ELSEIF(I.EQ.4) THEN
25629C...rho_tc+ -> pi_tc+ + pi_tc0.
25630 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25631 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25632 IF(KFLR.GT.0) THEN
25633 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25634 ELSE
25635 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25636 ENDIF
25637 ELSEIF(I.EQ.5) THEN
25638C...rho_tc+ -> pi_tc+ + gamma
25639 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25640 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25641 & SHR**3
25642 IF(KFLR.GT.0) THEN
25643 WID2=WIDS(PYCOMP(KTECHN+211),2)
25644 ELSE
25645 WID2=WIDS(PYCOMP(KTECHN+211),3)
25646 ENDIF
25647 ELSEIF(I.EQ.6) THEN
25648C...rho_tc+ -> W+ + pi_tc0'
25649 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25650 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25651 IF(KFLR.GT.0) THEN
25652 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25653 ELSE
25654 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25655 ENDIF
25656 ELSEIF(I.EQ.7) THEN
25657C...rho_tc+ -> W+ + gamma
25658 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25659 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25660 IF(KFLR.GT.0) THEN
25661 WID2=WIDS(24,2)
25662 ELSE
25663 WID2=WIDS(24,3)
25664 ENDIF
25665 ELSE
25666C...rho_tc+ -> f + fbar'.
25667 IA=I-7
25668 WID2=1D0
25669 IF(IA.LE.16) THEN
25670 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25671 IF(KFLR.GT.0) THEN
25672 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25673 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25674 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25675 ELSE
25676 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25677 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25678 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25679 ENDIF
25680 ELSE
25681 FCOF=1D0
25682 IF(KFLR.GT.0) THEN
25683 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25684 ELSE
25685 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25686 ENDIF
25687 ENDIF
25688 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25689 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25690 ENDIF
25691 WDTP(I)=FUDGE*WDTP(I)
25692 WDTP(0)=WDTP(0)+WDTP(I)
25693 IF(MDME(IDC,1).GT.0) THEN
25694 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25695 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25696 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25697 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25698 ENDIF
25699 380 CONTINUE
25700
25701 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25702C...Techni-omega:
25703 ALPRHT=2.16D0*(3D0/ITCM(1))
25704 FAC=(ALPRHT/12D0)*SHR
25705 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25706 SQMZ=PMAS(23,1)**2
25707 SHP=SH
25708 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25709 GMMZ=SHR*WDTPP(0)
25710 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25711 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25712 DO 390 I=1,MDCY(KC,3)
25713 IDC=I+MDCY(KC,2)-1
25714 IF(MDME(IDC,1).LT.0) GOTO 390
25715 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25716 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25717 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25718 WID2=1D0
25719 IF(I.EQ.1) THEN
25720C...omega_tc0 -> gamma + pi_tc0.
25721 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25722 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25723 WID2=WIDS(PYCOMP(KTECHN+111),2)
25724 ELSEIF(I.EQ.2) THEN
25725C...omega_tc0 -> Z0 + pi_tc0
25726 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25727 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25728 & XW/XW1*SHR**3
25729 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25730 ELSEIF(I.EQ.3) THEN
25731C...omega_tc0 -> gamma + pi_tc0'
25732 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25733 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25734 & SHR**3
25735 WID2=WIDS(PYCOMP(KTECHN+221),2)
25736 ELSEIF(I.EQ.4) THEN
25737C...omega_tc0 -> Z0 + pi_tc0'
25738 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25739 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25740 & XW/XW1*SHR**3
25741 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25742 ELSEIF(I.EQ.5) THEN
25743C...omega_tc0 -> W+ + pi_tc-
25744 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25745 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25746 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25747 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25748 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25749 ELSEIF(I.EQ.6) THEN
25750C...omega_tc0 -> pi_tc+ + W-
25751 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25752 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25753 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25754 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25755 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25756 ELSEIF(I.EQ.7) THEN
25757C...omega_tc0 -> W+ + W-.
25758C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25759 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25760 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25761 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25762 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
25763 WID2=WIDS(24,1)
25764 ELSEIF(I.EQ.8) THEN
25765C...omega_tc0 -> pi_tc+ + pi_tc-.
25766 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25767 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25768 WID2=WIDS(PYCOMP(KTECHN+211),1)
25769C...omega_tc0 -> gamma + Z0
25770 ELSEIF(I.EQ.9) THEN
25771 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25772 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25773 WID2=WIDS(23,2)
25774C...omega_tc0 -> Z0 + Z0
25775 ELSEIF(I.EQ.10) THEN
25776 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25777 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
25778 & /24D0/RTCM(12)**2*SHR**3
25779 WID2=WIDS(23,1)
25780 ELSE
25781C...omega_tc0 -> f + fbar.
25782 WID2=1D0
25783 IF(I.LE.18) THEN
25784 IA=I-10
25785 FCOF=3D0*RADC
25786 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25787 ELSE
25788 IA=I-8
25789 FCOF=1D0
25790 IF(IA.GE.17) WID2=WIDS(IA,1)
25791 ENDIF
25792 EI=KCHG(IA,1)/3D0
25793 AI=SIGN(1D0,EI+0.1D0)
25794 VI=AI-4D0*EI*XWV
25795 VALI=-0.5D0*(VI+AI)
25796 VARI=-0.5D0*(VI-AI)
25797 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25798 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25799 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25800 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25801 ENDIF
25802 WDTP(I)=FUDGE*WDTP(I)
25803 WDTP(0)=WDTP(0)+WDTP(I)
25804 IF(MDME(IDC,1).GT.0) THEN
25805 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25806 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25807 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25808 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25809 ENDIF
25810 390 CONTINUE
25811
25812C.....V8 -> quark anti-quark
25813 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25814 FAC=AS/6D0*SHR
25815 TANT3=RTCM(21)
25816 IF(ITCM(2).EQ.0) THEN
25817 IMDL=1
25818 ELSEIF(ITCM(2).EQ.1) THEN
25819 IMDL=2
25820 ENDIF
25821 DO 400 I=1,MDCY(KC,3)
25822 IDC=I+MDCY(KC,2)-1
25823 IF(MDME(IDC,1).LT.0) GOTO 400
25824 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25825 RM1=PM1**2/SH
25826 IF(RM1.GT.0.25D0) GOTO 400
25827 WID2=1D0
25828 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25829 FMIX=1D0/TANT3**2
25830 ELSE
25831 FMIX=TANT3**2
25832 ENDIF
25833 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25834 IF(I.EQ.6) WID2=WIDS(6,1)
25835 WDTP(I)=FUDGE*WDTP(I)
25836 WDTP(0)=WDTP(0)+WDTP(I)
25837 IF(MDME(IDC,1).GT.0) THEN
25838 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25839 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25840 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25841 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25842 ENDIF
25843 400 CONTINUE
25844
25845 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25846 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25847 CLEBF=0D0
25848 DO 410 I=1,MDCY(KC,3)
25849 IDC=I+MDCY(KC,2)-1
25850 IF(MDME(IDC,1).LT.0) GOTO 410
25851 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25852 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25853 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25854 WID2=1D0
25855C...pi_tc -> g + g
25856 IF(I.EQ.7) THEN
25857 IF(KFLA.EQ.KTECHN+100111) THEN
25858 CLEBG=4D0/3D0
25859 ELSE
25860 CLEBG=5D0/3D0
25861 ENDIF
25862 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25863 & /(2D0*PARU(1))*SH*SHR*CLEBG
25864 WDTP(I)=FACP
25865 ELSE
25866C...pi_tc -> f + fbar.
25867 IF(I.EQ.6) WID2=WIDS(6,1)
25868 FCOF=1D0
25869 IKA=IABS(KFDP(IDC,1))
25870 IF(IKA.LT.10) FCOF=3D0*RADC
25871 HM1=PYMRUN(KFDP(IDC,1),SH)
25872 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25873 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25874 ENDIF
25875 WDTP(I)=FUDGE*WDTP(I)
25876 WDTP(0)=WDTP(0)+WDTP(I)
25877 IF(MDME(IDC,1).GT.0) THEN
25878 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25879 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25880 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25881 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25882 ENDIF
25883 410 CONTINUE
25884
25885 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25886 FAC=AS/6D0*SHR
25887 ALPRHT=2.16D0*(3D0/ITCM(1))
25888 TANT3=RTCM(21)
25889 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25890 SINT3=TANT3/SQRT(TANT3**2+1D0)
25891 CSXPP=RTCM(22)
25892 RM82=RTCM(27)**2
25893 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25894 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25895 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25896 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25897 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25898 & SINT3**2)*2D0
25899 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25900 & SINT3**2)*2D0
25901 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25902
25903 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25904 GMV8=SHR*WDTPP(0)
25905 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25906 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25907 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25908 IF(ITCM(2).EQ.0) THEN
25909 IMDL=1
25910 ELSE
25911 IMDL=2
25912 ENDIF
25913 DO 420 I=1,MDCY(KC,3)
25914 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25915 & KFLA.EQ.KTECHN+300113)) GOTO 420
25916 IDC=I+MDCY(KC,2)-1
25917 IF(MDME(IDC,1).LT.0) GOTO 420
25918 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25919 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25920 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25921 WID2=1D0
25922 IF(I.LE.6) THEN
25923 IF(I.EQ.6) WID2=WIDS(6,1)
25924 XIG=1D0
25925 IF(KFLA.EQ.KTECHN+200113) THEN
25926 XIG=0D0
25927 XIJ=X12
25928 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25929 XIG=0D0
25930 XIJ=X21
25931 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25932 XIJ=X11
25933 ELSE
25934 XIJ=X22
25935 ENDIF
25936 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25937 FMIX=1D0/TANT3/SIN2T
25938 ELSE
25939 FMIX=-TANT3/SIN2T
25940 ENDIF
25941 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25942 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25943 ELSEIF(I.EQ.7) THEN
25944 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25945 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25946 PSH=SHR*(1D0-RM1)/2D0
25947 WDTP(I)=AS/9D0*PSH**3/RM82
25948 IF(I.EQ.8) THEN
25949 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25950 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25951 ELSE
25952 WDTP(I)=5D0*WDTP(I)
25953 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25954 ENDIF
25955 ENDIF
25956 WDTP(I)=FUDGE*WDTP(I)
25957 WDTP(0)=WDTP(0)+WDTP(I)
25958 IF(MDME(IDC,1).GT.0) THEN
25959 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25960 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25961 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25962 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25963 ENDIF
25964 420 CONTINUE
25965
25966 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25967C...d* excited quark.
25968 FAC=(SH/RTCM(41)**2)*SHR
25969 DO 430 I=1,MDCY(KC,3)
25970 IDC=I+MDCY(KC,2)-1
25971 IF(MDME(IDC,1).LT.0) GOTO 430
25972 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25973 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25974 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25975 WID2=1D0
25976 IF(I.EQ.1) THEN
25977C...d* -> g + d.
25978 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25979 WID2=1D0
25980 ELSEIF(I.EQ.2) THEN
25981C...d* -> gamma + d.
25982 QF=-RTCM(43)/2D0+RTCM(44)/6D0
25983 WDTP(I)=FAC*AEM*QF**2/4D0
25984 WID2=1D0
25985 ELSEIF(I.EQ.3) THEN
25986C...d* -> Z0 + d.
25987 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25988 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25989 & (1D0-RM1)**2*(2D0+RM1)
25990 WID2=WIDS(23,2)
25991 ELSEIF(I.EQ.4) THEN
25992C...d* -> W- + u.
25993 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25994 & (1D0-RM1)**2*(2D0+RM1)
25995 IF(KFLR.GT.0) WID2=WIDS(24,3)
25996 IF(KFLR.LT.0) WID2=WIDS(24,2)
25997 ENDIF
25998 WDTP(I)=FUDGE*WDTP(I)
25999 WDTP(0)=WDTP(0)+WDTP(I)
26000 IF(MDME(IDC,1).GT.0) THEN
26001 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26002 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26003 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26004 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26005 ENDIF
26006 430 CONTINUE
26007
26008 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26009C...u* excited quark.
26010 FAC=(SH/RTCM(41)**2)*SHR
26011 DO 440 I=1,MDCY(KC,3)
26012 IDC=I+MDCY(KC,2)-1
26013 IF(MDME(IDC,1).LT.0) GOTO 440
26014 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26015 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26016 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26017 WID2=1D0
26018 IF(I.EQ.1) THEN
26019C...u* -> g + u.
26020 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26021 WID2=1D0
26022 ELSEIF(I.EQ.2) THEN
26023C...u* -> gamma + u.
26024 QF=RTCM(43)/2D0+RTCM(44)/6D0
26025 WDTP(I)=FAC*AEM*QF**2/4D0
26026 WID2=1D0
26027 ELSEIF(I.EQ.3) THEN
26028C...u* -> Z0 + u.
26029 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26030 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26031 & (1D0-RM1)**2*(2D0+RM1)
26032 WID2=WIDS(23,2)
26033 ELSEIF(I.EQ.4) THEN
26034C...u* -> W+ + d.
26035 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26036 & (1D0-RM1)**2*(2D0+RM1)
26037 IF(KFLR.GT.0) WID2=WIDS(24,2)
26038 IF(KFLR.LT.0) WID2=WIDS(24,3)
26039 ENDIF
26040 WDTP(I)=FUDGE*WDTP(I)
26041 WDTP(0)=WDTP(0)+WDTP(I)
26042 IF(MDME(IDC,1).GT.0) THEN
26043 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26044 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26045 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26046 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26047 ENDIF
26048 440 CONTINUE
26049
26050 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26051C...e* excited lepton.
26052 FAC=(SH/RTCM(41)**2)*SHR
26053 DO 450 I=1,MDCY(KC,3)
26054 IDC=I+MDCY(KC,2)-1
26055 IF(MDME(IDC,1).LT.0) GOTO 450
26056 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26057 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26058 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26059 WID2=1D0
26060 IF(I.EQ.1) THEN
26061C...e* -> gamma + e.
26062 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26063 WDTP(I)=FAC*AEM*QF**2/4D0
26064 WID2=1D0
26065 ELSEIF(I.EQ.2) THEN
26066C...e* -> Z0 + e.
26067 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26068 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26069 & (1D0-RM1)**2*(2D0+RM1)
26070 WID2=WIDS(23,2)
26071 ELSEIF(I.EQ.3) THEN
26072C...e* -> W- + nu.
26073 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26074 & (1D0-RM1)**2*(2D0+RM1)
26075 IF(KFLR.GT.0) WID2=WIDS(24,3)
26076 IF(KFLR.LT.0) WID2=WIDS(24,2)
26077 ENDIF
26078 WDTP(I)=FUDGE*WDTP(I)
26079 WDTP(0)=WDTP(0)+WDTP(I)
26080 IF(MDME(IDC,1).GT.0) THEN
26081 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26082 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26083 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26084 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26085 ENDIF
26086 450 CONTINUE
26087
26088 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26089C...nu*_e excited neutrino.
26090 FAC=(SH/RTCM(41)**2)*SHR
26091 DO 460 I=1,MDCY(KC,3)
26092 IDC=I+MDCY(KC,2)-1
26093 IF(MDME(IDC,1).LT.0) GOTO 460
26094 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26095 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26096 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26097 WID2=1D0
26098 IF(I.EQ.1) THEN
26099C...nu*_e -> Z0 + nu*_e.
26100 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26101 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26102 & (1D0-RM1)**2*(2D0+RM1)
26103 WID2=WIDS(23,2)
26104 ELSEIF(I.EQ.2) THEN
26105C...nu*_e -> W+ + e.
26106 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26107 & (1D0-RM1)**2*(2D0+RM1)
26108 IF(KFLR.GT.0) WID2=WIDS(24,2)
26109 IF(KFLR.LT.0) WID2=WIDS(24,3)
26110 ENDIF
26111 WDTP(I)=FUDGE*WDTP(I)
26112 WDTP(0)=WDTP(0)+WDTP(I)
26113 IF(MDME(IDC,1).GT.0) THEN
26114 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26115 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26116 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26117 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26118 ENDIF
26119 460 CONTINUE
26120
26121 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26122C...G* (graviton resonance):
26123 FAC=(PARP(50)**2/PARU(1))*SHR
26124 DO 470 I=1,MDCY(KC,3)
26125 IDC=I+MDCY(KC,2)-1
26126 IF(MDME(IDC,1).LT.0) GOTO 470
26127 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26128 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26129 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26130 WID2=1D0
26131 IF(I.LE.8) THEN
26132C...G* -> q + qbar
26133 FCOF=3D0*RADC
26134 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26135 & PYHFTH(SH,SH*RM1,1D0)
26136 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26137 & (1D0+8D0*RM1/3D0)/320D0
26138 IF(I.EQ.6) WID2=WIDS(6,1)
26139 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
26140 ELSEIF(I.LE.16) THEN
26141C...G* -> l+ + l-, nu + nubar
26142 FCOF=1D0
26143 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26144 & (1D0+8D0*RM1/3D0)/320D0
26145 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
26146 ELSEIF(I.EQ.17) THEN
26147C...G* -> g + g.
26148 WDTP(I)=FAC/20D0
26149 ELSEIF(I.EQ.18) THEN
26150C...G* -> gamma + gamma.
26151 WDTP(I)=FAC/160D0
26152 ELSEIF(I.EQ.19) THEN
26153C...G* -> Z0 + Z0.
26154 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26155 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
26156 WID2=WIDS(23,1)
26157 ELSEIF(I.EQ.20) THEN
26158C...G* -> W+ + W-.
26159 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26160 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
26161 WID2=WIDS(24,1)
26162 ENDIF
26163 WDTP(I)=FUDGE*WDTP(I)
26164 WDTP(0)=WDTP(0)+WDTP(I)
26165 IF(MDME(IDC,1).GT.0) THEN
26166 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26167 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26168 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26169 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26170 ENDIF
26171 470 CONTINUE
26172
26173 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
26174C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26175 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
26176 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
26177 DO 480 I=1,MDCY(KC,3)
26178 IDC=I+MDCY(KC,2)-1
26179 IF(MDME(IDC,1).LT.0) GOTO 480
26180 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26181 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26182 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26183 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
26184 WID2=1D0
26185 IF(I.LE.9) THEN
26186C...nu_lR -> l- qbar q'
26187 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26188 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26189 ELSEIF(I.LE.18) THEN
26190C...nu_lR -> l+ q qbar'
26191 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
26192 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
26193 ELSE
26194C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26195 FCOF=1D0
26196 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
26197 ENDIF
26198 X=(PM1+PM2+PM3)/SHR
26199 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
26200 Y=(SHR/PMWR)**2
26201 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
26202 WDTP(I)=FAC*FCOF*FX*FY
26203 WDTP(I)=FUDGE*WDTP(I)
26204 WDTP(0)=WDTP(0)+WDTP(I)
26205 IF(MDME(IDC,1).GT.0) THEN
26206 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26207 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26208 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26209 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26210 ENDIF
26211 480 CONTINUE
26212
26213 ELSEIF(KFLA.EQ.9900023) THEN
26214C...Z_R0:
26215 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
26216 DO 490 I=1,MDCY(KC,3)
26217 IDC=I+MDCY(KC,2)-1
26218 IF(MDME(IDC,1).LT.0) GOTO 490
26219 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26220 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26221 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
26222 WID2=1D0
26223 SYMMET=1D0
26224 IF(I.LE.6) THEN
26225C...Z_R0 -> q + qbar
26226 EF=KCHG(I,1)/3D0
26227 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
26228 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
26229 FCOF=3D0*RADC
26230 IF(I.EQ.6) WID2=WIDS(6,1)
26231 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
26232C...Z_R0 -> l+ + l-
26233 AF=-(1D0-2D0*XW)
26234 VF=-1D0+4D0*XW
26235 FCOF=1D0
26236 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
26237C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
26238 AF=-2D0*XW
26239 VF=0D0
26240 FCOF=1D0
26241 SYMMET=0.5D0
26242 ELSEIF(I.LE.15) THEN
26243C...Z0 -> nu_R + nu_R, assumed Majorana.
26244 AF=2D0*XW1
26245 VF=0D0
26246 FCOF=1D0
26247 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
26248 SYMMET=0.5D0
26249 ENDIF
26250 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
26251 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
26252 WDTP(I)=FUDGE*WDTP(I)
26253 WDTP(0)=WDTP(0)+WDTP(I)
26254 IF(MDME(IDC,1).GT.0) THEN
26255 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26256 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26257 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26258 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26259 ENDIF
26260 490 CONTINUE
26261
26262 ELSEIF(KFLA.EQ.9900024) THEN
26263C...W_R+/-:
26264 FAC=(AEM/(24D0*XW))*SHR
26265 DO 500 I=1,MDCY(KC,3)
26266 IDC=I+MDCY(KC,2)-1
26267 IF(MDME(IDC,1).LT.0) GOTO 500
26268 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26269 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26270 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
26271 WID2=1D0
26272 IF(I.LE.9) THEN
26273C...W_R+/- -> q + qbar'
26274 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26275 IF(KFLR.GT.0) THEN
26276 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26277 ELSE
26278 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
26279 ENDIF
26280 ELSEIF(I.LE.12) THEN
26281C...W_R+/- -> l+/- + nu_R
26282 FCOF=1D0
26283 ENDIF
26284 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26285 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26286 WDTP(I)=FUDGE*WDTP(I)
26287 WDTP(0)=WDTP(0)+WDTP(I)
26288 IF(MDME(IDC,1).GT.0) THEN
26289 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26290 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26291 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26292 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26293 ENDIF
26294 500 CONTINUE
26295
26296 ELSEIF(KFLA.EQ.9900041) THEN
26297C...H_L++/--:
26298 FAC=(1D0/(8D0*PARU(1)))*SHR
26299 DO 510 I=1,MDCY(KC,3)
26300 IDC=I+MDCY(KC,2)-1
26301 IF(MDME(IDC,1).LT.0) GOTO 510
26302 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26303 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26304 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
26305 WID2=1D0
26306 IF(I.LE.6) THEN
26307C...H_L++/-- -> l+/- + l'+/-
26308 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26309 & (IABS(KFDP(IDC,2))-9)/2)**2
26310 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26311 ELSEIF(I.EQ.7) THEN
26312C...H_L++/-- -> W_L+/- + W_L+/-
26313 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
26314 & (3D0*RM1+0.25D0/RM1-1D0)
26315 WID2=WIDS(24,4+(1-KFLS)/2)
26316 ENDIF
26317 WDTP(I)=FAC*FCOF*
26318 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26319 WDTP(I)=FUDGE*WDTP(I)
26320 WDTP(0)=WDTP(0)+WDTP(I)
26321 IF(MDME(IDC,1).GT.0) THEN
26322 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26323 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26324 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26325 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26326 ENDIF
26327 510 CONTINUE
26328
26329 ELSEIF(KFLA.EQ.9900042) THEN
26330C...H_R++/--:
26331 FAC=(1D0/(8D0*PARU(1)))*SHR
26332 DO 520 I=1,MDCY(KC,3)
26333 IDC=I+MDCY(KC,2)-1
26334 IF(MDME(IDC,1).LT.0) GOTO 520
26335 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26336 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26337 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
26338 WID2=1D0
26339 IF(I.LE.6) THEN
26340C...H_R++/-- -> l+/- + l'+/-
26341 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26342 & (IABS(KFDP(IDC,2))-9)/2)**2
26343 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26344 ELSEIF(I.EQ.7) THEN
26345C...H_R++/-- -> W_R+/- + W_R+/-
26346 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
26347 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
26348 ENDIF
26349 WDTP(I)=FAC*FCOF*
26350 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26351 WDTP(I)=FUDGE*WDTP(I)
26352 WDTP(0)=WDTP(0)+WDTP(I)
26353 IF(MDME(IDC,1).GT.0) THEN
26354 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26355 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26356 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26357 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26358 ENDIF
26359 520 CONTINUE
26360
26361 ELSEIF(KFLA.EQ.KTECHN+115) THEN
26362C...Techni-a2:
26363C...Need to update to alpha_rho
26364 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26365 FAC=(ALPRHT/12D0)*SHR
26366 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26367 SQMZ=PMAS(23,1)**2
26368 SQMW=PMAS(24,1)**2
26369 SHP=SH
26370 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26371 GMMZ=SHR*WDTPP(0)
26372 XWRHT=1D0/(4D0*XW*(1D0-XW))
26373 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26374 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26375 DO 530 I=1,MDCY(KC,3)
26376 IDC=I+MDCY(KC,2)-1
26377 IF(MDME(IDC,1).LT.0) GOTO 530
26378 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26379 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26380 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
26381 WID2=1D0
26382 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26383 IF(I.LE.4) THEN
26384 FACPV=PCM**2
26385 FACPA=PCM**2+1.5D0*RM1
26386 VA2=0D0
26387 AA2=0D0
26388C...a2_tc0 -> W+ + W-
26389 IF(I.EQ.1) THEN
26390 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
26391C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
26392 WID2=WIDS(24,1)
26393C...a2_tc0 -> W+ + pi_tc- + c.c.
26394 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
26395 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26396 IF(I.EQ.6) THEN
26397 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26398 ELSE
26399 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26400 ENDIF
26401 ELSEIF(I.EQ.4) THEN
26402C...a2_tc0 -> Z0 + pi_tc0'
26403 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
26404 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26405 ENDIF
26406 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
26407 ELSEIF(I.GE.5.AND.I.LE.10) THEN
26408 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26409 FACPA=PCM**2*(1D0+RM1+RM2)
26410 VA2=0D0
26411 AA2=0D0
26412 IF(I.EQ.5) THEN
26413C...a_T^0 -> gamma rho_T^0
26414 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26415 WID2=WIDS(PYCOMP(KTECHN+113),2)
26416 ELSEIF(I.EQ.6) THEN
26417C...a_T^0 -> gamma omega_T
26418 VA2=1D0/RTCM(50)**4
26419 WID2=WIDS(PYCOMP(KTECHN+223),2)
26420 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
26421C...a_T^0 -> W^+- rho_T^-+
26422 AA2=.25D0/XW/RTCM(51)**4
26423 IF(I.EQ.7) THEN
26424 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
26425 ELSE
26426 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
26427 ENDIF
26428 ELSEIF(I.EQ.9) THEN
26429C...a_T^0 -> Z^0 rho_T^0
26430 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26431 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
26432 ELSEIF(I.EQ.10) THEN
26433C...a_T^0 -> Z^0 omega_T
26434 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
26435 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
26436 ENDIF
26437 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26438 ELSE
26439C...a2_tc0 -> f + fbar.
26440 WID2=1D0
26441 IF(I.LE.18) THEN
26442 IA=I-10
26443 FCOF=3D0*RADC
26444 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26445 ELSE
26446 IA=I-8
26447 FCOF=1D0
26448 IF(IA.GE.17) WID2=WIDS(IA,1)
26449 ENDIF
26450 EI=KCHG(IA,1)/3D0
26451 AI=SIGN(1D0,EI+0.1D0)
26452 VI=AI-4D0*EI*XWV
26453 VALI=0.5D0*(VI+AI)
26454 VARI=0.5D0*(VI-AI)
26455 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26456 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
26457 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26458 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
26459 ENDIF
26460 WDTP(I)=FUDGE*WDTP(I)
26461 WDTP(0)=WDTP(0)+WDTP(I)
26462 IF(MDME(IDC,1).GT.0) THEN
26463 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26464 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26465 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26466 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26467 ENDIF
26468 530 CONTINUE
26469
26470 ELSEIF(KFLA.EQ.KTECHN+215) THEN
26471C...Techni-a2+/-:
26472 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26473 FAC=(ALPRHT/12D0)*SHR
26474 SQMZ=PMAS(23,1)**2
26475 SQMW=PMAS(24,1)**2
26476 SHP=SH
26477 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26478 GMMW=SHR*WDTPP(0)
26479 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26480 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26481 DO 540 I=1,MDCY(KC,3)
26482 IDC=I+MDCY(KC,2)-1
26483 IF(MDME(IDC,1).LT.0) GOTO 540
26484 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26485 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26486 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
26487 WID2=1D0
26488 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26489 IF(KFLR.GT.0) THEN
26490 ICHANN=2
26491 ELSE
26492 ICHANN=3
26493 ENDIF
26494 IF(I.LE.7) THEN
26495 AA2=0
26496 VA2=0
26497C...a2_tc+ -> gamma + W+.
26498 IF(I.EQ.1) THEN
26499 AA2=RTCM(3)**2/RTCM(49)**2
26500 WID2=WIDS(24,ICHANN)
26501C...a2_tc+ -> gamma + pi_tc+.
26502 ELSEIF(I.EQ.2) THEN
26503 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
26504 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
26505C...a2_tc+ -> W+ + Z
26506 ELSEIF(I.EQ.3) THEN
26507 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
26508 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
26509 WID2=WIDS(24,ICHANN)*WIDS(23,2)
26510C...a2_tc+ -> W+ + pi_tc0.
26511 ELSEIF(I.EQ.4) THEN
26512 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26513 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
26514C...a2_tc+ -> W+ + pi_tc'0.
26515 ELSEIF(I.EQ.5) THEN
26516 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
26517 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
26518C...a2_tc+ -> Z0 + pi_tc+.
26519 ELSEIF(I.EQ.6) THEN
26520 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
26521 & RTCM(49)**2
26522 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
26523 ENDIF
26524 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26525 & /3D0*SHR**3
26526 ELSEIF(I.LE.10) THEN
26527 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26528 FACPA=PCM**2*(1D0+RM1+RM2)
26529 VA2=0D0
26530 AA2=0D0
26531C...a2_tc+ -> gamma + rho_tc+
26532 IF(I.EQ.7) THEN
26533 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26534 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
26535C...a2_tc+ -> W+ + rho_T^0
26536 ELSEIF(I.EQ.8) THEN
26537 AA2=1D0/(4D0*XW)/RTCM(51)**4
26538 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
26539C...a2_tc+ -> W+ + omega_T
26540 ELSEIF(I.EQ.9) THEN
26541 VA2=.25D0/XW/RTCM(50)**4
26542 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
26543C...a2_tc+ -> Z^0 + rho_T^+
26544 ELSEIF(I.EQ.10) THEN
26545 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26546 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
26547 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
26548 ENDIF
26549 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26550 ELSE
26551C...a2_tc+ -> f + fbar'.
26552 IA=I-10
26553 WID2=1D0
26554 IF(IA.LE.16) THEN
26555 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26556 IF(KFLR.GT.0) THEN
26557 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26558 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26559 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26560 ELSE
26561 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26562 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26563 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26564 ENDIF
26565 ELSE
26566 FCOF=1D0
26567 IF(KFLR.GT.0) THEN
26568 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26569 ELSE
26570 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26571 ENDIF
26572 ENDIF
26573 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26574 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26575 ENDIF
26576 WDTP(I)=FUDGE*WDTP(I)
26577 WDTP(0)=WDTP(0)+WDTP(I)
26578 IF(MDME(IDC,1).GT.0) THEN
26579 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26580 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26581 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26582 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26583 ENDIF
26584 540 CONTINUE
26585
26586 ENDIF
26587 MINT(61)=0
26588 MINT(62)=0
26589 MINT(63)=0
26590 RETURN
26591 END
26592
26593C***********************************************************************
26594
26595C...PYOFSH
26596C...Calculates partial width and differential cross-section maxima
26597C...of channels/processes not allowed on mass-shell, and selects
26598C...masses in such channels/processes.
26599
26600 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
26601
26602C...Double precision and integer declarations.
26603 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26604 IMPLICIT INTEGER(I-N)
26605 INTEGER PYK,PYCHGE,PYCOMP
26606C...Commonblocks.
26607 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26608 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26609 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26610 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26611 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26612 COMMON/PYINT1/MINT(400),VINT(400)
26613 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26614 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
26615 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
26616 &/PYINT2/,/PYINT5/
26617C...Local arrays.
26618 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
26619 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
26620 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
26621 &WDTE(0:400,0:5)
26622
26623C...Find if particles equal, maximum mass, matrix elements, etc.
26624 MINT(51)=0
26625 ISUB=MINT(1)
26626 KFD(1)=IABS(KFD1)
26627 KFD(2)=IABS(KFD2)
26628 MEQL=0
26629 IF(KFD(1).EQ.KFD(2)) MEQL=1
26630 MLM=0
26631 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
26632 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
26633 NOFF=44
26634 PMMX=PMMO
26635 ELSE
26636 NOFF=40
26637 PMMX=VINT(1)
26638 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
26639 ENDIF
26640 MMED=0
26641 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
26642 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
26643 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
26644 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
26645 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
26646 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
26647 LOOP=1
26648
26649C...Find where Breit-Wigners are required, else select discrete masses.
26650 100 DO 110 I=1,2
26651 KFCA=PYCOMP(KFD(I))
26652 IF(KFCA.GT.0) THEN
26653 PMD(I)=PMAS(KFCA,1)
26654 PGD(I)=PMAS(KFCA,2)
26655 ELSE
26656 PMD(I)=0D0
26657 PGD(I)=0D0
26658 ENDIF
26659 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
26660 MBW(I)=0
26661 PMG(I)=PMD(I)
26662 RMG(I)=(PMG(I)/PMMX)**2
26663 ELSE
26664 MBW(I)=1
26665 ENDIF
26666 110 CONTINUE
26667
26668C...Find allowed mass range and Breit-Wigner parameters.
26669 DO 120 I=1,2
26670 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
26671 PML(I)=PARP(42)
26672 PMU(I)=PMMX-PARP(42)
26673 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26674 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26675 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
26676 ILM=I
26677 IF(MLM.EQ.2) ILM=3-I
26678 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
26679 IF(MBW(3-I).EQ.0) THEN
26680 PMU(I)=PMMX-PMD(3-I)
26681 ELSE
26682 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
26683 ENDIF
26684 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
26685 & MIN(PMU(I),CKIN(NOFF+2*ILM))
26686 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26687 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26688 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26689 IF(MBW(I).EQ.1) THEN
26690 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26691 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26692 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26693 & PGD(I)))
26694 ENDIF
26695 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
26696 ILM=I
26697 IF(MLM.EQ.2) ILM=3-I
26698 PML(I)=MAX(CKIN(48+I),PARP(42))
26699 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
26700 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26701 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26702 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26703 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26704 IF(MBW(I).EQ.1) THEN
26705 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26706 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26707 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26708 & PGD(I)))
26709 ENDIF
26710 ENDIF
26711 120 CONTINUE
26712 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
26713 &THEN
26714 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
26715 MINT(51)=1
26716 RETURN
26717 ENDIF
26718
26719C...Calculation of partial width of resonance.
26720 IF(MOFSH.EQ.1) THEN
26721
26722C..If only one integration, pick that to be the inner.
26723 IF(MBW(1).EQ.0) THEN
26724 PM2=PMD(1)
26725 PMD(1)=PMD(2)
26726 PGD(1)=PGD(2)
26727 PML(1)=PML(2)
26728 PMU(1)=PMU(2)
26729 ELSEIF(MBW(2).EQ.0) THEN
26730 PM2=PMD(2)
26731 ENDIF
26732
26733C...Start outer loop of integration.
26734 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26735 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26736 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26737 NPT2=1
26738 XPT2(1)=1D0
26739 INX2(1)=0
26740 FMAX2=0D0
26741 ENDIF
26742 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26743 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
26744 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
26745 ENDIF
26746 RM2=(PM2/PMMX)**2
26747
26748C...Start inner loop of integration.
26749 PML1=PML(1)
26750 PMU1=MIN(PMU(1),PMMX-PM2)
26751 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
26752 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26753 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26754 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
26755 FUNC2=0D0
26756 GOTO 180
26757 ENDIF
26758 NPT1=1
26759 XPT1(1)=1D0
26760 INX1(1)=0
26761 FMAX1=0D0
26762 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
26763 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
26764 RM1=(PM1/PMMX)**2
26765
26766C...Evaluate function value - inner loop.
26767 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26768 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
26769 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
26770 & RM2**2+10D0*RM1*RM2)
26771 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
26772 FPT1(NPT1)=FUNC1
26773
26774C...Go to next position in inner loop.
26775 IF(NPT1.EQ.1) THEN
26776 NPT1=NPT1+1
26777 XPT1(NPT1)=0D0
26778 INX1(NPT1)=1
26779 GOTO 140
26780 ELSEIF(NPT1.LE.8) THEN
26781 NPT1=NPT1+1
26782 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
26783 ISH1=ISH1+1
26784 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26785 INX1(NPT1)=INX1(ISH1)
26786 INX1(ISH1)=NPT1
26787 GOTO 140
26788 ELSEIF(NPT1.LT.100) THEN
26789 ISN1=ISH1
26790 150 ISH1=ISH1+1
26791 IF(ISH1.GT.NPT1) ISH1=2
26792 IF(ISH1.EQ.ISN1) GOTO 160
26793 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
26794 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
26795 NPT1=NPT1+1
26796 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26797 INX1(NPT1)=INX1(ISH1)
26798 INX1(ISH1)=NPT1
26799 GOTO 140
26800 ENDIF
26801
26802C...Calculate integral over inner loop.
26803 160 FSUM1=0D0
26804 DO 170 IPT1=2,NPT1
26805 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
26806 & (XPT1(INX1(IPT1))-XPT1(IPT1))
26807 170 CONTINUE
26808 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
26809 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26810 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
26811 FPT2(NPT2)=FUNC2
26812
26813C...Go to next position in outer loop.
26814 IF(NPT2.EQ.1) THEN
26815 NPT2=NPT2+1
26816 XPT2(NPT2)=0D0
26817 INX2(NPT2)=1
26818 GOTO 130
26819 ELSEIF(NPT2.LE.8) THEN
26820 NPT2=NPT2+1
26821 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
26822 ISH2=ISH2+1
26823 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26824 INX2(NPT2)=INX2(ISH2)
26825 INX2(ISH2)=NPT2
26826 GOTO 130
26827 ELSEIF(NPT2.LT.100) THEN
26828 ISN2=ISH2
26829 190 ISH2=ISH2+1
26830 IF(ISH2.GT.NPT2) ISH2=2
26831 IF(ISH2.EQ.ISN2) GOTO 200
26832 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
26833 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
26834 NPT2=NPT2+1
26835 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26836 INX2(NPT2)=INX2(ISH2)
26837 INX2(ISH2)=NPT2
26838 GOTO 130
26839 ENDIF
26840
26841C...Calculate integral over outer loop.
26842 200 FSUM2=0D0
26843 DO 210 IPT2=2,NPT2
26844 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
26845 & (XPT2(INX2(IPT2))-XPT2(IPT2))
26846 210 CONTINUE
26847 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
26848 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
26849 ELSE
26850 FSUM2=FUNC2
26851 ENDIF
26852
26853C...Save result; second integration for user-selected mass range.
26854 IF(LOOP.EQ.1) WIDW=FSUM2
26855 WID2=FSUM2
26856 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
26857 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
26858 LOOP=2
26859 GOTO 100
26860 ENDIF
26861 RET1=WIDW
26862 RET2=WID2/WIDW
26863
26864C...Select two decay product masses of a resonance.
26865 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
26866 220 DO 230 I=1,2
26867 IF(MBW(I).EQ.0) GOTO 230
26868 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
26869 & (ATU(I)-ATL(I)))
26870 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
26871 RMG(I)=(PMG(I)/PMMX)**2
26872 230 CONTINUE
26873 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26874 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
26875
26876C...Weight with matrix element (if none known, use beta factor).
26877 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26878 IF(MMED.EQ.1) THEN
26879 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26880 ELSEIF(MMED.EQ.2) THEN
26881 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26882 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26883 ELSEIF(MMED.EQ.3) THEN
26884 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26885 ELSE
26886 WTBE=FLAM
26887 ENDIF
26888 IF(WTBE.LT.PYR(0)) GOTO 220
26889 RET1=PMG(1)
26890 RET2=PMG(2)
26891
26892C...Find suitable set of masses for initialization of 2 -> 2 processes.
26893 ELSEIF(MOFSH.EQ.3) THEN
26894 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26895 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26896 PMG(2)=PMD(2)
26897 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26898 PMG(1)=PMD(1)
26899 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26900 ELSE
26901 IDIV=-1
26902 240 IDIV=IDIV+1
26903 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26904 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26905 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26906 ENDIF
26907 RET1=PMG(1)
26908 RET2=PMG(2)
26909
26910C...Evaluate importance of excluded tails of Breit-Wigners.
26911 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26912 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26913 IF(MEQL.LE.1) THEN
26914 VINT(80)=1D0
26915 DO 250 I=1,2
26916 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26917 & PARU(1)
26918 250 CONTINUE
26919 ELSE
26920 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26921 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26922 ENDIF
26923 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26924 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26925 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26926 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26927
26928C...Pick one particle to be the lighter (if improves efficiency).
26929 ELSEIF(MOFSH.EQ.4) THEN
26930 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26931 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26932 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26933
26934C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26935 DO 270 I=1,2
26936 IF(MBW(I).EQ.0) GOTO 270
26937 PMV=PMU(I)
26938 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26939 ATV=ATU(I)
26940 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26941 RBR=PYR(0)
26942 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26943 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26944 IF(RBR.LT.0.8D0) THEN
26945 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26946 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26947 ELSEIF(RBR.LT.0.9D0) THEN
26948 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26949 ELSEIF(RBR.LT.1.5D0) THEN
26950 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26951 ELSE
26952 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26953 & (PMV**2-PML(I)**2))))
26954 ENDIF
26955 270 CONTINUE
26956 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26957 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26958 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26959 NGEN(0,1)=NGEN(0,1)+1
26960 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26961 GOTO 260
26962 ELSE
26963 MINT(51)=1
26964 RETURN
26965 ENDIF
26966 ENDIF
26967 RET1=PMG(1)
26968 RET2=PMG(2)
26969
26970C...Give weight for selected mass distribution.
26971 VINT(80)=1D0
26972 DO 280 I=1,2
26973 IF(MBW(I).EQ.0) GOTO 280
26974 PMV=PMU(I)
26975 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26976 ATV=ATU(I)
26977 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26978 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26979 & (PMD(I)*PGD(I))**2)/PARU(1)
26980 F1=1D0
26981 F2=1D0/PMG(I)**2
26982 F3=1D0/PMG(I)**4
26983 FI0=(ATV-ATL(I))/PARU(1)
26984 FI1=PMV**2-PML(I)**2
26985 FI2=2D0*LOG(PMV/PML(I))
26986 FI3=1D0/PML(I)**2-1D0/PMV**2
26987 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26988 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
26989 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
26990 & 5D0*F3/FI3))
26991 ELSE
26992 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
26993 ENDIF
26994 VINT(80)=VINT(80)*FI0
26995 280 CONTINUE
26996 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26997 ENDIF
26998
26999 RETURN
27000 END
27001
27002C***********************************************************************
27003
27004C...PYRECO
27005C...Handles the possibility of colour reconnection in W+W- events,
27006C...Based on the main scenarios of the Sjostrand and Khoze study:
27007C...I, II, II', intermediate and instantaneous; plus one model
27008C...along the lines of the Gustafson and Hakkinen: GH.
27009C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27010C...is as if first resonance is W+ and second W-.
27011
27012 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27013
27014C...Double precision and integer declarations.
27015 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27016 IMPLICIT INTEGER(I-N)
27017 INTEGER PYK,PYCHGE,PYCOMP
27018C...Parameter value; number of points in MC integration.
27019 PARAMETER (NPT=100)
27020C...Commonblocks.
27021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27025 COMMON/PYINT1/MINT(400),VINT(400)
27026 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27027C...Local arrays.
27028 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27029 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27030 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27031 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27032 &TMC(20),IJOIN(100)
27033
27034C...Functions to give four-product and to do determinants.
27035 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)
27036 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27037 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27038 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27039
27040C...Only allow fraction of recoupling for GH, intermediate and
27041C...instantaneous.
27042 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27043 IF(PYR(0).GT.PARP(120)) RETURN
27044 ENDIF
27045 ISUB=MINT(1)
27046
27047C...Common part for scenarios I, II, II', and GH.
27048 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27049 &MSTP(115).EQ.5) THEN
27050
27051C...Read out frequently-used parameters.
27052 PI=PARU(1)
27053 HBAR=PARU(3)
27054 PMW=PMAS(24,1)
27055 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27056 PGW=PMAS(24,2)
27057 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27058 TFRAG=PARP(115)
27059 RHAD=PARP(116)
27060 FACT=PARP(117)
27061 BLOWR=PARP(118)
27062 BLOWT=PARP(119)
27063
27064C...Find range of decay products of the W's.
27065C...Background: the W's are stored in IW1 and IW2.
27066C...Their direct decay products in NSD1+1 through NSD1+4.
27067C...Products after shower (if any) in NSD1+5 through NAFT1
27068C...for first W and in NAFT1+1 through N for the second.
27069 IF(NAFT1.GT.NSD1+4) THEN
27070 NBEG(1)=NSD1+5
27071 NEND(1)=NAFT1
27072 ELSE
27073 NBEG(1)=NSD1+1
27074 NEND(1)=NSD1+2
27075 ENDIF
27076 IF(N.GT.NAFT1) THEN
27077 NBEG(2)=NAFT1+1
27078 NEND(2)=N
27079 ELSE
27080 NBEG(2)=NSD1+3
27081 NEND(2)=NSD1+4
27082 ENDIF
27083
27084C...Rearrange parton shower products along strings.
27085 NOLD=N
27086 CALL PYPREP(NSD1+1)
27087 IF(MINT(51).NE.0) RETURN
27088
27089C...Find partons pointing back to W+ and W-; store them with quark
27090C...end of string first.
27091 NNP=0
27092 NNM=0
27093 ISGP=0
27094 ISGM=0
27095 DO 120 I=NOLD+1,N
27096 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27097 IF(IABS(K(I,2)).GE.22) GOTO 120
27098 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27099 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27100 NNP=NNP+1
27101 IF(ISGP.EQ.1) THEN
27102 INP(NNP)=I
27103 ELSE
27104 DO 100 I1=NNP,2,-1
27105 INP(I1)=INP(I1-1)
27106 100 CONTINUE
27107 INP(1)=I
27108 ENDIF
27109 IF(K(I,1).EQ.1) ISGP=0
27110 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27111 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27112 NNM=NNM+1
27113 IF(ISGM.EQ.1) THEN
27114 INM(NNM)=I
27115 ELSE
27116 DO 110 I1=NNM,2,-1
27117 INM(I1)=INM(I1-1)
27118 110 CONTINUE
27119 INM(1)=I
27120 ENDIF
27121 IF(K(I,1).EQ.1) ISGM=0
27122 ENDIF
27123 120 CONTINUE
27124
27125C...Boost to W+W- rest frame (not strictly needed).
27126 DO 130 J=1,3
27127 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27128 130 CONTINUE
27129 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27130 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27131 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27132
27133C...Select decay vertices of W+ and W-.
27134 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27135 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27136 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27137 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
27138 GTMAX=MAX(TP,TM)
27139 DO 140 J=1,3
27140 XP(J)=TP*P(IW1,J)/P(IW1,4)
27141 XM(J)=TM*P(IW2,J)/P(IW2,4)
27142 140 CONTINUE
27143
27144C...Begin scenario I specifics.
27145 IF(MSTP(115).EQ.1) THEN
27146
27147C...Reconstruct velocity and direction of W+ string pieces.
27148 DO 170 IIP=1,NNP-1
27149 IF(K(INP(IIP),2).LT.0) GOTO 170
27150 I1=INP(IIP)
27151 I2=INP(IIP+1)
27152 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27153 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27154 DO 150 J=1,3
27155 V1(J)=P(I1,J)/P1A
27156 V2(J)=P(I2,J)/P2A
27157 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
27158 DIRP(IIP,J)=V1(J)-V2(J)
27159 150 CONTINUE
27160 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
27161 & BETP(IIP,3)**2)
27162 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
27163 DO 160 J=1,3
27164 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
27165 160 CONTINUE
27166 170 CONTINUE
27167
27168C...Reconstruct velocity and direction of W- string pieces.
27169 DO 200 IIM=1,NNM-1
27170 IF(K(INM(IIM),2).LT.0) GOTO 200
27171 I1=INM(IIM)
27172 I2=INM(IIM+1)
27173 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27174 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27175 DO 180 J=1,3
27176 V1(J)=P(I1,J)/P1A
27177 V2(J)=P(I2,J)/P2A
27178 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
27179 DIRM(IIM,J)=V1(J)-V2(J)
27180 180 CONTINUE
27181 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
27182 & BETM(IIM,3)**2)
27183 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
27184 DO 190 J=1,3
27185 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
27186 190 CONTINUE
27187 200 CONTINUE
27188
27189C...Loop over number of space-time points.
27190 NACC=0
27191 SUM=0D0
27192 DO 250 IPT=1,NPT
27193
27194C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27195 R=SQRT(-LOG(PYR(0)))
27196 PHI=2D0*PI*PYR(0)
27197 X=BLOWR*RHAD*R*COS(PHI)
27198 Y=BLOWR*RHAD*R*SIN(PHI)
27199 R=SQRT(-LOG(PYR(0)))
27200 PHI=2D0*PI*PYR(0)
27201 Z=BLOWR*RHAD*R*COS(PHI)
27202 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
27203
27204C...Reject impossible points. Weight for sample distribution.
27205 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
27206 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
27207 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
27208
27209C...Loop over W+ string pieces and find one with largest weight.
27210 IMAXP=0
27211 WTMAXP=1D-10
27212 XD(1)=X-XP(1)
27213 XD(2)=Y-XP(2)
27214 XD(3)=Z-XP(3)
27215 XD(4)=T-TP
27216 DO 220 IIP=1,NNP-1
27217 IF(K(INP(IIP),2).LT.0) GOTO 220
27218 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
27219 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
27220 DO 210 J=1,3
27221 XB(J)=XD(J)+BEDG*BETP(IIP,J)
27222 210 CONTINUE
27223 XB(4)=BETP(IIP,4)*(XD(4)-BED)
27224 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27225 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
27226 & DIRP(IIP,3)*XB(3))**2
27227 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27228 & TFRAG**2)
27229 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
27230 IF(WTP.GT.WTMAXP) THEN
27231 IMAXP=IIP
27232 WTMAXP=WTP
27233 ENDIF
27234 220 CONTINUE
27235
27236C...Loop over W- string pieces and find one with largest weight.
27237 IMAXM=0
27238 WTMAXM=1D-10
27239 XD(1)=X-XM(1)
27240 XD(2)=Y-XM(2)
27241 XD(3)=Z-XM(3)
27242 XD(4)=T-TM
27243 DO 240 IIM=1,NNM-1
27244 IF(K(INM(IIM),2).LT.0) GOTO 240
27245 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
27246 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
27247 DO 230 J=1,3
27248 XB(J)=XD(J)+BEDG*BETM(IIM,J)
27249 230 CONTINUE
27250 XB(4)=BETM(IIM,4)*(XD(4)-BED)
27251 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27252 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
27253 & DIRM(IIM,3)*XB(3))**2
27254 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27255 & TFRAG**2)
27256 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
27257 IF(WTM.GT.WTMAXM) THEN
27258 IMAXM=IIM
27259 WTMAXM=WTM
27260 ENDIF
27261 240 CONTINUE
27262
27263C...Result of integration.
27264 WT=0D0
27265 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
27266 WT=WTMAXP*WTMAXM/WTSMP
27267 SUM=SUM+WT
27268 NACC=NACC+1
27269 IAP(NACC)=IMAXP
27270 IAM(NACC)=IMAXM
27271 WTA(NACC)=WT
27272 ENDIF
27273 250 CONTINUE
27274 RES=BLOWR**3*BLOWT*SUM/NPT
27275
27276C...Decide whether to reconnect and, if so, where.
27277 IACC=0
27278 PREC=1D0-EXP(-FACT*RES)
27279 IF(PREC.GT.PYR(0)) THEN
27280 RSUM=PYR(0)*SUM
27281 DO 260 IA=1,NACC
27282 IACC=IA
27283 RSUM=RSUM-WTA(IA)
27284 IF(RSUM.LE.0D0) GOTO 270
27285 260 CONTINUE
27286 270 IIP=IAP(IACC)
27287 IIM=IAM(IACC)
27288 ENDIF
27289
27290C...Begin scenario II and II' specifics.
27291 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
27292
27293C...Loop through all string pieces, one from W+ and one from W-.
27294 NCROSS=0
27295 TC(0)=0D0
27296 DO 340 IIP=1,NNP-1
27297 IF(K(INP(IIP),2).LT.0) GOTO 340
27298 I1P=INP(IIP)
27299 I2P=INP(IIP+1)
27300 DO 330 IIM=1,NNM-1
27301 IF(K(INM(IIM),2).LT.0) GOTO 330
27302 I1M=INM(IIM)
27303 I2M=INM(IIM+1)
27304
27305C...Find endpoint velocity vectors.
27306 DO 280 J=1,3
27307 V1P(J)=P(I1P,J)/P(I1P,4)
27308 V2P(J)=P(I2P,J)/P(I2P,4)
27309 V1M(J)=P(I1M,J)/P(I1M,4)
27310 V2M(J)=P(I2M,J)/P(I2M,4)
27311 280 CONTINUE
27312
27313C...Define q matrix and find t.
27314 DO 290 J=1,3
27315 Q(1,J)=V2P(J)-V1P(J)
27316 Q(2,J)=-(V2M(J)-V1M(J))
27317 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
27318 Q(4,J)=V1P(J)-V1M(J)
27319 290 CONTINUE
27320 T=-DETER(1,2,3)/DETER(1,2,4)
27321
27322C...Find alpha and beta; i.e. coordinates of crossing point.
27323 S11=Q(1,1)*(T-TP)
27324 S12=Q(2,1)*(T-TM)
27325 S13=Q(3,1)+Q(4,1)*T
27326 S21=Q(1,2)*(T-TP)
27327 S22=Q(2,2)*(T-TM)
27328 S23=Q(3,2)+Q(4,2)*T
27329 DEN=S11*S22-S12*S21
27330 ALP=(S12*S23-S22*S13)/DEN
27331 BET=(S21*S13-S11*S23)/DEN
27332
27333C...Check if solution acceptable.
27334 IANSW=1
27335 IF(T.LT.GTMAX) IANSW=0
27336 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
27337 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
27338
27339C...Find point of crossing and check that not inconsistent.
27340 DO 300 J=1,3
27341 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
27342 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
27343 300 CONTINUE
27344 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
27345 & (XPP(3)-XMM(3))**2
27346 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
27347 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
27348 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
27349
27350C...Find string eigentimes at crossing.
27351 IF(IANSW.EQ.1) THEN
27352 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
27353 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
27354 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
27355 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
27356 ELSE
27357 TAUP=0D0
27358 TAUM=0D0
27359 ENDIF
27360
27361C...Order crossings by time. End loop over crossings.
27362 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
27363 NCROSS=NCROSS+1
27364 DO 310 I1=NCROSS,1,-1
27365 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
27366 IPC(I1)=IIP
27367 IMC(I1)=IIM
27368 TC(I1)=T
27369 TPC(I1)=TAUP
27370 TMC(I1)=TAUM
27371 GOTO 320
27372 ELSE
27373 IPC(I1)=IPC(I1-1)
27374 IMC(I1)=IMC(I1-1)
27375 TC(I1)=TC(I1-1)
27376 TPC(I1)=TPC(I1-1)
27377 TMC(I1)=TMC(I1-1)
27378 ENDIF
27379 310 CONTINUE
27380 320 CONTINUE
27381 ENDIF
27382 330 CONTINUE
27383 340 CONTINUE
27384
27385C...Loop over crossings; find first (if any) acceptable one.
27386 IACC=0
27387 IF(NCROSS.GE.1) THEN
27388 DO 350 IC=1,NCROSS
27389 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
27390 IF(PNFRAG.GT.PYR(0)) THEN
27391C...Scenario II: only compare with fragmentation time.
27392 IF(MSTP(115).EQ.2) THEN
27393 IACC=IC
27394 IIP=IPC(IACC)
27395 IIM=IMC(IACC)
27396 GOTO 360
27397C...Scenario II': also require that string length decreases.
27398 ELSE
27399 IIP=IPC(IC)
27400 IIM=IMC(IC)
27401 I1P=INP(IIP)
27402 I2P=INP(IIP+1)
27403 I1M=INM(IIM)
27404 I2M=INM(IIM+1)
27405 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27406 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27407 IF(ELNEW.LT.ELOLD) THEN
27408 IACC=IC
27409 IIP=IPC(IACC)
27410 IIM=IMC(IACC)
27411 GOTO 360
27412 ENDIF
27413 ENDIF
27414 ENDIF
27415 350 CONTINUE
27416 360 CONTINUE
27417 ENDIF
27418
27419C...Begin scenario GH specifics.
27420 ELSEIF(MSTP(115).EQ.5) THEN
27421
27422C...Loop through all string pieces, one from W+ and one from W-.
27423 IACC=0
27424 ELMIN=1D0
27425 DO 380 IIP=1,NNP-1
27426 IF(K(INP(IIP),2).LT.0) GOTO 380
27427 I1P=INP(IIP)
27428 I2P=INP(IIP+1)
27429 DO 370 IIM=1,NNM-1
27430 IF(K(INM(IIM),2).LT.0) GOTO 370
27431 I1M=INM(IIM)
27432 I2M=INM(IIM+1)
27433
27434C...Look for largest decrease of (exponent of) Lambda measure.
27435 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27436 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27437 ELDIF=ELNEW/MAX(1D-10,ELOLD)
27438 IF(ELDIF.LT.ELMIN) THEN
27439 IACC=IIP+IIM
27440 ELMIN=ELDIF
27441 IPC(1)=IIP
27442 IMC(1)=IIM
27443 ENDIF
27444 370 CONTINUE
27445 380 CONTINUE
27446 IIP=IPC(1)
27447 IIM=IMC(1)
27448 ENDIF
27449
27450C...Common for scenarios I, II, II' and GH: reconnect strings.
27451 IF(IACC.NE.0) THEN
27452 MINT(32)=1
27453 NJOIN=0
27454 DO 390 IS=1,NNP+NNM
27455 NJOIN=NJOIN+1
27456 IF(IS.LE.IIP) THEN
27457 I=INP(IS)
27458 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
27459 I=INM(IS-IIP+IIM)
27460 ELSEIF(IS.LE.IIP+NNM) THEN
27461 I=INM(IS-IIP-NNM+IIM)
27462 ELSE
27463 I=INP(IS-NNM)
27464 ENDIF
27465 IJOIN(NJOIN)=I
27466 IF(K(I,2).LT.0) THEN
27467 CALL PYJOIN(NJOIN,IJOIN)
27468 NJOIN=0
27469 ENDIF
27470 390 CONTINUE
27471
27472C...Restore original event record if no reconnection.
27473 ELSE
27474 DO 400 I=NSD1+1,NOLD
27475 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
27476 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27477 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27478 ENDIF
27479 400 CONTINUE
27480 DO 410 I=NOLD+1,N
27481 K(K(I,3),1)=3
27482 410 CONTINUE
27483 N=NOLD
27484 ENDIF
27485
27486C...Boost back system.
27487 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27488 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27489 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
27490 & BEWW(1),BEWW(2),BEWW(3))
27491
27492C...Common part for intermediate and instantaneous scenarios.
27493 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27494 MINT(32)=1
27495
27496C...Remove old shower products and reset showering ones.
27497 N=NSD1+4
27498 DO 420 I=NSD1+1,NSD1+4
27499 K(I,1)=3
27500 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27501 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27502 420 CONTINUE
27503
27504C...Identify quark-antiquark pairs.
27505 IQ1=NSD1+1
27506 IQ2=NSD1+2
27507 IQ3=NSD1+3
27508 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
27509 IQ4=2*NSD1+7-IQ3
27510
27511C...Reconnect strings.
27512 IJOIN(1)=IQ1
27513 IJOIN(2)=IQ4
27514 CALL PYJOIN(2,IJOIN)
27515 IJOIN(1)=IQ3
27516 IJOIN(2)=IQ2
27517 CALL PYJOIN(2,IJOIN)
27518
27519C...Do new parton showers in intermediate scenario.
27520 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
27521 MSTJ50=MSTJ(50)
27522 MSTJ(50)=0
27523 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
27524 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
27525 MSTJ(50)=MSTJ50
27526
27527C...Do new parton showers in instantaneous scenario.
27528 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
27529 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
27530 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
27531 PPM=SQRT(MAX(0D0,PPM2))
27532 CALL PYSHOW(IQ1,IQ4,PPM)
27533 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
27534 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
27535 PPM=SQRT(MAX(0D0,PPM2))
27536 CALL PYSHOW(IQ3,IQ2,PPM)
27537 ENDIF
27538 ENDIF
27539
27540 RETURN
27541 END
27542
27543C***********************************************************************
27544
27545C...PYKLIM
27546C...Checks generated variables against pre-set kinematical limits;
27547C...also calculates limits on variables used in generation.
27548
27549 SUBROUTINE PYKLIM(ILIM)
27550
27551C...Double precision and integer declarations.
27552 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27553 IMPLICIT INTEGER(I-N)
27554 INTEGER PYK,PYCHGE,PYCOMP
27555C...Commonblocks.
27556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27560 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27562 COMMON/PYINT1/MINT(400),VINT(400)
27563 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27564 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27565 &/PYINT1/,/PYINT2/
27566
27567C...Common kinematical expressions.
27568 MINT(51)=0
27569 ISUB=MINT(1)
27570 ISTSB=ISET(ISUB)
27571 IF(ISUB.EQ.96) GOTO 100
27572 SQM3=VINT(63)
27573 SQM4=VINT(64)
27574 IF(ILIM.NE.0) THEN
27575 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
27576 CKIN09=MAX(CKIN(9),CKIN(13))
27577 CKIN10=MIN(CKIN(10),CKIN(14))
27578 CKIN11=MAX(CKIN(11),CKIN(15))
27579 CKIN12=MIN(CKIN(12),CKIN(16))
27580 ELSE
27581 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
27582 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
27583 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
27584 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
27585 ENDIF
27586 ENDIF
27587 IF(ILIM.NE.1) THEN
27588 TAU=VINT(21)
27589 RM3=SQM3/(TAU*VINT(2))
27590 RM4=SQM4/(TAU*VINT(2))
27591 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27592 ENDIF
27593 PTHMIN=CKIN(3)
27594 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
27595 &PTHMIN=MAX(CKIN(3),CKIN(5))
27596
27597 IF(ILIM.EQ.0) THEN
27598C...Check generated values of tau, y*, cos(theta-hat), and tau' against
27599C...pre-set kinematical limits.
27600 YST=VINT(22)
27601 CTH=VINT(23)
27602 TAUP=VINT(26)
27603 TAUE=TAU
27604 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27605 X1=SQRT(TAUE)*EXP(YST)
27606 X2=SQRT(TAUE)*EXP(-YST)
27607 XF=X1-X2
27608 IF(MINT(47).NE.1) THEN
27609 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
27610 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
27611 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
27612 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
27613 ENDIF
27614 IF(MINT(45).NE.1) THEN
27615 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
27616 ENDIF
27617 IF(MINT(46).NE.1) THEN
27618 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
27619 ENDIF
27620 IF(MINT(45).EQ.2) THEN
27621 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27622 ENDIF
27623 IF(MINT(46).EQ.2) THEN
27624 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27625 ENDIF
27626 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
27627 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
27628 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
27629 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
27630 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
27631 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
27632 Y3=YST+0.5D0*LOG(EXPY3)
27633 Y4=YST+0.5D0*LOG(EXPY4)
27634 YLARGE=MAX(Y3,Y4)
27635 YSMALL=MIN(Y3,Y4)
27636 ETALAR=20D0
27637 ETASMA=-20D0
27638 STH=SQRT(MAX(0D0,1D0-CTH**2))
27639 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
27640 & CTH)**2-4D0*RM3))
27641 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
27642 & CTH)**2-4D0*RM4))
27643 IF(STH.GE.1D-10) THEN
27644 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
27645 & (BE34*STH)
27646 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
27647 & (BE34*STH)
27648 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
27649 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
27650 ETALAR=MAX(ETA3,ETA4)
27651 ETASMA=MIN(ETA3,ETA4)
27652 ENDIF
27653 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
27654 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
27655 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
27656 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
27657 SH=TAU*VINT(2)
27658 RPTS=4D0*VINT(71)**2/SH
27659 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27660 RM34=MAX(1D-20,2D0*RM3*RM4)
27661 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27662 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27663 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27664 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
27665 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27666 IF(PTH.LT.PTHMIN) MINT(51)=1
27667 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
27668 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
27669 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
27670 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
27671 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
27672 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
27673 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
27674 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
27675 IF(THA.LT.CKIN(35)) MINT(51)=1
27676 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
27677 IF(UHA.LT.CKIN(37)) MINT(51)=1
27678 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
27679 ENDIF
27680 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27681 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
27682 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
27683 ENDIF
27684
27685C...Additional cuts on W2 (approximately) in DIS.
27686 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
27687 XBJ=X2
27688 IF(IABS(MINT(12)).LT.20) XBJ=X1
27689 Q2BJ=THA
27690 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
27691 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
27692 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
27693 ENDIF
27694
27695 ELSEIF(ILIM.EQ.1) THEN
27696C...Calculate limits on tau
27697C...0) due to definition
27698 TAUMN0=0D0
27699 TAUMX0=1D0
27700C...1) due to limits on subsystem mass
27701 TAUMN1=CKIN(1)**2/VINT(2)
27702 TAUMX1=1D0
27703 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
27704C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
27705 TM3=SQRT(SQM3+PTHMIN**2)
27706 TM4=SQRT(SQM4+PTHMIN**2)
27707 YDCOSH=1D0
27708 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
27709 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
27710 TAUMX2=1D0
27711C...3) due to limits on pT-hat and cos(theta-hat)
27712 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
27713 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
27714 TAUMN3=0D0
27715 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
27716 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
27717 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
27718 TAUMX3=1D0
27719 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
27720 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
27721 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
27722C...4) due to limits on x1 and x2
27723 TAUMN4=CKIN(21)*CKIN(23)
27724 TAUMX4=CKIN(22)*CKIN(24)
27725C...5) due to limits on xF
27726 TAUMN5=0D0
27727 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
27728C...6) due to limits on that and uhat
27729 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
27730 TAUMX6=1D0
27731 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
27732 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
27733
27734C...Net effect of all separate limits.
27735 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
27736 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
27737 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27738 VINT(11)=1D0-1D-9
27739 VINT(31)=1D0+1D-9
27740 ELSEIF(MINT(47).EQ.5) THEN
27741 VINT(31)=MIN(VINT(31),1D0-2D-10)
27742 ELSEIF(MINT(47).GE.6) THEN
27743 VINT(31)=MIN(VINT(31),1D0-1D-10)
27744 ENDIF
27745 IF(VINT(31).LE.VINT(11)) MINT(51)=1
27746
27747 ELSEIF(ILIM.EQ.2) THEN
27748C...Calculate limits on y*
27749 TAUE=TAU
27750 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27751 TAURT=SQRT(TAUE)
27752C...0) due to kinematics
27753 YSTMN0=LOG(TAURT)
27754 YSTMX0=-YSTMN0
27755C...1) due to explicit limits
27756 YSTMN1=CKIN(7)
27757 YSTMX1=CKIN(8)
27758C...2) due to limits on x1
27759 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
27760 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
27761C...3) due to limits on x2
27762 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
27763 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
27764C...4) due to limits on xF
27765 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
27766 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
27767 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
27768 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
27769C...5) due to simultaneous limits on y-large and y-small
27770 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
27771 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
27772 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
27773 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
27774 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
27775 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
27776C...6) due to simultaneous limits on cos(theta-hat) and y-large or
27777C... y-small
27778 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
27779 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
27780 RZMX=BE34*MIN(CKIN(28),CTHLIM)
27781 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
27782 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
27783 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
27784 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
27785 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
27786 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
27787
27788C...Net effect of all separate limits.
27789 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
27790 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
27791 IF(MINT(47).EQ.1) THEN
27792 VINT(12)=-1D-9
27793 VINT(32)=1D-9
27794 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27795 VINT(12)=(1D0-1D-9)*YSTMX0
27796 VINT(32)=(1D0+1D-9)*YSTMX0
27797 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27798 VINT(12)=-(1D0+1D-9)*YSTMX0
27799 VINT(32)=-(1D0-1D-9)*YSTMX0
27800 ELSEIF(MINT(47).EQ.5) THEN
27801 YSTEE=LOG((1D0-1D-10)/TAURT)
27802 VINT(12)=MAX(VINT(12),-YSTEE)
27803 VINT(32)=MIN(VINT(32),YSTEE)
27804 ENDIF
27805 IF(VINT(32).LE.VINT(12)) MINT(51)=1
27806
27807 ELSEIF(ILIM.EQ.3) THEN
27808C...Calculate limits on cos(theta-hat)
27809 YST=VINT(22)
27810C...0) due to definition
27811 CTNMN0=-1D0
27812 CTNMX0=0D0
27813 CTPMN0=0D0
27814 CTPMX0=1D0
27815C...1) due to explicit limits
27816 CTNMN1=MIN(0D0,CKIN(27))
27817 CTNMX1=MIN(0D0,CKIN(28))
27818 CTPMN1=MAX(0D0,CKIN(27))
27819 CTPMX1=MAX(0D0,CKIN(28))
27820C...2) due to limits on pT-hat
27821 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
27822 CTPMX2=-CTNMN2
27823 CTNMX2=0D0
27824 CTPMN2=0D0
27825 IF(CKIN(4).GE.0D0) THEN
27826 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
27827 & (BE34**2*TAU*VINT(2))))
27828 CTPMN2=-CTNMX2
27829 ENDIF
27830C...3) due to limits on y-large and y-small
27831 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
27832 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
27833 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
27834 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
27835 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
27836 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
27837 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
27838 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
27839C...4) due to limits on that
27840 CTNMN4=-1D0
27841 CTNMX4=0D0
27842 CTPMN4=0D0
27843 CTPMX4=1D0
27844 SH=TAU*VINT(2)
27845 IF(CKIN(35).GT.0D0) THEN
27846 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
27847 IF(CTLIM.GT.0D0) THEN
27848 CTPMX4=CTLIM
27849 ELSE
27850 CTPMX4=0D0
27851 CTNMX4=CTLIM
27852 ENDIF
27853 ENDIF
27854 IF(CKIN(36).GT.0D0) THEN
27855 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
27856 IF(CTLIM.LT.0D0) THEN
27857 CTNMN4=CTLIM
27858 ELSE
27859 CTNMN4=0D0
27860 CTPMN4=CTLIM
27861 ENDIF
27862 ENDIF
27863C...5) due to limits on uhat
27864 CTNMN5=-1D0
27865 CTNMX5=0D0
27866 CTPMN5=0D0
27867 CTPMX5=1D0
27868 IF(CKIN(37).GT.0D0) THEN
27869 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
27870 IF(CTLIM.LT.0D0) THEN
27871 CTNMN5=CTLIM
27872 ELSE
27873 CTNMN5=0D0
27874 CTPMN5=CTLIM
27875 ENDIF
27876 ENDIF
27877 IF(CKIN(38).GT.0D0) THEN
27878 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27879 IF(CTLIM.GT.0D0) THEN
27880 CTPMX5=CTLIM
27881 ELSE
27882 CTPMX5=0D0
27883 CTNMX5=CTLIM
27884 ENDIF
27885 ENDIF
27886
27887C...Net effect of all separate limits.
27888 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27889 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27890 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27891 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27892 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27893
27894 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
27895 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
27896
27897 ELSEIF(ILIM.EQ.4) THEN
27898C...Calculate limits on tau'
27899C...0) due to kinematics
27900 TAPMN0=TAU
27901 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27902 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27903 TAPMN0=(SQRT(TAU)+PQRAT)**2
27904 ENDIF
27905 TAPMX0=1D0
27906C...1) due to explicit limits
27907 TAPMN1=CKIN(31)**2/VINT(2)
27908 TAPMX1=1D0
27909 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27910
27911C...Net effect of all separate limits.
27912 VINT(16)=MAX(TAPMN0,TAPMN1)
27913 VINT(36)=MIN(TAPMX0,TAPMX1)
27914 IF(MINT(47).EQ.1) THEN
27915 VINT(16)=1D0-1D-9
27916 VINT(36)=1D0+1D-9
27917 ELSEIF(MINT(47).EQ.5) THEN
27918 VINT(36)=MIN(VINT(36),1D0-2D-10)
27919 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27920 VINT(36)=MIN(VINT(36),1D0-1D-10)
27921 ENDIF
27922 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27923
27924 ENDIF
27925 RETURN
27926
27927C...Special case for low-pT and multiple interactions:
27928C...effective kinematical limits for tau, y*, cos(theta-hat).
27929 100 IF(ILIM.EQ.0) THEN
27930 ELSEIF(ILIM.EQ.1) THEN
27931 IF(MSTP(82).LE.1) THEN
27932 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27933 & VINT(2)
27934 ELSE
27935 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27936 ENDIF
27937 VINT(31)=1D0
27938 ELSEIF(ILIM.EQ.2) THEN
27939 VINT(12)=0.5D0*LOG(VINT(21))
27940 VINT(32)=-VINT(12)
27941 ELSEIF(ILIM.EQ.3) THEN
27942 IF(MSTP(82).LE.1) THEN
27943 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27944 & (VINT(21)*VINT(2))
27945 ELSE
27946 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27947 & (VINT(21)*VINT(2))
27948 ENDIF
27949 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27950 VINT(33)=0D0
27951 VINT(14)=0D0
27952 VINT(34)=-VINT(13)
27953 ENDIF
27954
27955 RETURN
27956 END
27957
27958C*********************************************************************
27959
27960C...PYKMAP
27961C...Maps a uniform distribution into a distribution of a kinematical
27962C...variable according to one of the possibilities allowed. It is
27963C...assumed that kinematical limits have been set by a PYKLIM call.
27964
27965 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27966
27967C...Double precision and integer declarations.
27968 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27969 IMPLICIT INTEGER(I-N)
27970 INTEGER PYK,PYCHGE,PYCOMP
27971C...Commonblocks.
27972 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27973 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27974 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27975 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27976 COMMON/PYINT1/MINT(400),VINT(400)
27977 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27978 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
27979
27980C...Convert VVAR to tau variable.
27981 ISUB=MINT(1)
27982 ISTSB=ISET(ISUB)
27983 IF(IVAR.EQ.1) THEN
27984 TAUMIN=VINT(11)
27985 TAUMAX=VINT(31)
27986 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
27987 TAURE=VINT(73)
27988 GAMRE=VINT(74)
27989 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
27990 TAURE=VINT(75)
27991 GAMRE=VINT(76)
27992 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
27993 TAURE=VINT(77)
27994 GAMRE=VINT(78)
27995 ENDIF
27996 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27997 TAU=1D0
27998 ELSEIF(MVAR.EQ.1) THEN
27999 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28000 ELSEIF(MVAR.EQ.2) THEN
28001 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28002 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28003 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28004 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28005 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28006 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28007 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28008 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28009 ELSEIF(MINT(47).EQ.5) THEN
28010 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28011 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28012 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28013 ELSE
28014 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28015 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28016 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28017 ENDIF
28018 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28019
28020C...Convert VVAR to y* variable.
28021 ELSEIF(IVAR.EQ.2) THEN
28022 YSTMIN=VINT(12)
28023 YSTMAX=VINT(32)
28024 TAUE=VINT(21)
28025 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28026 IF(MINT(47).EQ.1) THEN
28027 YST=0D0
28028 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28029 YST=-0.5D0*LOG(TAUE)
28030 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28031 YST=0.5D0*LOG(TAUE)
28032 ELSEIF(MVAR.EQ.1) THEN
28033 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28034 ELSEIF(MVAR.EQ.2) THEN
28035 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28036 ELSEIF(MVAR.EQ.3) THEN
28037 AUPP=ATAN(EXP(YSTMAX))
28038 ALOW=ATAN(EXP(YSTMIN))
28039 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28040 ELSEIF(MVAR.EQ.4) THEN
28041 YST0=-0.5D0*LOG(TAUE)
28042 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28043 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28044 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28045 ELSE
28046 YST0=-0.5D0*LOG(TAUE)
28047 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28048 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28049 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28050 ENDIF
28051 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28052
28053C...Convert VVAR to cos(theta-hat) variable.
28054 ELSEIF(IVAR.EQ.3) THEN
28055 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28056 RSQM=1D0+RM34
28057 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28058 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28059 CTNMIN=VINT(13)
28060 CTNMAX=VINT(33)
28061 CTPMIN=VINT(14)
28062 CTPMAX=VINT(34)
28063 IF(MVAR.EQ.1) THEN
28064 ANEG=CTNMAX-CTNMIN
28065 APOS=CTPMAX-CTPMIN
28066 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28067 VCTN=VVAR*(ANEG+APOS)/ANEG
28068 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28069 ELSE
28070 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28071 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28072 ENDIF
28073 ELSEIF(MVAR.EQ.2) THEN
28074 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28075 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28076 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28077 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28078 ANEG=LOG(RMNMIN/RMNMAX)
28079 APOS=LOG(RMPMIN/RMPMAX)
28080 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28081 VCTN=VVAR*(ANEG+APOS)/ANEG
28082 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28083 ELSE
28084 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28085 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28086 ENDIF
28087 ELSEIF(MVAR.EQ.3) THEN
28088 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28089 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28090 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28091 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28092 ANEG=LOG(RMNMAX/RMNMIN)
28093 APOS=LOG(RMPMAX/RMPMIN)
28094 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28095 VCTN=VVAR*(ANEG+APOS)/ANEG
28096 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28097 ELSE
28098 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28099 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28100 ENDIF
28101 ELSEIF(MVAR.EQ.4) THEN
28102 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28103 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28104 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28105 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28106 ANEG=1D0/RMNMAX-1D0/RMNMIN
28107 APOS=1D0/RMPMAX-1D0/RMPMIN
28108 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28109 VCTN=VVAR*(ANEG+APOS)/ANEG
28110 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28111 ELSE
28112 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28113 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28114 ENDIF
28115 ELSEIF(MVAR.EQ.5) THEN
28116 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28117 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28118 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28119 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28120 ANEG=1D0/RMNMIN-1D0/RMNMAX
28121 APOS=1D0/RMPMIN-1D0/RMPMAX
28122 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28123 VCTN=VVAR*(ANEG+APOS)/ANEG
28124 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28125 ELSE
28126 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28127 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28128 ENDIF
28129 ENDIF
28130 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28131 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28132 VINT(23)=CTH
28133
28134C...Convert VVAR to tau' variable.
28135 ELSEIF(IVAR.EQ.4) THEN
28136 TAU=VINT(21)
28137 TAUPMN=VINT(16)
28138 TAUPMX=VINT(36)
28139 IF(MINT(47).EQ.1) THEN
28140 TAUP=1D0
28141 ELSEIF(MVAR.EQ.1) THEN
28142 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
28143 ELSEIF(MVAR.EQ.2) THEN
28144 AUPP=(1D0-TAU/TAUPMX)**4
28145 ALOW=(1D0-TAU/TAUPMN)**4
28146 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
28147 ELSEIF(MINT(47).EQ.5) THEN
28148 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
28149 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
28150 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28151 ELSE
28152 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
28153 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
28154 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28155 ENDIF
28156 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
28157
28158C...Selection of extra variables needed in 2 -> 3 process:
28159C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28160C...Since no options are available, the functions of PYKLIM
28161C...and PYKMAP are joint for these choices.
28162 ELSEIF(IVAR.EQ.5) THEN
28163
28164C...Read out total energy and particle masses.
28165 MINT(51)=0
28166 MPTPK=1
28167 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
28168 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
28169 & MPTPK=2
28170 SHP=VINT(26)*VINT(2)
28171 SHPR=SQRT(SHP)
28172 PM1=VINT(201)
28173 PM2=VINT(206)
28174 PM3=SQRT(VINT(21))*VINT(1)
28175 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
28176 MINT(51)=1
28177 RETURN
28178 ENDIF
28179 PMRS1=VINT(204)**2
28180 PMRS2=VINT(209)**2
28181
28182C...Specify coefficients of pT choice; upper and lower limits.
28183 IF(MPTPK.EQ.1) THEN
28184 HWT1=0.4D0
28185 HWT2=0.4D0
28186 ELSE
28187 HWT1=0.05D0
28188 HWT2=0.05D0
28189 ENDIF
28190 HWT3=1D0-HWT1-HWT2
28191 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
28192 & (4D0*SHP)
28193 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
28194 PTSMN1=CKIN(51)**2
28195 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
28196 & (4D0*SHP)
28197 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
28198 PTSMN2=CKIN(53)**2
28199
28200C...Select transverse momenta according to
28201C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28202 HMX=PMRS1+PTSMX1
28203 HMN=PMRS1+PTSMN1
28204 IF(HMX.LT.1.0001D0*HMN) THEN
28205 MINT(51)=1
28206 RETURN
28207 ENDIF
28208 HDE=PTSMX1-PTSMN1
28209 RPT=PYR(0)
28210 IF(RPT.LT.HWT1) THEN
28211 PTS1=PTSMN1+PYR(0)*HDE
28212 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28213 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
28214 ELSE
28215 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
28216 ENDIF
28217 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
28218 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
28219 HMX=PMRS2+PTSMX2
28220 HMN=PMRS2+PTSMN2
28221 IF(HMX.LT.1.0001D0*HMN) THEN
28222 MINT(51)=1
28223 RETURN
28224 ENDIF
28225 HDE=PTSMX2-PTSMN2
28226 RPT=PYR(0)
28227 IF(RPT.LT.HWT1) THEN
28228 PTS2=PTSMN2+PYR(0)*HDE
28229 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28230 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
28231 ELSE
28232 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
28233 ENDIF
28234 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
28235 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
28236
28237C...Select azimuthal angles and check pT choice.
28238 PHI1=PARU(2)*PYR(0)
28239 PHI2=PARU(2)*PYR(0)
28240 PHIR=PHI2-PHI1
28241 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
28242 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
28243 & CKIN(56)**2)) THEN
28244 MINT(51)=1
28245 RETURN
28246 ENDIF
28247
28248C...Calculate transverse masses and check phase space not closed.
28249 PMS1=PM1**2+PTS1
28250 PMS2=PM2**2+PTS2
28251 PMS3=PM3**2+PTS3
28252 PMT1=SQRT(PMS1)
28253 PMT2=SQRT(PMS2)
28254 PMT3=SQRT(PMS3)
28255 PM12=(PMT1+PMT2)**2
28256 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
28257 MINT(51)=1
28258 RETURN
28259 ENDIF
28260
28261C...Select rapidity for particle 3 and check phase space not closed.
28262 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
28263 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
28264 IF(Y3MAX.LT.1D-6) THEN
28265 MINT(51)=1
28266 RETURN
28267 ENDIF
28268 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
28269 PZ3=PMT3*SINH(Y3)
28270 PE3=PMT3*COSH(Y3)
28271
28272C...Find momentum transfers in two mirror solutions (in 1-2 frame).
28273 PZ12=-PZ3
28274 PE12=SHPR-PE3
28275 PMS12=PE12**2-PZ12**2
28276 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
28277 IF(SQL12.LT.1D-6*SHP) THEN
28278 MINT(51)=1
28279 RETURN
28280 ENDIF
28281 PMM1=PMS12+PMS1-PMS2
28282 PMM2=PMS12+PMS2-PMS1
28283 TFAC=-SHPR/(2D0*PMS12)
28284 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
28285 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
28286 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
28287 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
28288
28289C...Construct relative mirror weights and make choice.
28290 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
28291 WTPU=1D0
28292 WTNU=1D0
28293 ELSE
28294 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
28295 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
28296 ENDIF
28297 WTP=WTPU/(WTPU+WTNU)
28298 WTN=WTNU/(WTPU+WTNU)
28299 EPS=1D0
28300 IF(WTN.GT.PYR(0)) EPS=-1D0
28301
28302C...Store result of variable choice and associated weights.
28303 VINT(202)=PTS1
28304 VINT(207)=PTS2
28305 VINT(203)=PHI1
28306 VINT(208)=PHI2
28307 VINT(205)=WTPTS1
28308 VINT(210)=WTPTS2
28309 VINT(211)=Y3
28310 VINT(212)=Y3MAX
28311 VINT(213)=EPS
28312 IF(EPS.GT.0D0) THEN
28313 VINT(214)=1D0/WTP
28314 VINT(215)=T1P
28315 VINT(216)=T2P
28316 ELSE
28317 VINT(214)=1D0/WTN
28318 VINT(215)=T1N
28319 VINT(216)=T2N
28320 ENDIF
28321 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
28322 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
28323 VINT(219)=0.5D0*(PMS12-PTS3)
28324 VINT(220)=SQL12
28325 ENDIF
28326
28327 RETURN
28328 END
28329
28330C***********************************************************************
28331
28332C...PYSIGH
28333C...Differential matrix elements for all included subprocesses
28334C...Note that what is coded is (disregarding the COMFAC factor)
28335C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
28336C...when d(sigma-hat) is given in the zero-width limit, the delta
28337C...function in tau is replaced by a (modified) Breit-Wigner:
28338C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
28339C...where H_res = s-hat/m_res*Gamma_res(s-hat);
28340C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
28341C...i.e., dimensionless quantities
28342C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
28343C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
28344C...(2pi)^4 delta^4(P - sum p_i)
28345C...COMFAC contains the factor pi/s (or equivalent) and
28346C...the conversion factor from GeV^-2 to mb
28347
28348 SUBROUTINE PYSIGH(NCHN,SIGS)
28349
28350C...Double precision and integer declarations
28351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28352 IMPLICIT INTEGER(I-N)
28353 INTEGER PYK,PYCHGE,PYCOMP
28354C...Parameter statement to help give large particle numbers.
28355 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28356 &KEXCIT=4000000,KDIMEN=5000000)
28357C...Commonblocks
28358 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28359 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28360 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28361 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28362 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28363 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28364 COMMON/PYINT1/MINT(400),VINT(400)
28365 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28366 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28367 COMMON/PYINT4/MWID(500),WIDS(500,5)
28368 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28369 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28370 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28371 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28372 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
28373 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
28374 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28375 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28376 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28377 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28378 COMMON/PYTCCO/COEFX(194:380,2)
28379 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28380 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
28381 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/,/PYTCCO/
28382C...Local arrays and complex variables
28383 DIMENSION XPQ(-25:25)
28384
28385C...Map of processes onto which routine to call
28386C...in order to evaluate cross section:
28387C...0 = not implemented;
28388C...1 = standard QCD (including photons);
28389C...2 = heavy flavours;
28390C...3 = W/Z;
28391C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
28392C...5 = SUSY;
28393C...6 = Technicolor;
28394C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28395 DIMENSION MAPPR(500)
28396 DATA (MAPPR(I),I=1,180)/
28397 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
28398 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
28399 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
28400 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
28401 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28402 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
28403 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
28404 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
28405 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28406 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
28407 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
28408 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
28409 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
28410 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
28411 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
28412 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
28413 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
28414 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
28415 DATA (MAPPR(I),I=181,500)/
28416 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
28417 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
28418 & 100*5,
28419 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28420 1 30*0,
28421 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
28422 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
28423 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
28424 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
28425 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
28426 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
28427 & 4, 4, 18*0,
28428 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28429 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28430 4 20*0,
28431 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28432 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28433 8 20*0/
28434
28435C...Reset number of channels and cross-section
28436 NCHN=0
28437 SIGS=0D0
28438
28439C...Read process to consider.
28440 ISUB=MINT(1)
28441 ISUBSV=ISUB
28442 MAP=MAPPR(ISUB)
28443
28444C...Read kinematical variables and limits
28445 ISTSB=ISET(ISUBSV)
28446 TAUMIN=VINT(11)
28447 YSTMIN=VINT(12)
28448 CTNMIN=VINT(13)
28449 CTPMIN=VINT(14)
28450 TAUPMN=VINT(16)
28451 TAU=VINT(21)
28452 YST=VINT(22)
28453 CTH=VINT(23)
28454 XT2=VINT(25)
28455 TAUP=VINT(26)
28456 TAUMAX=VINT(31)
28457 YSTMAX=VINT(32)
28458 CTNMAX=VINT(33)
28459 CTPMAX=VINT(34)
28460 TAUPMX=VINT(36)
28461
28462C...Derive kinematical quantities
28463 TAUE=TAU
28464 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28465 X(1)=SQRT(TAUE)*EXP(YST)
28466 X(2)=SQRT(TAUE)*EXP(-YST)
28467 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
28468 IF(X(1).GT.1D0-1D-7) RETURN
28469 ELSEIF(MINT(45).EQ.3) THEN
28470 X(1)=MIN(1D0-1.1D-10,X(1))
28471 ENDIF
28472 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
28473 IF(X(2).GT.1D0-1D-7) RETURN
28474 ELSEIF(MINT(46).EQ.3) THEN
28475 X(2)=MIN(1D0-1.1D-10,X(2))
28476 ENDIF
28477 SH=MAX(1D0,TAU*VINT(2))
28478 SQM3=VINT(63)
28479 SQM4=VINT(64)
28480 RM3=SQM3/SH
28481 RM4=SQM4/SH
28482 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28483 RPTS=4D0*VINT(71)**2/SH
28484 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28485 RM34=MAX(1D-20,2D0*RM3*RM4)
28486 RSQM=1D0+RM34
28487 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
28488 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
28489 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28490 IF(ISTSB.EQ.0) THEN
28491 TH=VINT(45)
28492 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28493 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
28494 ELSE
28495C...Kinematics with incoming masses tricky: now depends on how
28496C...subprocess has been set up w.r.t. order of incoming partons.
28497 RM1=0D0
28498 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
28499 RM2=0D0
28500 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
28501 IF(ISUB.EQ.35) THEN
28502 RM2=MIN(RM1,RM2)
28503 RM1=0D0
28504 ENDIF
28505 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28506 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
28507 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
28508 & BE12*BE34*CTH)
28509 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
28510 & BE12*BE34*CTH)
28511 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
28512 ENDIF
28513 SHR=SQRT(SH)
28514 SH2=SH**2
28515 TH2=TH**2
28516 UH2=UH**2
28517
28518C...Choice of Q2 scale for hard process (e.g. alpha_s).
28519 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
28520 Q2=SH
28521 ELSEIF(ISTSB.EQ.8) THEN
28522 IF(MINT(107).EQ.4) Q2=VINT(307)
28523 IF(MINT(108).EQ.4) Q2=VINT(308)
28524 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
28525 Q2IN1=0D0
28526 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
28527 Q2IN2=0D0
28528 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
28529 IF(MSTP(32).EQ.1) THEN
28530 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
28531 ELSEIF(MSTP(32).EQ.2) THEN
28532 Q2=SQPTH+0.5D0*(SQM3+SQM4)
28533 ELSEIF(MSTP(32).EQ.3) THEN
28534 Q2=MIN(-TH,-UH)
28535 ELSEIF(MSTP(32).EQ.4) THEN
28536 Q2=SH
28537 ELSEIF(MSTP(32).EQ.5) THEN
28538 Q2=-TH
28539 ELSEIF(MSTP(32).EQ.6) THEN
28540 XSF1=X(1)
28541 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
28542 XSF2=X(2)
28543 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
28544 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
28545 & (SQPTH+0.5D0*(SQM3+SQM4))
28546 ELSEIF(MSTP(32).EQ.7) THEN
28547 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
28548 ELSEIF(MSTP(32).EQ.8) THEN
28549 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
28550 ELSEIF(MSTP(32).EQ.9) THEN
28551 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
28552 ELSEIF(MSTP(32).EQ.10) THEN
28553 Q2=VINT(2)
28554C..Begin JA 040914
28555 ELSEIF(MSTP(32).EQ.11) THEN
28556 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
28557 ELSEIF(MSTP(32).EQ.12) THEN
28558 Q2=PARP(193)
28559C..End JA
28560 ELSEIF(MSTP(32).EQ.13) THEN
28561 Q2=SQPTH
28562 ENDIF
28563 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
28564 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
28565 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
28566 ENDIF
28567
28568C...Choice of Q2 scale for parton densities.
28569 Q2SF=Q2
28570C..Begin JA 040914
28571 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
28572 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
28573 & Q2=PARP(194)
28574C..End JA
28575 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28576 Q2SF=PMAS(23,1)**2
28577 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
28578 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
28579 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
28580 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
28581 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
28582 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
28583 IF(MSTP(39).EQ.2) Q2SF=
28584 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
28585 IF(MSTP(39).EQ.3) Q2SF=SH
28586 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
28587 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
28588C..Begin JA 040914
28589 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
28590 IF(MSTP(39).EQ.7) Q2SF=
28591 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
28592 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
28593C..End JA
28594 ENDIF
28595 ENDIF
28596 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
28597
28598 Q2PS=Q2SF
28599 Q2SF=Q2SF*PARP(34)
28600 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
28601 IF(MSTP(69).GE.2) Q2SF=VINT(2)
28602
28603C...Identify to which class(es) subprocess belongs
28604 ISMECR=0
28605 ISQCD=0
28606 ISJETS=0
28607 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
28608 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
28609 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
28610 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
28611 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
28612 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
28613 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
28614 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
28615 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
28616 IF (ISTSB.EQ.9) ISQCD=1
28617 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
28618 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
28619 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
28620 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
28621 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
28622 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
28623 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
28624 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
28625C...WBF is special case of ISJETS
28626 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
28627 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
28628 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
28629 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
28630 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
28631 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
28632 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
28633 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
28634 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
28635C...Some processes with photons also belong here.
28636 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
28637 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
28638 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
28639 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
28640 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
28641 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
28642
28643C...Choice of Q2 scale for parton-shower activity.
28644 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
28645 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
28646 XBJ=X(2)
28647 IF(MINT(43).EQ.3) XBJ=X(1)
28648 IF(MSTP(22).EQ.1) THEN
28649 Q2PS=-TH
28650 ELSEIF(MSTP(22).EQ.2) THEN
28651 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
28652 ELSEIF(MSTP(22).EQ.3) THEN
28653 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
28654 ELSE
28655 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
28656 ENDIF
28657 ENDIF
28658C...For multiple interactions, start from scale defined above
28659C...For all other QCD or "+jets"-type events, start shower from pThard.
28660 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
28661 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
28662C...Max shower scale = s for ME corrected processes.
28663C...(pT-ordering: max pT2 is s/4)
28664 Q2PS=VINT(2)
28665 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28666 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
28667C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
28668C...(pT-ordering: max pT2 is s/4)
28669 Q2PS=VINT(2)
28670 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28671 ENDIF
28672 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
28673
28674C...Elastic and diffractive events not associated with scales so set 0.
28675 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
28676 Q2SF=0D0
28677 Q2PS=0D0
28678 ENDIF
28679
28680C...Store derived kinematical quantities
28681 VINT(41)=X(1)
28682 VINT(42)=X(2)
28683 VINT(44)=SH
28684 VINT(43)=SQRT(SH)
28685 VINT(45)=TH
28686 VINT(46)=UH
28687 IF(ISTSB.NE.8) VINT(48)=SQPTH
28688 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
28689 VINT(50)=TAUP*VINT(2)
28690 VINT(49)=SQRT(MAX(0D0,VINT(50)))
28691 VINT(52)=Q2
28692 VINT(51)=SQRT(Q2)
28693 VINT(54)=Q2SF
28694 VINT(53)=SQRT(Q2SF)
28695 VINT(56)=Q2PS
28696 VINT(55)=SQRT(Q2PS)
28697
28698C...Set starting scale for multiple interactions
28699 IF (ISUBSV.EQ.95) THEN
28700 XT2GMX=0D0
28701 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
28702 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
28703 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
28704 & ISUBSV.NE.96)) THEN
28705C...All accessible phase space allowed.
28706 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
28707 ELSE
28708C...Scale of hard process sets limit.
28709C...2 -> 1. Limit is tau = x1*x2.
28710C...2 -> 2. Limit is XT2 for hard process + FS masses.
28711C...2 -> n > 2. Limit is tau' = tau of outer process.
28712 XT2GMX=VINT(25)
28713 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
28714 IF(ISTSB.EQ.2)
28715 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
28716 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
28717 ENDIF
28718 VINT(62)=0.25D0*XT2GMX*VINT(2)
28719 VINT(61)=SQRT(MAX(0D0,VINT(62)))
28720
28721C...Calculate parton distributions
28722 IF(ISTSB.LE.0) GOTO 160
28723 IF(MINT(47).GE.2) THEN
28724 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
28725 XSF=X(I)
28726 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
28727 IF(ISUB.EQ.99) THEN
28728 IF(MINT(140+I).EQ.0) THEN
28729 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
28730 ELSE
28731 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
28732 ENDIF
28733 VINT(40+I)=XSF
28734 Q2SF=VINT(309-I)
28735 ENDIF
28736 MINT(105)=MINT(102+I)
28737 MINT(109)=MINT(106+I)
28738 VINT(120)=VINT(2+I)
28739C.... ALICE
28740C.... Store side in MINT(124)
28741 MINT(124)=I
28742C....
28743 IF(MSTP(57).LE.1) THEN
28744 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
28745 ELSE
28746 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
28747 ENDIF
28748C...Safety margin against heavy flavour very close to threshold,
28749C...e.g. caused by mismatch in c and b masses.
28750 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
28751 XPQ(4)=0D0
28752 XPQ(-4)=0D0
28753 ENDIF
28754 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
28755 XPQ(5)=0D0
28756 XPQ(-5)=0D0
28757 ENDIF
28758 DO 100 KFL=-25,25
28759 XSFX(I,KFL)=XPQ(KFL)
28760 100 CONTINUE
28761 110 CONTINUE
28762 ENDIF
28763
28764C...Calculate alpha_em, alpha_strong and K-factor
28765 XW=PARU(102)
28766 XWV=XW
28767 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
28768 &1D0-(PMAS(24,1)/PMAS(23,1))**2
28769 XW1=1D0-XW
28770 XWC=1D0/(16D0*XW*XW1)
28771 AEM=PYALEM(Q2)
28772 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
28773 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
28774 FACK=1D0
28775 FACA=1D0
28776 IF(MSTP(33).EQ.1) THEN
28777 FACK=PARP(31)
28778 ELSEIF(MSTP(33).EQ.2) THEN
28779 FACK=PARP(31)
28780 FACA=PARP(32)/PARP(31)
28781 ELSEIF(MSTP(33).EQ.3) THEN
28782 Q2AS=PARP(33)*Q2
28783 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
28784 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
28785 AS=PYALPS(Q2AS)
28786 ENDIF
28787 VINT(138)=1D0
28788 VINT(57)=AEM
28789 VINT(58)=AS
28790
28791C...Set flags for allowed reacting partons/leptons
28792 DO 140 I=1,2
28793 DO 120 J=-25,25
28794 KFAC(I,J)=0
28795 120 CONTINUE
28796 IF(MINT(44+I).EQ.1) THEN
28797 KFAC(I,MINT(10+I))=1
28798 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
28799 KFAC(I,MINT(10+I))=1
28800 KFAC(I,22)=1
28801 KFAC(I,24)=1
28802 KFAC(I,-24)=1
28803 ELSE
28804 DO 130 J=-25,25
28805 KFAC(I,J)=KFIN(I,J)
28806 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
28807 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
28808 130 CONTINUE
28809 ENDIF
28810 140 CONTINUE
28811
28812C...Lower and upper limit for fermion flavour loops
28813 MMIN1=0
28814 MMAX1=0
28815 MMIN2=0
28816 MMAX2=0
28817 DO 150 J=-20,20
28818 IF(KFAC(1,-J).EQ.1) MMIN1=-J
28819 IF(KFAC(1,J).EQ.1) MMAX1=J
28820 IF(KFAC(2,-J).EQ.1) MMIN2=-J
28821 IF(KFAC(2,J).EQ.1) MMAX2=J
28822 150 CONTINUE
28823 MMINA=MIN(MMIN1,MMIN2)
28824 MMAXA=MAX(MMAX1,MMAX2)
28825
28826C...Common resonance mass and width combinations
28827 SQMZ=PMAS(23,1)**2
28828 SQMW=PMAS(24,1)**2
28829 GMMZ=PMAS(23,1)*PMAS(23,2)
28830 GMMW=PMAS(24,1)*PMAS(24,2)
28831
28832C...Polarization factors...implemented so far for W+W-(25)
28833 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
28834 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
28835 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
28836 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
28837
28838C...Phase space integral in tau
28839 COMFAC=PARU(1)*PARU(5)/VINT(2)
28840 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
28841 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
28842 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
28843 ATAU1=LOG(TAUMAX/TAUMIN)
28844 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
28845 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
28846 IF(MINT(72).GE.1) THEN
28847 TAUR1=VINT(73)
28848 GAMR1=VINT(74)
28849 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
28850 ATAU3=ATAUD/TAUR1
28851 IF(ATAUD.GT.1D-10) H1=H1+
28852 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
28853 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
28854 ATAU4=ATAUD/GAMR1
28855 IF(ATAUD.GT.1D-10) H1=H1+
28856 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
28857 ENDIF
28858 IF(MINT(72).GE.2) THEN
28859 TAUR2=VINT(75)
28860 GAMR2=VINT(76)
28861 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
28862 ATAU5=ATAUD/TAUR2
28863 IF(ATAUD.GT.1D-10) H1=H1+
28864 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
28865 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
28866 ATAU6=ATAUD/GAMR2
28867 IF(ATAUD.GT.1D-10) H1=H1+
28868 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
28869 ENDIF
28870 IF(MINT(72).EQ.3) THEN
28871 TAUR3=VINT(77)
28872 GAMR3=VINT(78)
28873 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
28874 ATAU50=ATAUD/TAUR3
28875 IF(ATAUD.GT.1D-10) H1=H1+
28876 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
28877 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
28878 ATAU60=ATAUD/GAMR3
28879 IF(ATAUD.GT.1D-10) H1=H1+
28880 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
28881 ENDIF
28882 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28883 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
28884 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28885 & MAX(2D-10,1D0-TAU)
28886 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28887 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
28888 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28889 & MAX(1D-10,1D0-TAU)
28890 ENDIF
28891 COMFAC=COMFAC*ATAU1/(TAU*H1)
28892 ENDIF
28893
28894C...Phase space integral in y*
28895 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
28896 &THEN
28897 AYST0=YSTMAX-YSTMIN
28898 IF(AYST0.LT.1D-10) THEN
28899 COMFAC=0D0
28900 ELSE
28901 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28902 AYST2=AYST1
28903 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28904 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28905 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28906 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28907 IF(MINT(45).EQ.3) THEN
28908 YST0=-0.5D0*LOG(TAUE)
28909 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28910 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28911 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28912 & MAX(1D-10,1D0-EXP(YST-YST0))
28913 ENDIF
28914 IF(MINT(46).EQ.3) THEN
28915 YST0=-0.5D0*LOG(TAUE)
28916 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28917 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28918 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28919 & MAX(1D-10,1D0-EXP(-YST-YST0))
28920 ENDIF
28921 COMFAC=COMFAC*AYST0/H2
28922 ENDIF
28923 ENDIF
28924
28925C...2 -> 1 processes: reduction in angular part of phase space integral
28926C...for case of decaying resonance
28927 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28928 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28929 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28930 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28931 & KFPR(ISUB,1).EQ.39) THEN
28932 COMFAC=COMFAC*0.5D0*ACTH0
28933 ELSE
28934 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28935 & CTPMAX**3-CTPMIN**3)
28936 ENDIF
28937 ENDIF
28938
28939C...2 -> 2 processes: angular part of phase space integral
28940 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28941 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28942 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28943 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28944 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28945 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28946 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28947 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28948 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28949 H3=COEF(ISUBSV,13)+
28950 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28951 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28952 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28953 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28954 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28955
28956C...2 -> 2 processes: take into account final state Breit-Wigners
28957 COMFAC=COMFAC*VINT(80)
28958 ENDIF
28959
28960C...2 -> 3, 4 processes: phace space integral in tau'
28961 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28962 ATAUP1=LOG(TAUPMX/TAUPMN)
28963 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28964 H4=COEF(ISUBSV,18)+
28965 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28966 IF(MINT(47).EQ.5) THEN
28967 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28968 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28969 ELSEIF(MINT(47).GE.6) THEN
28970 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28971 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28972 ENDIF
28973 COMFAC=COMFAC*ATAUP1/H4
28974 ENDIF
28975
28976C...2 -> 3, 4 processes: effective W/Z parton distributions
28977 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28978 IF(1D0-TAU/TAUP.GT.1D-4) THEN
28979 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
28980 ELSE
28981 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
28982 ENDIF
28983 COMFAC=COMFAC*FZW
28984 ENDIF
28985
28986C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
28987 IF(ISTSB.EQ.5) THEN
28988 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
28989 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
28990 ENDIF
28991
28992C...Phase space integral for low-pT and multiple interactions
28993 IF(ISTSB.EQ.9) THEN
28994 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
28995 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
28996 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
28997 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
28998 COMFAC=COMFAC*ATAU1/H1
28999 AYST0=YSTMAX-YSTMIN
29000 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29001 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29002 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29003 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29004 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29005 COMFAC=COMFAC*AYST0/H2
29006 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29007C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29008C...introduced to make cross-section finite for xT2 -> 0
29009 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29010 & (1D0+VINT(149)))
29011 ENDIF
29012
29013C...Real gamma + gamma: include factor 2 when different nature
29014 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29015 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29016
29017C...Extra factors to include the effects of
29018C...longitudinal resolved photons (but not direct or DIS ones).
29019 DO 170 ISDE=1,2
29020 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29021 & MINT(106+ISDE).LE.3) THEN
29022 VINT(314+ISDE)=1D0
29023 XY=PARP(166+ISDE)
29024 IF(MSTP(16).EQ.0) THEN
29025 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29026 & XY=VINT(304+ISDE)
29027 ELSE
29028 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29029 & XY=VINT(308+ISDE)
29030 ENDIF
29031 Q2GA=VINT(306+ISDE)
29032 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29033 & Q2GA.GT.0D0) THEN
29034 REDUCE=0D0
29035 IF(MSTP(17).EQ.1) THEN
29036 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29037 ELSEIF(MSTP(17).EQ.2) THEN
29038 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29039 ELSEIF(MSTP(17).EQ.3) THEN
29040 PMVIRT=PMAS(PYCOMP(113),1)
29041 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29042 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29043 PMVIRT=PMAS(PYCOMP(113),1)
29044 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29045 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29046 PMVIRT=PMAS(PYCOMP(113),1)
29047 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29048 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29049 PMVSMN=4D0*PARP(15)**2
29050 PMVSMX=4D0*VINT(154)**2
29051 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29052 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29053 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29054 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29055 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29056 PMVIRT=PMAS(PYCOMP(113),1)
29057 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29058 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29059 PMVIRT=PMAS(PYCOMP(113),1)
29060 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29061 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29062 PMVSMN=4D0*PARP(15)**2
29063 PMVSMX=4D0*VINT(154)**2
29064 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29065 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29066 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29067 ENDIF
29068 BEAMAS=PYMASS(11)
29069 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29070 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29071 & (1D0-2D0*BEAMAS**2/Q2GA))
29072 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29073 ENDIF
29074 ELSE
29075 VINT(314+ISDE)=1D0
29076 ENDIF
29077 COMFAC=COMFAC*VINT(314+ISDE)
29078 170 CONTINUE
29079
29080C...Evaluate cross sections - done in separate routines by kind
29081C...of physics, to keep PYSIGH of sensible size.
29082 IF(MAP.EQ.1) THEN
29083C...Standard QCD (including photons).
29084 CALL PYSGQC(NCHN,SIGS)
29085 ELSEIF(MAP.EQ.2) THEN
29086C...Heavy flavours.
29087 CALL PYSGHF(NCHN,SIGS)
29088 ELSEIF(MAP.EQ.3) THEN
29089C...W/Z.
29090 CALL PYSGWZ(NCHN,SIGS)
29091 ELSEIF(MAP.EQ.4) THEN
29092C...Higgs (2 doublets; including longitudinal W/Z scattering).
29093 CALL PYSGHG(NCHN,SIGS)
29094 ELSEIF(MAP.EQ.5) THEN
29095C...SUSY.
29096 CALL PYSGSU(NCHN,SIGS)
29097 ELSEIF(MAP.EQ.6) THEN
29098C...Technicolor.
29099 CALL PYSGTC(NCHN,SIGS)
29100 ELSEIF(MAP.EQ.7) THEN
29101C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29102 CALL PYSGEX(NCHN,SIGS)
29103 ENDIF
29104
29105C...Multiply with parton distributions
29106 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29107 DO 180 ICHN=1,NCHN
29108 IF(MINT(45).GE.2) THEN
29109 KFL1=ISIG(ICHN,1)
29110 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29111 ENDIF
29112 IF(MINT(46).GE.2) THEN
29113 KFL2=ISIG(ICHN,2)
29114 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29115 ENDIF
29116 SIGS=SIGS+SIGH(ICHN)
29117 180 CONTINUE
29118 ENDIF
29119
29120 RETURN
29121 END
29122
29123C*********************************************************************
29124
29125C...PYSGQC
29126C...Subprocess cross sections for QCD processes,
29127C...including photons.
29128C...Auxiliary to PYSIGH.
29129
29130 SUBROUTINE PYSGQC(NCHN,SIGS)
29131
29132C...Double precision and integer declarations
29133 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29134 IMPLICIT INTEGER(I-N)
29135 INTEGER PYK,PYCHGE,PYCOMP
29136C...Parameter statement to help give large particle numbers.
29137 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29138 &KEXCIT=4000000,KDIMEN=5000000)
29139C...Commonblocks
29140 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29141 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29142 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29143 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29144 COMMON/PYINT1/MINT(400),VINT(400)
29145 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29146 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29147 COMMON/PYINT4/MWID(500),WIDS(500,5)
29148 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29149 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29150 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29151 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29152 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29153 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
29154 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
29155C...Local arrays
29156 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29157
29158C...Differential cross section expressions.
29159
29160 IF(ISUB.LE.20) THEN
29161 IF(ISUB.EQ.10) THEN
29162C...f + f' -> f + f' (gamma/Z/W exchange)
29163 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
29164 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
29165 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
29166 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
29167 DO 110 I=MMIN1,MMAX1
29168 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
29169 IA=IABS(I)
29170 DO 100 J=MMIN2,MMAX2
29171 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
29172 JA=IABS(J)
29173C...Electroweak couplings
29174 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
29175 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
29176 VI=AI-4D0*EI*XWV
29177 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
29178 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
29179 VJ=AJ-4D0*EJ*XWV
29180 EPSIJ=ISIGN(1,I*J)
29181C...gamma/Z exchange, only gamma exchange, or only Z exchange
29182 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
29183 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
29184 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
29185 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
29186 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
29187 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29188 ELSEIF(MSTP(21).EQ.2) THEN
29189 FACNCF=FACGGF*EI**2*EJ**2
29190 ELSE
29191 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
29192 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29193 ENDIF
29194C...Extrafactor 2 for only one incoming neutrino spin state.
29195 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
29196 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
29197 NCHN=NCHN+1
29198 ISIG(NCHN,1)=I
29199 ISIG(NCHN,2)=J
29200 ISIG(NCHN,3)=1
29201 SIGH(NCHN)=FACNCF
29202 ENDIF
29203C...W exchange
29204 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
29205 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
29206 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
29207 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
29208 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
29209 NCHN=NCHN+1
29210 ISIG(NCHN,1)=I
29211 ISIG(NCHN,2)=J
29212 ISIG(NCHN,3)=2
29213 SIGH(NCHN)=FACCCF
29214 ENDIF
29215 100 CONTINUE
29216 110 CONTINUE
29217
29218 ELSEIF(ISUB.EQ.11) THEN
29219C...f + f' -> f + f' (g exchange)
29220 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29221 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29222 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29223 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
29224 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
29225 DO 130 I=MMIN1,MMAX1
29226 IA=IABS(I)
29227 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
29228 DO 120 J=MMIN2,MMAX2
29229 JA=IABS(J)
29230 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
29231 NCHN=NCHN+1
29232 ISIG(NCHN,1)=I
29233 ISIG(NCHN,2)=J
29234 ISIG(NCHN,3)=1
29235 SIGH(NCHN)=FACQQ1
29236 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29237 IF(I.EQ.J) THEN
29238 SIGH(NCHN)=0.5D0*SIGH(NCHN)
29239 NCHN=NCHN+1
29240 ISIG(NCHN,1)=I
29241 ISIG(NCHN,2)=J
29242 ISIG(NCHN,3)=2
29243 SIGH(NCHN)=0.5D0*FACQQ2
29244 ENDIF
29245 120 CONTINUE
29246 130 CONTINUE
29247
29248 ELSEIF(ISUB.EQ.12) THEN
29249C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
29250 CALL PYWIDT(21,SH,WDTP,WDTE)
29251 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29252 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
29253 DO 140 I=MMINA,MMAXA
29254 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29255 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
29256 NCHN=NCHN+1
29257 ISIG(NCHN,1)=I
29258 ISIG(NCHN,2)=-I
29259 ISIG(NCHN,3)=1
29260 SIGH(NCHN)=FACQQB
29261 140 CONTINUE
29262
29263 ELSEIF(ISUB.EQ.13) THEN
29264C...f + fbar -> g + g (q + qbar -> g + g only)
29265 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29266 & UH2/SH2)
29267 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29268 & TH2/SH2)
29269 DO 150 I=MMINA,MMAXA
29270 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29271 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
29272 NCHN=NCHN+1
29273 ISIG(NCHN,1)=I
29274 ISIG(NCHN,2)=-I
29275 ISIG(NCHN,3)=1
29276 SIGH(NCHN)=0.5D0*FACGG1
29277 NCHN=NCHN+1
29278 ISIG(NCHN,1)=I
29279 ISIG(NCHN,2)=-I
29280 ISIG(NCHN,3)=2
29281 SIGH(NCHN)=0.5D0*FACGG2
29282 150 CONTINUE
29283
29284 ELSEIF(ISUB.EQ.14) THEN
29285C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
29286 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
29287 DO 160 I=MMINA,MMAXA
29288 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29289 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
29290 EI=KCHG(IABS(I),1)/3D0
29291 NCHN=NCHN+1
29292 ISIG(NCHN,1)=I
29293 ISIG(NCHN,2)=-I
29294 ISIG(NCHN,3)=1
29295 SIGH(NCHN)=FACGG*EI**2
29296 160 CONTINUE
29297
29298 ELSEIF(ISUB.EQ.18) THEN
29299C...f + fbar -> gamma + gamma
29300 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
29301 DO 170 I=MMINA,MMAXA
29302 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
29303 EI=KCHG(IABS(I),1)/3D0
29304 FCOI=1D0
29305 IF(IABS(I).LE.10) FCOI=FACA/3D0
29306 NCHN=NCHN+1
29307 ISIG(NCHN,1)=I
29308 ISIG(NCHN,2)=-I
29309 ISIG(NCHN,3)=1
29310 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
29311 170 CONTINUE
29312 ENDIF
29313
29314 ELSEIF(ISUB.LE.40) THEN
29315 IF(ISUB.EQ.28) THEN
29316C...f + g -> f + g (q + g -> q + g only)
29317 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29318 & UH/SH)*FACA
29319 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29320 & SH/UH)
29321 DO 190 I=MMINA,MMAXA
29322 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
29323 DO 180 ISDE=1,2
29324 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
29325 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
29326 NCHN=NCHN+1
29327 ISIG(NCHN,ISDE)=I
29328 ISIG(NCHN,3-ISDE)=21
29329 ISIG(NCHN,3)=1
29330 SIGH(NCHN)=FACQG1
29331 NCHN=NCHN+1
29332 ISIG(NCHN,ISDE)=I
29333 ISIG(NCHN,3-ISDE)=21
29334 ISIG(NCHN,3)=2
29335 SIGH(NCHN)=FACQG2
29336 180 CONTINUE
29337 190 CONTINUE
29338
29339 ELSEIF(ISUB.EQ.29) THEN
29340C...f + g -> f + gamma (q + g -> q + gamma only)
29341 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
29342 DO 210 I=MMINA,MMAXA
29343 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
29344 EI=KCHG(IABS(I),1)/3D0
29345 FACGQ=FGQ*EI**2
29346 DO 200 ISDE=1,2
29347 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
29348 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
29349 NCHN=NCHN+1
29350 ISIG(NCHN,ISDE)=I
29351 ISIG(NCHN,3-ISDE)=21
29352 ISIG(NCHN,3)=1
29353 SIGH(NCHN)=FACGQ
29354 200 CONTINUE
29355 210 CONTINUE
29356
29357 ELSEIF(ISUB.EQ.33) THEN
29358C...f + gamma -> f + g (q + gamma -> q + g only)
29359 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
29360 DO 230 I=MMINA,MMAXA
29361 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
29362 EI=KCHG(IABS(I),1)/3D0
29363 FACGQ=FGQ*EI**2
29364 DO 220 ISDE=1,2
29365 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
29366 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
29367 NCHN=NCHN+1
29368 ISIG(NCHN,ISDE)=I
29369 ISIG(NCHN,3-ISDE)=22
29370 ISIG(NCHN,3)=1
29371 SIGH(NCHN)=FACGQ
29372 220 CONTINUE
29373 230 CONTINUE
29374
29375 ELSEIF(ISUB.EQ.34) THEN
29376C...f + gamma -> f + gamma
29377 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
29378 DO 250 I=MMINA,MMAXA
29379 IF(I.EQ.0) GOTO 250
29380 EI=KCHG(IABS(I),1)/3D0
29381 FACGQ=FGQ*EI**4
29382 DO 240 ISDE=1,2
29383 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
29384 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
29385 NCHN=NCHN+1
29386 ISIG(NCHN,ISDE)=I
29387 ISIG(NCHN,3-ISDE)=22
29388 ISIG(NCHN,3)=1
29389 SIGH(NCHN)=FACGQ
29390 240 CONTINUE
29391 250 CONTINUE
29392 ENDIF
29393
29394 ELSEIF(ISUB.LE.80) THEN
29395 IF(ISUB.EQ.53) THEN
29396C...g + g -> f + fbar (g + g -> q + qbar only)
29397 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
29398 IDC0=MDCY(21,2)-1
29399C...Begin by d, u, s flavours.
29400 FLAVWT=0D0
29401 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29402 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29403 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29404 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29405 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29406 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29407 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29408 & UH2/SH2)*FLAVWT*FACA
29409 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29410 & TH2/SH2)*FLAVWT*FACA
29411 NCHN=NCHN+1
29412 ISIG(NCHN,1)=21
29413 ISIG(NCHN,2)=21
29414 ISIG(NCHN,3)=1
29415 SIGH(NCHN)=FACQQ1
29416 NCHN=NCHN+1
29417 ISIG(NCHN,1)=21
29418 ISIG(NCHN,2)=21
29419 ISIG(NCHN,3)=2
29420 SIGH(NCHN)=FACQQ2
29421C...Next c and b flavours: modified that and uhat for fixed
29422C...cos(theta-hat).
29423 DO 260 IFL=4,5
29424 SQMAVG=PMAS(IFL,1)**2
29425 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29426 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29427 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29428 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29429 THUHQ=THQ*UHQ-SQMAVG*SH
29430 IF(MSTP(34).EQ.0) THEN
29431 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29432 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29433 ELSE
29434 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29435 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29436 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29437 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29438 ENDIF
29439 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29440 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29441 NCHN=NCHN+1
29442 ISIG(NCHN,1)=21
29443 ISIG(NCHN,2)=21
29444 ISIG(NCHN,3)=1+2*(IFL-3)
29445 SIGH(NCHN)=FACQQ1
29446 NCHN=NCHN+1
29447 ISIG(NCHN,1)=21
29448 ISIG(NCHN,2)=21
29449 ISIG(NCHN,3)=2+2*(IFL-3)
29450 SIGH(NCHN)=FACQQ2
29451 ENDIF
29452 260 CONTINUE
29453 270 CONTINUE
29454
29455 ELSEIF(ISUB.EQ.54) THEN
29456C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
29457 CALL PYWIDT(21,SH,WDTP,WDTE)
29458 WDTESU=0D0
29459 DO 280 I=1,MIN(8,MDCY(21,3))
29460 EF=KCHG(I,1)/3D0
29461 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29462 & WDTE(I,4))
29463 280 CONTINUE
29464 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
29465 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29466 NCHN=NCHN+1
29467 ISIG(NCHN,1)=21
29468 ISIG(NCHN,2)=22
29469 ISIG(NCHN,3)=1
29470 SIGH(NCHN)=FACQQ
29471 ENDIF
29472 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29473 NCHN=NCHN+1
29474 ISIG(NCHN,1)=22
29475 ISIG(NCHN,2)=21
29476 ISIG(NCHN,3)=1
29477 SIGH(NCHN)=FACQQ
29478 ENDIF
29479
29480 ELSEIF(ISUB.EQ.58) THEN
29481C...gamma + gamma -> f + fbar
29482 CALL PYWIDT(22,SH,WDTP,WDTE)
29483 WDTESU=0D0
29484 DO 290 I=1,MIN(12,MDCY(22,3))
29485 IF(I.LE.8) EF= KCHG(I,1)/3D0
29486 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29487 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29488 & WDTE(I,4))
29489 290 CONTINUE
29490 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
29491 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29492 NCHN=NCHN+1
29493 ISIG(NCHN,1)=22
29494 ISIG(NCHN,2)=22
29495 ISIG(NCHN,3)=1
29496 SIGH(NCHN)=FACFF
29497 ENDIF
29498
29499 ELSEIF(ISUB.EQ.68) THEN
29500C...g + g -> g + g
29501 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
29502 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
29503 & TH2/SH2)*FACA
29504 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
29505 & SH2/UH2)*FACA
29506 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
29507 & UH2/TH2)
29508 NCHN=NCHN+1
29509 ISIG(NCHN,1)=21
29510 ISIG(NCHN,2)=21
29511 ISIG(NCHN,3)=1
29512 SIGH(NCHN)=0.5D0*FACGG1
29513 NCHN=NCHN+1
29514 ISIG(NCHN,1)=21
29515 ISIG(NCHN,2)=21
29516 ISIG(NCHN,3)=2
29517 SIGH(NCHN)=0.5D0*FACGG2
29518 NCHN=NCHN+1
29519 ISIG(NCHN,1)=21
29520 ISIG(NCHN,2)=21
29521 ISIG(NCHN,3)=3
29522 SIGH(NCHN)=0.5D0*FACGG3
29523 300 CONTINUE
29524
29525 ELSEIF(ISUB.EQ.80) THEN
29526C...q + gamma -> q' + pi+/-
29527 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
29528 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
29529 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
29530 DELSH=UH*SQRT(ASSH*Q2FPSH)
29531 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
29532 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
29533 DELUH=SH*SQRT(ASUH*Q2FPUH)
29534 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
29535 IF(I.EQ.0) GOTO 320
29536 EI=KCHG(IABS(I),1)/3D0
29537 EJ=SIGN(1D0-ABS(EI),EI)
29538 DO 310 ISDE=1,2
29539 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
29540 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
29541 NCHN=NCHN+1
29542 ISIG(NCHN,ISDE)=I
29543 ISIG(NCHN,3-ISDE)=22
29544 ISIG(NCHN,3)=1
29545 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
29546 310 CONTINUE
29547 320 CONTINUE
29548 ENDIF
29549
29550 ELSEIF(ISUB.LE.100) THEN
29551 IF(ISUB.EQ.91) THEN
29552C...Elastic scattering
29553 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
29554
29555 ELSEIF(ISUB.EQ.92) THEN
29556C...Single diffractive scattering (first side, i.e. XB)
29557 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
29558
29559 ELSEIF(ISUB.EQ.93) THEN
29560C...Single diffractive scattering (second side, i.e. AX)
29561 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
29562
29563 ELSEIF(ISUB.EQ.94) THEN
29564C...Double diffractive scattering
29565 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
29566
29567 ELSEIF(ISUB.EQ.95) THEN
29568C...Low-pT scattering
29569 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
29570
29571 ELSEIF(ISUB.EQ.96) THEN
29572C...Multiple interactions: sum of QCD processes
29573 CALL PYWIDT(21,SH,WDTP,WDTE)
29574
29575C...q + q' -> q + q'
29576 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29577 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29578 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29579 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
29580 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
29581 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
29582 DO 340 I=-5,5
29583 IF(I.EQ.0) GOTO 340
29584 DO 330 J=-5,5
29585 IF(J.EQ.0) GOTO 330
29586 NCHN=NCHN+1
29587 ISIG(NCHN,1)=I
29588 ISIG(NCHN,2)=J
29589 ISIG(NCHN,3)=111
29590 SIGH(NCHN)=FACQQ1
29591 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29592 IF(I.EQ.J) THEN
29593 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
29594 NCHN=NCHN+1
29595 ISIG(NCHN,1)=I
29596 ISIG(NCHN,2)=J
29597 ISIG(NCHN,3)=112
29598 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
29599 ENDIF
29600 330 CONTINUE
29601 340 CONTINUE
29602
29603C...q + qbar -> q' + qbar' or g + g
29604 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29605 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
29606 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29607 & UH2/SH2)
29608 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29609 & TH2/SH2)
29610 DO 350 I=-5,5
29611 IF(I.EQ.0) GOTO 350
29612 NCHN=NCHN+1
29613 ISIG(NCHN,1)=I
29614 ISIG(NCHN,2)=-I
29615 ISIG(NCHN,3)=121
29616 SIGH(NCHN)=FACQQB
29617 NCHN=NCHN+1
29618 ISIG(NCHN,1)=I
29619 ISIG(NCHN,2)=-I
29620 ISIG(NCHN,3)=131
29621 SIGH(NCHN)=0.5D0*FACGG1
29622 NCHN=NCHN+1
29623 ISIG(NCHN,1)=I
29624 ISIG(NCHN,2)=-I
29625 ISIG(NCHN,3)=132
29626 SIGH(NCHN)=0.5D0*FACGG2
29627 350 CONTINUE
29628
29629C...q + g -> q + g
29630 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29631 & UH/SH)*FACA
29632 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29633 & SH/UH)
29634 DO 370 I=-5,5
29635 IF(I.EQ.0) GOTO 370
29636 DO 360 ISDE=1,2
29637 NCHN=NCHN+1
29638 ISIG(NCHN,ISDE)=I
29639 ISIG(NCHN,3-ISDE)=21
29640 ISIG(NCHN,3)=281
29641 SIGH(NCHN)=FACQG1
29642 NCHN=NCHN+1
29643 ISIG(NCHN,ISDE)=I
29644 ISIG(NCHN,3-ISDE)=21
29645 ISIG(NCHN,3)=282
29646 SIGH(NCHN)=FACQG2
29647 360 CONTINUE
29648 370 CONTINUE
29649
29650C...g + g -> q + qbar (only d, u, s)
29651 IDC0=MDCY(21,2)-1
29652 FLAVWT=0D0
29653 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29654 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29655 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29656 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29657 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29658 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29659 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29660 & UH2/SH2)*FLAVWT*FACA
29661 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29662 & TH2/SH2)*FLAVWT*FACA
29663 NCHN=NCHN+1
29664 ISIG(NCHN,1)=21
29665 ISIG(NCHN,2)=21
29666 ISIG(NCHN,3)=531
29667 SIGH(NCHN)=FACQQ1
29668 NCHN=NCHN+1
29669 ISIG(NCHN,1)=21
29670 ISIG(NCHN,2)=21
29671 ISIG(NCHN,3)=532
29672 SIGH(NCHN)=FACQQ2
29673
29674C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
29675C...cos(theta-hat)
29676 DO 380 IFL=4,5
29677 SQMAVG=PMAS(IFL,1)**2
29678 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29679 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29680 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29681 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29682 THUHQ=THQ*UHQ-SQMAVG*SH
29683 IF(MSTP(34).EQ.0) THEN
29684 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29685 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29686 ELSE
29687 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29688 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29689 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29690 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29691 ENDIF
29692 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29693 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29694 NCHN=NCHN+1
29695 ISIG(NCHN,1)=21
29696 ISIG(NCHN,2)=21
29697 ISIG(NCHN,3)=531+2*(IFL-3)
29698 SIGH(NCHN)=FACQQ1
29699 NCHN=NCHN+1
29700 ISIG(NCHN,1)=21
29701 ISIG(NCHN,2)=21
29702 ISIG(NCHN,3)=532+2*(IFL-3)
29703 SIGH(NCHN)=FACQQ2
29704 ENDIF
29705 380 CONTINUE
29706
29707C...g + g -> g + g
29708 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
29709 & 2D0*TH/SH+TH2/SH2)*FACA
29710 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
29711 & 2D0*SH/UH+SH2/UH2)*FACA
29712 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
29713 & 2D0*UH/TH+UH2/TH2)
29714 NCHN=NCHN+1
29715 ISIG(NCHN,1)=21
29716 ISIG(NCHN,2)=21
29717 ISIG(NCHN,3)=681
29718 SIGH(NCHN)=0.5D0*FACGG1
29719 NCHN=NCHN+1
29720 ISIG(NCHN,1)=21
29721 ISIG(NCHN,2)=21
29722 ISIG(NCHN,3)=682
29723 SIGH(NCHN)=0.5D0*FACGG2
29724 NCHN=NCHN+1
29725 ISIG(NCHN,1)=21
29726 ISIG(NCHN,2)=21
29727 ISIG(NCHN,3)=683
29728 SIGH(NCHN)=0.5D0*FACGG3
29729
29730 ELSEIF(ISUB.EQ.99) THEN
29731C...f + gamma* -> f.
29732 IF(MINT(107).EQ.4) THEN
29733 Q2GA=VINT(307)
29734 P2GA=VINT(308)
29735 ISDE=2
29736 ELSE
29737 Q2GA=VINT(308)
29738 P2GA=VINT(307)
29739 ISDE=1
29740 ENDIF
29741 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
29742 PM2RHO=PMAS(PYCOMP(113),1)**2
29743 IF(MSTP(19).EQ.0) THEN
29744 COMFAC=COMFAC/Q2GA
29745 ELSEIF(MSTP(19).EQ.1) THEN
29746 COMFAC=COMFAC/(Q2GA+PM2RHO)
29747 ELSEIF(MSTP(19).EQ.2) THEN
29748 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29749 ELSE
29750 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29751 W2GA=VINT(2)
29752 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
29753 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
29754 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
29755 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
29756 ELSE
29757 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
29758 & Q2GA**0.57D0)
29759 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
29760 ENDIF
29761 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
29762 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
29763 ENDIF
29764 DO 390 I=MMINA,MMAXA
29765 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
29766 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
29767 EI=KCHG(IABS(I),1)/3D0
29768 NCHN=NCHN+1
29769 ISIG(NCHN,ISDE)=I
29770 ISIG(NCHN,3-ISDE)=22
29771 ISIG(NCHN,3)=1
29772 SIGH(NCHN)=COMFAC*EI**2
29773 390 CONTINUE
29774 ENDIF
29775
29776 ELSE
29777 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
29778C...g + g -> gamma + gamma or g + g -> g + gamma
29779 A0STUR=0D0
29780 A0STUI=0D0
29781 A0TSUR=0D0
29782 A0TSUI=0D0
29783 A0UTSR=0D0
29784 A0UTSI=0D0
29785 A1STUR=0D0
29786 A1STUI=0D0
29787 A2STUR=0D0
29788 A2STUI=0D0
29789 ALST=LOG(-SH/TH)
29790 ALSU=LOG(-SH/UH)
29791 ALTU=LOG(TH/UH)
29792 IMAX=2*MSTP(1)
29793 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
29794 DO 400 I=1,IMAX
29795 EI=KCHG(IABS(I),1)/3D0
29796 EIWT=EI**2
29797 IF(ISUB.EQ.115) EIWT=EI
29798 SQMQ=PMAS(I,1)**2
29799 EPSS=4D0*SQMQ/SH
29800 EPST=4D0*SQMQ/TH
29801 EPSU=4D0*SQMQ/UH
29802 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
29803 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
29804 & PARU(1)**2)
29805 B0STUI=0D0
29806 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
29807 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
29808 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
29809 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
29810 B1STUR=-1D0
29811 B1STUI=0D0
29812 B2STUR=-1D0
29813 B2STUI=0D0
29814 ELSE
29815 CALL PYWAUX(1,EPSS,W1SR,W1SI)
29816 CALL PYWAUX(1,EPST,W1TR,W1TI)
29817 CALL PYWAUX(1,EPSU,W1UR,W1UI)
29818 CALL PYWAUX(2,EPSS,W2SR,W2SI)
29819 CALL PYWAUX(2,EPST,W2TR,W2TI)
29820 CALL PYWAUX(2,EPSU,W2UR,W2UI)
29821 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
29822 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
29823 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
29824 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
29825 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
29826 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
29827 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
29828 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
29829 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
29830 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
29831 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29832 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29833 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
29834 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
29835 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
29836 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
29837 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29838 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29839 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
29840 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
29841 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
29842 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
29843 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29844 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
29845 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
29846 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
29847 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
29848 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
29849 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29850 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
29851 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
29852 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
29853 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
29854 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
29855 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29856 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
29857 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
29858 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
29859 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
29860 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
29861 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29862 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
29863 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
29864 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
29865 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
29866 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29867 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
29868 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
29869 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
29870 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29871 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
29872 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
29873 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
29874 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
29875 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
29876 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
29877 ENDIF
29878 A0STUR=A0STUR+EIWT*B0STUR
29879 A0STUI=A0STUI+EIWT*B0STUI
29880 A0TSUR=A0TSUR+EIWT*B0TSUR
29881 A0TSUI=A0TSUI+EIWT*B0TSUI
29882 A0UTSR=A0UTSR+EIWT*B0UTSR
29883 A0UTSI=A0UTSI+EIWT*B0UTSI
29884 A1STUR=A1STUR+EIWT*B1STUR
29885 A1STUI=A1STUI+EIWT*B1STUI
29886 A2STUR=A2STUR+EIWT*B2STUR
29887 A2STUI=A2STUI+EIWT*B2STUI
29888 400 CONTINUE
29889 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
29890 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
29891 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
29892 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
29893 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
29894 NCHN=NCHN+1
29895 ISIG(NCHN,1)=21
29896 ISIG(NCHN,2)=21
29897 ISIG(NCHN,3)=1
29898 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
29899 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29900 410 CONTINUE
29901
29902 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29903C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29904 PH=0D0
29905 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29906 & PH=VINT(3)**2
29907 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29908 & PH=VINT(4)**2
29909 IF(ISUB.EQ.131) THEN
29910 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29911 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29912 ELSE
29913 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29914 ENDIF
29915 DO 430 I=MMINA,MMAXA
29916 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29917 EI=KCHG(IABS(I),1)/3D0
29918 FACGQ=FGQ*EI**2
29919 DO 420 ISDE=1,2
29920 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29921 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29922 NCHN=NCHN+1
29923 ISIG(NCHN,ISDE)=I
29924 ISIG(NCHN,3-ISDE)=22
29925 ISIG(NCHN,3)=1
29926 SIGH(NCHN)=FACGQ
29927 420 CONTINUE
29928 430 CONTINUE
29929
29930 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29931C...f + gamma*_(T,L) -> f + gamma
29932 PH=0D0
29933 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29934 & PH=VINT(3)**2
29935 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29936 & PH=VINT(4)**2
29937 IF(ISUB.EQ.133) THEN
29938 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29939 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29940 ELSE
29941 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29942 ENDIF
29943 DO 450 I=MMINA,MMAXA
29944 IF(I.EQ.0) GOTO 450
29945 EI=KCHG(IABS(I),1)/3D0
29946 FACGQ=FGQ*EI**4
29947 DO 440 ISDE=1,2
29948 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29949 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29950 NCHN=NCHN+1
29951 ISIG(NCHN,ISDE)=I
29952 ISIG(NCHN,3-ISDE)=22
29953 ISIG(NCHN,3)=1
29954 SIGH(NCHN)=FACGQ
29955 440 CONTINUE
29956 450 CONTINUE
29957
29958 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29959C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29960 PH=0D0
29961 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29962 & PH=VINT(3)**2
29963 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29964 & PH=VINT(4)**2
29965 CALL PYWIDT(21,SH,WDTP,WDTE)
29966 WDTESU=0D0
29967 DO 460 I=1,MIN(8,MDCY(21,3))
29968 EF=KCHG(I,1)/3D0
29969 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29970 & WDTE(I,4))
29971 460 CONTINUE
29972 IF(ISUB.EQ.135) THEN
29973 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29974 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29975 ELSE
29976 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29977 ENDIF
29978 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29979 NCHN=NCHN+1
29980 ISIG(NCHN,1)=21
29981 ISIG(NCHN,2)=22
29982 ISIG(NCHN,3)=1
29983 SIGH(NCHN)=FACQQ
29984 ENDIF
29985 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29986 NCHN=NCHN+1
29987 ISIG(NCHN,1)=22
29988 ISIG(NCHN,2)=21
29989 ISIG(NCHN,3)=1
29990 SIGH(NCHN)=FACQQ
29991 ENDIF
29992
29993 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
29994C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
29995 PH1=0D0
29996 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
29997 PH2=0D0
29998 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
29999 CALL PYWIDT(22,SH,WDTP,WDTE)
30000 WDTESU=0D0
30001 DO 470 I=1,MIN(12,MDCY(22,3))
30002 IF(I.LE.8) EF= KCHG(I,1)/3D0
30003 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30004 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30005 & WDTE(I,4))
30006 470 CONTINUE
30007 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30008 IF(ISUB.EQ.137) THEN
30009 FPARAM=-SH*(TH+UH)/DLAMB2
30010 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30011 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30012 & 2D0*PH1*PH2*FPARAM**2)
30013 ELSEIF(ISUB.EQ.138) THEN
30014 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30015 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30016 & 2D0*PH1**2*(TH-UH)**2)
30017 ELSEIF(ISUB.EQ.139) THEN
30018 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30019 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30020 & 2D0*PH2**2*(TH-UH)**2)
30021 ELSE
30022 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30023 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30024 ENDIF
30025 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30026 NCHN=NCHN+1
30027 ISIG(NCHN,1)=22
30028 ISIG(NCHN,2)=22
30029 ISIG(NCHN,3)=1
30030 SIGH(NCHN)=FACFF
30031 ENDIF
30032
30033 ENDIF
30034 ENDIF
30035
30036 RETURN
30037 END
30038
30039C*********************************************************************
30040
30041C...PYSGHF
30042C...Subprocess cross sections for heavy flavour production,
30043C...open and closed.
30044C...Auxiliary to PYSIGH.
30045
30046 SUBROUTINE PYSGHF(NCHN,SIGS)
30047
30048C...Double precision and integer declarations
30049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30050 IMPLICIT INTEGER(I-N)
30051 INTEGER PYK,PYCHGE,PYCOMP
30052C...Parameter statement to help give large particle numbers.
30053 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30054 &KEXCIT=4000000,KDIMEN=5000000)
30055C...Commonblocks
30056 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30057 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30058 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30059 COMMON/PYINT1/MINT(400),VINT(400)
30060 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30061 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30062 COMMON/PYINT4/MWID(500),WIDS(500,5)
30063 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30064 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30065 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30066 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30067 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30068 &/PYINT4/,/PYSGCM/
30069C...Local arrays
30070 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30071
30072C...Determine where are charmonium/bottomonium wave function parameters.
30073 IONIUM=140
30074 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30075
30076C...Convert bottomonium process into equivalent charmonium ones.
30077 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30078
30079C...Differential cross section expressions.
30080
30081 IF(ISUB.LE.100) THEN
30082 IF(ISUB.EQ.81) THEN
30083C...q + qbar -> Q + Qbar
30084 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30085 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30086 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30087 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30088 & 2D0*SQMAVG/SH)
30089 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30090 WID2=1D0
30091 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30092 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30093 FACQQB=FACQQB*WID2
30094 DO 100 I=MMINA,MMAXA
30095 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30096 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30097 NCHN=NCHN+1
30098 ISIG(NCHN,1)=I
30099 ISIG(NCHN,2)=-I
30100 ISIG(NCHN,3)=1
30101 SIGH(NCHN)=FACQQB
30102 100 CONTINUE
30103
30104 ELSEIF(ISUB.EQ.82) THEN
30105C...g + g -> Q + Qbar
30106 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30107 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30108 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30109 THUHQ=THQ*UHQ-SQMAVG*SH
30110 IF(MSTP(34).EQ.0) THEN
30111 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30112 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30113 ELSE
30114 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30115 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30116 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30117 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30118 ENDIF
30119 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30120 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30121 IF(MSTP(35).GE.1) THEN
30122 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30123 FACQQ1=FACQQ1*FATRE
30124 FACQQ2=FACQQ2*FATRE
30125 ENDIF
30126 WID2=1D0
30127 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30128 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30129 FACQQ1=FACQQ1*WID2
30130 FACQQ2=FACQQ2*WID2
30131 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
30132 NCHN=NCHN+1
30133 ISIG(NCHN,1)=21
30134 ISIG(NCHN,2)=21
30135 ISIG(NCHN,3)=1
30136 SIGH(NCHN)=FACQQ1
30137 NCHN=NCHN+1
30138 ISIG(NCHN,1)=21
30139 ISIG(NCHN,2)=21
30140 ISIG(NCHN,3)=2
30141 SIGH(NCHN)=FACQQ2
30142 110 CONTINUE
30143
30144 ELSEIF(ISUB.EQ.83) THEN
30145C...f + q -> f' + Q
30146 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
30147 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
30148 DO 130 I=MMIN1,MMAX1
30149 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
30150 DO 120 J=MMIN2,MMAX2
30151 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
30152 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
30153 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
30154 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
30155 & THEN
30156 NCHN=NCHN+1
30157 ISIG(NCHN,1)=I
30158 ISIG(NCHN,2)=J
30159 ISIG(NCHN,3)=1
30160 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30161 & (IABS(I)+1)/2)*VINT(180+J)
30162 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
30163 & (MINT(55)+1)/2)*VINT(180+J)
30164 WID2=1D0
30165 IF(I.GT.0) THEN
30166 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30167 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30168 & WIDS(MINT(55),2)
30169 ELSE
30170 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30171 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30172 & WIDS(MINT(55),3)
30173 ENDIF
30174 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30175 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30176 ENDIF
30177 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
30178 & THEN
30179 NCHN=NCHN+1
30180 ISIG(NCHN,1)=I
30181 ISIG(NCHN,2)=J
30182 ISIG(NCHN,3)=2
30183 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30184 & (IABS(J)+1)/2)*VINT(180+I)
30185 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
30186 & (MINT(55)+1)/2)*VINT(180+I)
30187 IF(J.GT.0) THEN
30188 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30189 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30190 & WIDS(MINT(55),2)
30191 ELSE
30192 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30193 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30194 & WIDS(MINT(55),3)
30195 ENDIF
30196 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30197 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30198 ENDIF
30199 120 CONTINUE
30200 130 CONTINUE
30201
30202 ELSEIF(ISUB.EQ.84) THEN
30203C...g + gamma -> Q + Qbar
30204 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30205 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30206 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30207 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
30208 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
30209 & (THQ*UHQ)
30210 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
30211 WID2=1D0
30212 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30213 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30214 FACQQ=FACQQ*WID2
30215 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30216 NCHN=NCHN+1
30217 ISIG(NCHN,1)=21
30218 ISIG(NCHN,2)=22
30219 ISIG(NCHN,3)=1
30220 SIGH(NCHN)=FACQQ
30221 ENDIF
30222 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30223 NCHN=NCHN+1
30224 ISIG(NCHN,1)=22
30225 ISIG(NCHN,2)=21
30226 ISIG(NCHN,3)=1
30227 SIGH(NCHN)=FACQQ
30228 ENDIF
30229
30230 ELSEIF(ISUB.EQ.85) THEN
30231C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
30232 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30233 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30234 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30235 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
30236 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
30237 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
30238 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
30239 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
30240 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
30241 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
30242 WID2=1D0
30243 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
30244 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
30245 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
30246 FACFF=FACFF*WID2
30247 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30248 NCHN=NCHN+1
30249 ISIG(NCHN,1)=22
30250 ISIG(NCHN,2)=22
30251 ISIG(NCHN,3)=1
30252 SIGH(NCHN)=FACFF
30253 ENDIF
30254
30255 ELSEIF(ISUB.EQ.86) THEN
30256C...g + g -> J/Psi + g
30257 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
30258 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30259 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30260 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30261 NCHN=NCHN+1
30262 ISIG(NCHN,1)=21
30263 ISIG(NCHN,2)=21
30264 ISIG(NCHN,3)=1
30265 SIGH(NCHN)=FACQQG
30266 ENDIF
30267
30268 ELSEIF(ISUB.EQ.87) THEN
30269C...g + g -> chi_0c + g
30270 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30271 QGTW=(SH*TH*UH)/SH**3
30272 RGTW=SQM3/SH
30273 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30274 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30275 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
30276 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
30277 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
30278 & (QGTW*(QGTW-RGTW*PGTW)**4)
30279 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30280 NCHN=NCHN+1
30281 ISIG(NCHN,1)=21
30282 ISIG(NCHN,2)=21
30283 ISIG(NCHN,3)=1
30284 SIGH(NCHN)=FACQQG
30285 ENDIF
30286
30287 ELSEIF(ISUB.EQ.88) THEN
30288C...g + g -> chi_1c + g
30289 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30290 QGTW=(SH*TH*UH)/SH**3
30291 RGTW=SQM3/SH
30292 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30293 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
30294 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
30295 & (QGTW-RGTW*PGTW)**4
30296 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30297 NCHN=NCHN+1
30298 ISIG(NCHN,1)=21
30299 ISIG(NCHN,2)=21
30300 ISIG(NCHN,3)=1
30301 SIGH(NCHN)=FACQQG
30302 ENDIF
30303
30304 ELSEIF(ISUB.EQ.89) THEN
30305C...g + g -> chi_2c + g
30306 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30307 QGTW=(SH*TH*UH)/SH**3
30308 RGTW=SQM3/SH
30309 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30310 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30311 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
30312 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
30313 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
30314 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30315 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30316 NCHN=NCHN+1
30317 ISIG(NCHN,1)=21
30318 ISIG(NCHN,2)=21
30319 ISIG(NCHN,3)=1
30320 SIGH(NCHN)=FACQQG
30321 ENDIF
30322 ENDIF
30323
30324 ELSEIF(ISUB.LE.200) THEN
30325 IF(ISUB.EQ.104) THEN
30326C...g + g -> chi_c0.
30327 KC=PYCOMP(10441)
30328 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
30329 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30330 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30331 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30332 NCHN=NCHN+1
30333 ISIG(NCHN,1)=21
30334 ISIG(NCHN,2)=21
30335 ISIG(NCHN,3)=1
30336 SIGH(NCHN)=FACBW
30337 ENDIF
30338
30339 ELSEIF(ISUB.EQ.105) THEN
30340C...g + g -> chi_c2.
30341 KC=PYCOMP(445)
30342 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
30343 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30344 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30345 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30346 NCHN=NCHN+1
30347 ISIG(NCHN,1)=21
30348 ISIG(NCHN,2)=21
30349 ISIG(NCHN,3)=1
30350 SIGH(NCHN)=FACBW
30351 ENDIF
30352
30353 ELSEIF(ISUB.EQ.106) THEN
30354C...g + g -> J/Psi + gamma.
30355 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30356 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
30357 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30358 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30359 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30360 NCHN=NCHN+1
30361 ISIG(NCHN,1)=21
30362 ISIG(NCHN,2)=21
30363 ISIG(NCHN,3)=1
30364 SIGH(NCHN)=FACQQG
30365 ENDIF
30366
30367 ELSEIF(ISUB.EQ.107) THEN
30368C...g + gamma -> J/Psi + g.
30369 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30370 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
30371 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30372 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30373 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30374 NCHN=NCHN+1
30375 ISIG(NCHN,1)=21
30376 ISIG(NCHN,2)=22
30377 ISIG(NCHN,3)=1
30378 SIGH(NCHN)=FACQQG
30379 ENDIF
30380 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30381 NCHN=NCHN+1
30382 ISIG(NCHN,1)=22
30383 ISIG(NCHN,2)=21
30384 ISIG(NCHN,3)=1
30385 SIGH(NCHN)=FACQQG
30386 ENDIF
30387
30388 ELSEIF(ISUB.EQ.108) THEN
30389C...gamma + gamma -> J/Psi + gamma.
30390 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30391 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
30392 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30393 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30394 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30395 NCHN=NCHN+1
30396 ISIG(NCHN,1)=22
30397 ISIG(NCHN,2)=22
30398 ISIG(NCHN,3)=1
30399 SIGH(NCHN)=FACQQG
30400 ENDIF
30401 ENDIF
30402
30403C...QUARKONIA+++
30404C...Additional code by Stefan Wolf
30405 ELSE
30406
30407C...Common code for quarkonium production.
30408 SHTH=SH+TH
30409 THUH=TH+UH
30410 UHSH=UH+SH
30411 SHTH2=SHTH**2
30412 THUH2=THUH**2
30413 UHSH2=UHSH**2
30414 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
30415 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
30416 SQMQQ=SQM3
30417 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
30418 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
30419 SQMQQ=SQM4
30420 ENDIF
30421 SQMQQR=SQRT(SQMQQ)
30422 IF(MSTP(145).EQ.1) THEN
30423 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
30424 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
30425 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
30426 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
30427 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30428 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30429 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30430 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30431 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
30432 & ISUB.GE.437) THEN
30433 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
30434 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
30435 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30436 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30437 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30438 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30439 ENDIF
30440 AQ2=AQ**2
30441 BQ2=BQ**2
30442 SMQQ2=SQMQQ*VINT(2)
30443C...Polarisation frames
30444 IF(MSTP(146).EQ.1) THEN
30445C...Recoil frame
30446 POLH1=SQRT(AQ2-SMQQ2)
30447 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30448 AZ=-SQMQQR/POLH1
30449 BZ=0D0
30450 AX=AQ*BQ/(POLH1*POLH2)
30451 BX=-POLH1/POLH2
30452 ELSEIF(MSTP(146).EQ.2) THEN
30453C...Gottfried Jackson frame
30454 POLH1=AQ+BQ
30455 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30456 AZ=SQMQQR/POLH1
30457 BZ=AZ
30458 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
30459 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
30460 ELSEIF(MSTP(146).EQ.3) THEN
30461C...Target frame
30462 POLH1=AQ-BQ
30463 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30464 AZ=-SQMQQR/POLH1
30465 BZ=-AZ
30466 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
30467 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
30468 ELSEIF(MSTP(146).EQ.4) THEN
30469C...Collins Soper frame
30470 POLH1=AQ2-BQ2
30471 POLH2=SQRT(VINT(2)*POLH1)
30472 AZ=-BQ/POLH2
30473 BZ=AQ/POLH2
30474 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
30475 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
30476 ENDIF
30477C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
30478 EL1K10=AZ*ATILK1+BZ*BTILK1
30479 EL1K20=AZ*ATILK2+BZ*BTILK2
30480 EL2K10=EL1K10
30481 EL2K20=EL1K20
30482 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
30483 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
30484 EL2K11=EL1K11
30485 EL2K21=EL1K21
30486 ENDIF
30487
30488 IF(ISUB.EQ.421) THEN
30489C...g + g -> QQ~[3S11] + g
30490 IF(MSTP(145).EQ.0) THEN
30491* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30492* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
30493 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30494 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
30495* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30496* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
30497 ELSE
30498 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
30499 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30500 BB=2D0*(SH2+TH2)
30501 CC=2D0*(SH2+UH2)
30502 DD=2D0*SH2
30503 IF(MSTP(147).EQ.0) THEN
30504 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30505 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30506 ELSEIF(MSTP(147).EQ.1) THEN
30507 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30508 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30509 ELSEIF(MSTP(147).EQ.3) THEN
30510 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30511 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30512 ELSEIF(MSTP(147).EQ.4) THEN
30513 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30514 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30515 ELSEIF(MSTP(147).EQ.5) THEN
30516 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30517 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30518 ELSEIF(MSTP(147).EQ.6) THEN
30519 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30520 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30521 ENDIF
30522 FACQQG=COMFAC*FF*FACQQG
30523 ENDIF
30524 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30525 NCHN=NCHN+1
30526 ISIG(NCHN,1)=21
30527 ISIG(NCHN,2)=21
30528 ISIG(NCHN,3)=1
30529 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
30530 ENDIF
30531
30532 ELSEIF(ISUB.EQ.422) THEN
30533C...g + g -> QQ~[3S18] + g
30534 IF(MSTP(145).EQ.0) THEN
30535 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
30536 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30537 & (SQMQQ*SQMQQR)*
30538 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
30539 ELSE
30540 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30541 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
30542 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30543 BB=2D0*(SH2+TH2)
30544 CC=2D0*(SH2+UH2)
30545 DD=2D0*SH2
30546 IF(MSTP(147).EQ.0) THEN
30547 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30548 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30549 ELSEIF(MSTP(147).EQ.1) THEN
30550 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30551 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30552 ELSEIF(MSTP(147).EQ.3) THEN
30553 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30554 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30555 ELSEIF(MSTP(147).EQ.4) THEN
30556 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30557 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30558 ELSEIF(MSTP(147).EQ.5) THEN
30559 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30560 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30561 ELSEIF(MSTP(147).EQ.6) THEN
30562 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30563 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30564 ENDIF
30565 FACQQG=COMFAC*FF*FACQQG
30566 ENDIF
30567C...Split total contribution into different colour flows just like
30568C...in g g -> g g (recalculate kinematics for massless partons).
30569 THP=-0.5D0*SH*(1D0-CTH)
30570 UHP=-0.5D0*SH*(1D0+CTH)
30571 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30572 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30573 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30574 FACGGS=FACGG1+FACGG2+FACGG3
30575 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30576 NCHN=NCHN+1
30577 ISIG(NCHN,1)=21
30578 ISIG(NCHN,2)=21
30579 ISIG(NCHN,3)=1
30580 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30581 NCHN=NCHN+1
30582 ISIG(NCHN,1)=21
30583 ISIG(NCHN,2)=21
30584 ISIG(NCHN,3)=2
30585 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30586 NCHN=NCHN+1
30587 ISIG(NCHN,1)=21
30588 ISIG(NCHN,2)=21
30589 ISIG(NCHN,3)=3
30590 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
30591 ENDIF
30592
30593 ELSEIF(ISUB.EQ.423) THEN
30594C...g + g -> QQ~[1S08] + g
30595 IF(MSTP(145).EQ.0) THEN
30596* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
30597* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
30598* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
30599* & (SHTH2*THUH2*UHSH2)
30600 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
30601 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30602 & TH2/(SHTH2*THUH2))*
30603 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30604 ELSE
30605 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
30606 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30607 & TH2/(SHTH2*THUH2))*
30608 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30609 IF(MSTP(147).EQ.0) THEN
30610 FACQQG=COMFAC*FA
30611 ELSEIF(MSTP(147).EQ.1) THEN
30612 FACQQG=COMFAC*2D0*FA
30613 ELSEIF(MSTP(147).EQ.3) THEN
30614 FACQQG=COMFAC*FA
30615 ELSEIF(MSTP(147).EQ.4) THEN
30616 FACQQG=COMFAC*FA
30617 ELSEIF(MSTP(147).EQ.5) THEN
30618 FACQQG=0D0
30619 ELSEIF(MSTP(147).EQ.6) THEN
30620 FACQQG=0D0
30621 ENDIF
30622 ENDIF
30623C...Split total contribution into different colour flows just like
30624C...in g g -> g g (recalculate kinematics for massless partons).
30625 THP=-0.5D0*SH*(1D0-CTH)
30626 UHP=-0.5D0*SH*(1D0+CTH)
30627 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30628 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30629 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30630 FACGGS=FACGG1+FACGG2+FACGG3
30631 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30632 NCHN=NCHN+1
30633 ISIG(NCHN,1)=21
30634 ISIG(NCHN,2)=21
30635 ISIG(NCHN,3)=1
30636 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30637 NCHN=NCHN+1
30638 ISIG(NCHN,1)=21
30639 ISIG(NCHN,2)=21
30640 ISIG(NCHN,3)=2
30641 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30642 NCHN=NCHN+1
30643 ISIG(NCHN,1)=21
30644 ISIG(NCHN,2)=21
30645 ISIG(NCHN,3)=3
30646 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
30647 ENDIF
30648
30649 ELSEIF(ISUB.EQ.424) THEN
30650C...g + g -> QQ~[3PJ8] + g
30651 POLY=SH2+SH*TH+TH2
30652 IF(MSTP(145).EQ.0) THEN
30653 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
30654 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
30655 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
30656 & +7D0*TH**6)
30657 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
30658 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
30659 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
30660 & +35D0*TH**8)
30661 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
30662 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
30663 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
30664 & +84D0*TH**8)
30665 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
30666 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
30667 & +451D0*SH*TH**5+126D0*TH**6)
30668 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
30669 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
30670 & +171D0*SH*TH**5+42D0*TH**6)
30671 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
30672 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
30673 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
30674 & +99D0*SH*TH**3+35D0*TH**4)
30675 & +7D0*SQMQQ**8*SHTH*POLY)/
30676 & (SH*TH*UH*SQMQQR*SQMQQ*
30677 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30678 ELSE
30679 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
30680 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30681 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
30682 & -SQMQQ*SHTH2*POLY**2*
30683 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
30684 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
30685 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
30686 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
30687 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
30688 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
30689 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
30690 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
30691 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
30692 & +145D0*SH*TH**5+34D0*TH**6)
30693 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
30694 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
30695 & +44D0*TH**6)
30696 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
30697 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
30698 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
30699 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
30700 & +3D0*SQMQQ**8*SHTH*POLY)
30701 BB=4D0*SHTH2*POLY**3
30702 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
30703 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
30704 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
30705 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
30706 & +84D0*SH*TH**9+20D0*TH**10)
30707 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
30708 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
30709 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
30710 & +40D0*TH**8)
30711 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
30712 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
30713 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
30714 & +40D0*TH**8)
30715 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
30716 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
30717 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
30718 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
30719 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
30720 & +4D0*TH**6)
30721 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
30722 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
30723 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
30724 CC=4D0*TH2*POLY**3
30725 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
30726 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
30727 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
30728 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
30729 & +28D0*TH**9)
30730 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
30731 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
30732 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
30733 & +394D0*SH*TH**9+84D0*TH**10)
30734 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
30735 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
30736 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
30737 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
30738 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
30739 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
30740 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
30741 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
30742 & +266D0*SH*TH**6+84D0*TH**7)
30743 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
30744 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
30745 & +28D0*TH**6)
30746 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
30747 & +7D0*SH*TH**3+4*TH**4)
30748 & +SQMQQ**8*SH*(SH-TH)**2*TH
30749 DD=2D0*TH2*SHTH2*POLY**3
30750 & *(-SH2+2*SH*TH+2*TH2)
30751 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
30752 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
30753 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
30754 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
30755 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
30756 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
30757 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
30758 & -210D0*SH*TH**8-60D0*TH**9)
30759 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
30760 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
30761 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
30762 & -80D0*TH**8)
30763 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
30764 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
30765 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
30766 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
30767 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
30768 & -30D0*SH*TH**6-24D0*TH**7)
30769 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
30770 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
30771 & -4D0*TH**6)
30772 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
30773 IF(MSTP(147).EQ.0) THEN
30774 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30775 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30776 ELSEIF(MSTP(147).EQ.1) THEN
30777 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30778 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30779 ELSEIF(MSTP(147).EQ.3) THEN
30780 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30781 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30782 ELSEIF(MSTP(147).EQ.4) THEN
30783 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30784 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30785 ELSEIF(MSTP(147).EQ.5) THEN
30786 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30787 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30788 ELSEIF(MSTP(147).EQ.6) THEN
30789 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30790 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30791 ENDIF
30792 FACQQG=COMFAC*FF*FACQQG
30793 ENDIF
30794C...Split total contribution into different colour flows just like
30795C...in g g -> g g (recalculate kinematics for massless partons).
30796 THP=-0.5D0*SH*(1D0-CTH)
30797 UHP=-0.5D0*SH*(1D0+CTH)
30798 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30799 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30800 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30801 FACGGS=FACGG1+FACGG2+FACGG3
30802 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30803 NCHN=NCHN+1
30804 ISIG(NCHN,1)=21
30805 ISIG(NCHN,2)=21
30806 ISIG(NCHN,3)=1
30807 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30808 NCHN=NCHN+1
30809 ISIG(NCHN,1)=21
30810 ISIG(NCHN,2)=21
30811 ISIG(NCHN,3)=2
30812 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30813 NCHN=NCHN+1
30814 ISIG(NCHN,1)=21
30815 ISIG(NCHN,2)=21
30816 ISIG(NCHN,3)=3
30817 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
30818 ENDIF
30819
30820 ELSEIF(ISUB.EQ.425) THEN
30821C...q + g -> q + QQ~[3S18]
30822 IF(MSTP(145).EQ.0) THEN
30823 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
30824 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
30825 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
30826 ELSE
30827 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
30828 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
30829 AA=SHTH2+THUH2
30830 BB=4D0
30831 CC=8D0
30832 DD=4D0
30833 IF(MSTP(147).EQ.0) THEN
30834 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30835 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30836 ELSEIF(MSTP(147).EQ.1) THEN
30837 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30838 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30839 ELSEIF(MSTP(147).EQ.3) THEN
30840 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30841 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30842 ELSEIF(MSTP(147).EQ.4) THEN
30843 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30844 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30845 ELSEIF(MSTP(147).EQ.5) THEN
30846 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30847 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30848 ELSEIF(MSTP(147).EQ.6) THEN
30849 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30850 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30851 ENDIF
30852 FACQQG=COMFAC*FF*FACQQG
30853 ENDIF
30854C...Split total contribution into different colour flows just like
30855C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30856C...(recalculate kinematics for massless partons).
30857 THP=-0.5D0*SH*(1D0-CTH)
30858 UHP=-0.5D0*SH*(1D0+CTH)
30859 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30860 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30861 FACQGS=FACQG1+FACQG2
30862 DO 2442 I=MMINA,MMAXA
30863 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
30864 DO 2441 ISDE=1,2
30865 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
30866 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
30867 NCHN=NCHN+1
30868 ISIG(NCHN,ISDE)=I
30869 ISIG(NCHN,3-ISDE)=21
30870 ISIG(NCHN,3)=1
30871 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
30872 NCHN=NCHN+1
30873 ISIG(NCHN,ISDE)=I
30874 ISIG(NCHN,3-ISDE)=21
30875 ISIG(NCHN,3)=2
30876 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
30877 2441 CONTINUE
30878 2442 CONTINUE
30879
30880 ELSEIF(ISUB.EQ.426) THEN
30881C...q + g -> q + QQ~[1S08]
30882 IF(MSTP(145).EQ.0) THEN
30883 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
30884 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
30885 ELSE
30886 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
30887 IF(MSTP(147).EQ.0) THEN
30888 FACQQG=COMFAC*FA
30889 ELSEIF(MSTP(147).EQ.1) THEN
30890 FACQQG=COMFAC*2D0*FA
30891 ELSEIF(MSTP(147).EQ.3) THEN
30892 FACQQG=COMFAC*FA
30893 ELSEIF(MSTP(147).EQ.4) THEN
30894 FACQQG=COMFAC*FA
30895 ELSEIF(MSTP(147).EQ.5) THEN
30896 FACQQG=0D0
30897 ELSEIF(MSTP(147).EQ.6) THEN
30898 FACQQG=0D0
30899 ENDIF
30900 ENDIF
30901C...Split total contribution into different colour flows just like
30902C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30903C...(recalculate kinematics for massless partons).
30904 THP=-0.5D0*SH*(1D0-CTH)
30905 UHP=-0.5D0*SH*(1D0+CTH)
30906 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30907 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30908 FACQGS=FACQG1+FACQG2
30909 DO 2444 I=MMINA,MMAXA
30910 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30911 DO 2443 ISDE=1,2
30912 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30913 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30914 NCHN=NCHN+1
30915 ISIG(NCHN,ISDE)=I
30916 ISIG(NCHN,3-ISDE)=21
30917 ISIG(NCHN,3)=1
30918 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30919 NCHN=NCHN+1
30920 ISIG(NCHN,ISDE)=I
30921 ISIG(NCHN,3-ISDE)=21
30922 ISIG(NCHN,3)=2
30923 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30924 2443 CONTINUE
30925 2444 CONTINUE
30926
30927 ELSEIF(ISUB.EQ.427) THEN
30928C...q + g -> q + QQ~[3PJ8]
30929 IF(MSTP(145).EQ.0) THEN
30930 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30931 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30932 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30933 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30934 ELSE
30935 FF=10D0*PARU(1)*AS**3/
30936 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30937 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30938 BB=8D0*(SHTH2+TH*UH)
30939 CC=8D0*UHSH*(SHTH+THUH)
30940 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30941 IF(MSTP(147).EQ.0) THEN
30942 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30943 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30944 ELSEIF(MSTP(147).EQ.1) THEN
30945 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30946 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30947 ELSEIF(MSTP(147).EQ.3) THEN
30948 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30949 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30950 ELSEIF(MSTP(147).EQ.4) THEN
30951 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30952 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30953 ELSEIF(MSTP(147).EQ.5) THEN
30954 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30955 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30956 ELSEIF(MSTP(147).EQ.6) THEN
30957 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30958 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30959 ENDIF
30960 FACQQG=COMFAC*FF*FACQQG
30961 ENDIF
30962C...Split total contribution into different colour flows just like
30963C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30964C...(recalculate kinematics for massless partons).
30965 THP=-0.5D0*SH*(1D0-CTH)
30966 UHP=-0.5D0*SH*(1D0+CTH)
30967 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30968 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30969 FACQGS=FACQG1+FACQG2
30970 DO 2446 I=MMINA,MMAXA
30971 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30972 DO 2445 ISDE=1,2
30973 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30974 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30975 NCHN=NCHN+1
30976 ISIG(NCHN,ISDE)=I
30977 ISIG(NCHN,3-ISDE)=21
30978 ISIG(NCHN,3)=1
30979 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
30980 NCHN=NCHN+1
30981 ISIG(NCHN,ISDE)=I
30982 ISIG(NCHN,3-ISDE)=21
30983 ISIG(NCHN,3)=2
30984 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
30985 2445 CONTINUE
30986 2446 CONTINUE
30987
30988 ELSEIF(ISUB.EQ.428) THEN
30989C...q + q~ -> g + QQ~[3S18]
30990 IF(MSTP(145).EQ.0) THEN
30991 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
30992 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
30993 & (SQMQQ*SQMQQR*TH*UH*THUH2)
30994 ELSE
30995 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
30996 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
30997 AA=SHTH2+UHSH2
30998 BB=4D0
30999 CC=4D0
31000 DD=0D0
31001 IF(MSTP(147).EQ.0) THEN
31002 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31003 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31004 ELSEIF(MSTP(147).EQ.1) THEN
31005 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31006 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31007 ELSEIF(MSTP(147).EQ.3) THEN
31008 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31009 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31010 ELSEIF(MSTP(147).EQ.4) THEN
31011 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31012 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31013 ELSEIF(MSTP(147).EQ.5) THEN
31014 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31015 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31016 ELSEIF(MSTP(147).EQ.6) THEN
31017 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31018 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31019 ENDIF
31020 FACQQG=COMFAC*FF*FACQQG
31021 ENDIF
31022C...Split total contribution into different colour flows just like
31023C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31024C...(recalculate kinematics for massless partons).
31025 THP=-0.5D0*SH*(1D0-CTH)
31026 UHP=-0.5D0*SH*(1D0+CTH)
31027 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31028 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31029 FACGGS=FACGG1+FACGG2
31030 DO 2447 I=MMINA,MMAXA
31031 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31032 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31033 NCHN=NCHN+1
31034 ISIG(NCHN,1)=I
31035 ISIG(NCHN,2)=-I
31036 ISIG(NCHN,3)=1
31037 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31038 NCHN=NCHN+1
31039 ISIG(NCHN,1)=I
31040 ISIG(NCHN,2)=-I
31041 ISIG(NCHN,3)=2
31042 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31043 2447 CONTINUE
31044
31045 ELSEIF(ISUB.EQ.429) THEN
31046C...q + q~ -> g + QQ~[1S08]
31047 IF(MSTP(145).EQ.0) THEN
31048 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31049 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31050 ELSE
31051 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31052 IF(MSTP(147).EQ.0) THEN
31053 FACQQG=COMFAC*FA
31054 ELSEIF(MSTP(147).EQ.1) THEN
31055 FACQQG=COMFAC*2D0*FA
31056 ELSEIF(MSTP(147).EQ.3) THEN
31057 FACQQG=COMFAC*FA
31058 ELSEIF(MSTP(147).EQ.4) THEN
31059 FACQQG=COMFAC*FA
31060 ELSEIF(MSTP(147).EQ.5) THEN
31061 FACQQG=0D0
31062 ELSEIF(MSTP(147).EQ.6) THEN
31063 FACQQG=0D0
31064 ENDIF
31065 ENDIF
31066C...Split total contribution into different colour flows just like
31067C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31068C...(recalculate kinematics for massless partons).
31069 THP=-0.5D0*SH*(1D0-CTH)
31070 UHP=-0.5D0*SH*(1D0+CTH)
31071 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31072 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31073 FACGGS=FACGG1+FACGG2
31074 DO 2448 I=MMINA,MMAXA
31075 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31076 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31077 NCHN=NCHN+1
31078 ISIG(NCHN,1)=I
31079 ISIG(NCHN,2)=-I
31080 ISIG(NCHN,3)=1
31081 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31082 NCHN=NCHN+1
31083 ISIG(NCHN,1)=I
31084 ISIG(NCHN,2)=-I
31085 ISIG(NCHN,3)=2
31086 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31087 2448 CONTINUE
31088
31089 ELSEIF(ISUB.EQ.430) THEN
31090C...q + q~ -> g + QQ~[3PJ8]
31091 IF(MSTP(145).EQ.0) THEN
31092 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31093 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31094 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31095 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31096 ELSE
31097 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31098 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31099 BB=8D0*(UHSH2+SH*TH)
31100 CC=8D0*(SHTH2+SH*UH)
31101 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31102 IF(MSTP(147).EQ.0) THEN
31103 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31104 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31105 ELSEIF(MSTP(147).EQ.1) THEN
31106 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31107 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31108 ELSEIF(MSTP(147).EQ.3) THEN
31109 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31110 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31111 ELSEIF(MSTP(147).EQ.4) THEN
31112 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31113 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31114 ELSEIF(MSTP(147).EQ.5) THEN
31115 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31116 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31117 ELSEIF(MSTP(147).EQ.6) THEN
31118 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31119 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31120 ENDIF
31121 FACQQG=COMFAC*FF*FACQQG
31122 ENDIF
31123C...Split total contribution into different colour flows just like
31124C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31125C...(recalculate kinematics for massless partons).
31126 THP=-0.5D0*SH*(1D0-CTH)
31127 UHP=-0.5D0*SH*(1D0+CTH)
31128 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31129 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31130 FACGGS=FACGG1+FACGG2
31131 DO 2449 I=MMINA,MMAXA
31132 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31133 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
31134 NCHN=NCHN+1
31135 ISIG(NCHN,1)=I
31136 ISIG(NCHN,2)=-I
31137 ISIG(NCHN,3)=1
31138 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31139 NCHN=NCHN+1
31140 ISIG(NCHN,1)=I
31141 ISIG(NCHN,2)=-I
31142 ISIG(NCHN,3)=2
31143 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31144 2449 CONTINUE
31145
31146 ELSEIF(ISUB.EQ.431) THEN
31147C...g + g -> QQ~[3P01] + g
31148 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31149 QGTW=(SH*TH*UH)/SH**3
31150 RGTW=SQMQQ/SH
31151 IF(MSTP(145).EQ.0) THEN
31152 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31153 & (9D0*RGTW**2*PGTW**4*
31154 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31155 & -6D0*RGTW*PGTW**3*QGTW*
31156 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31157 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31158 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31159 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31160 ELSE
31161 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
31162 & (9D0*RGTW**2*PGTW**4*
31163 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31164 & -6D0*RGTW*PGTW**3*QGTW*
31165 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31166 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31167 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31168 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31169 IF(MSTP(147).EQ.0) THEN
31170 FACQQG=COMFAC*FC1
31171 ELSEIF(MSTP(147).EQ.1) THEN
31172 FACQQG=COMFAC*2D0*FC1
31173 ELSEIF(MSTP(147).EQ.3) THEN
31174 FACQQG=COMFAC*FC1
31175 ELSEIF(MSTP(147).EQ.4) THEN
31176 FACQQG=COMFAC*FC1
31177 ELSEIF(MSTP(147).EQ.5) THEN
31178 FACQQG=0D0
31179 ELSEIF(MSTP(147).EQ.6) THEN
31180 FACQQG=0D0
31181 ENDIF
31182 ENDIF
31183 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31184 NCHN=NCHN+1
31185 ISIG(NCHN,1)=21
31186 ISIG(NCHN,2)=21
31187 ISIG(NCHN,3)=1
31188 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31189 ENDIF
31190
31191 ELSEIF(ISUB.EQ.432) THEN
31192C...g + g -> QQ~[3P11] + g
31193 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31194 QGTW=(SH*TH*UH)/SH**3
31195 RGTW=SQMQQ/SH
31196 IF(MSTP(145).EQ.0) THEN
31197 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
31198 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
31199 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
31200 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
31201 ELSE
31202 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
31203 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
31204 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
31205 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
31206 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
31207 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31208 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31209 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
31210 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31211 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31212 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
31213 C4=-4D0*THUH*(TH-UH)**2*
31214 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
31215 & -SH2*TH*UH*(TH2+UH2))
31216 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
31217 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
31218 & +SH2*(5D0*THUH2-17D0*TH*UH)))
31219 IF(MSTP(147).EQ.0) THEN
31220 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31221 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31222 ELSEIF(MSTP(147).EQ.1) THEN
31223 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31224 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31225 ELSEIF(MSTP(147).EQ.3) THEN
31226 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31227 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31228 ELSEIF(MSTP(147).EQ.4) THEN
31229 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31230 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31231 ELSEIF(MSTP(147).EQ.5) THEN
31232 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31233 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31234 ELSEIF(MSTP(147).EQ.6) THEN
31235 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31236 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31237 ENDIF
31238 FACQQG=COMFAC*FF*FACQQG
31239 ENDIF
31240 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31241 NCHN=NCHN+1
31242 ISIG(NCHN,1)=21
31243 ISIG(NCHN,2)=21
31244 ISIG(NCHN,3)=1
31245 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31246 ENDIF
31247
31248 ELSEIF(ISUB.EQ.433) THEN
31249C...g + g -> QQ~[3P21] + g
31250 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31251 QGTW=(SH*TH*UH)/SH**3
31252 RGTW=SQMQQ/SH
31253 IF(MSTP(145).EQ.0) THEN
31254 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31255 & (12D0*RGTW**2*PGTW**4*
31256 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31257 & -3D0*RGTW*PGTW**3*QGTW*
31258 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
31259 & +2D0*PGTW**2*QGTW**2*
31260 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
31261 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
31262 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31263 ELSE
31264 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
31265 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
31266 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
31267 & *SH*SH2**7
31268 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
31269 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
31270 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
31271 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
31272 & +10D0*(SH2**2+TH2**2))
31273 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
31274 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
31275 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
31276 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
31277 & +4D0*SH*TH*UH2**4*SHTH2)
31278 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
31279 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
31280 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
31281 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
31282 & +10D0*(SH2**2+UH2**2))
31283 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
31284 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
31285 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
31286 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
31287 & +4D0*SH*UH*TH2**4*UHSH2)
31288 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
31289 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
31290 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
31291 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
31292 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
31293 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
31294 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
31295 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
31296 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
31297 & +3D0*(TH2**3+UH2**3)))
31298 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
31299 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
31300 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
31301 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
31302 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
31303 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
31304 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
31305 & 82D0*TH**3)
31306 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
31307 & +45D0*TH**3)
31308 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
31309 & 8D0*TH**3)
31310 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
31311 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
31312 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
31313 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
31314 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
31315 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
31316 & 82D0*UH**3)
31317 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
31318 & +45D0*UH**3)
31319 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
31320 & 8D0*UH**3)
31321 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
31322 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
31323 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
31324 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
31325 & +4D0*SH*TH2**2*UH2**2*THUH2
31326 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
31327 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
31328 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
31329 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
31330 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31331 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
31332 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
31333 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
31334 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
31335 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
31336 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
31337 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
31338 & +2D0*(TH2**3+UH2**3))
31339 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
31340 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
31341 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
31342 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31343 IF(MSTP(147).EQ.0) THEN
31344 FACQQG=1D0/3D0*(C1*3D0
31345 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31346 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31347 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31348 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31349 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31350 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31351 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31352 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31353 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31354 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31355 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31356 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31357 ELSEIF(MSTP(147).EQ.1) THEN
31358 FACQQG=C1*2D0
31359 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31360 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31361 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31362 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31363 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31364 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31365 & +EL1K10*EL2K20*EL1K11*EL2K11)
31366 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31367 & +EL1K10*EL2K20*EL1K21*EL2K21)
31368 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31369 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31370 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31371 & +EL1K20*EL2K20*EL1K11*EL2K11)
31372 ELSEIF(MSTP(147).EQ.2) THEN
31373 FACQQG=2D0*(C1
31374 & -C2*EL1K11*EL2K11
31375 & -C3*EL1K21*EL2K21
31376 & -C4*EL1K11*EL2K21
31377 & +C5*(EL1K11*EL2K11)**2
31378 & +C6*(EL1K21*EL2K21)**2
31379 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31380 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31381 & +(C9+C0)*(EL1K11*EL2K21)**2)
31382 ENDIF
31383 FACQQG=COMFAC*FF*FACQQG
31384 ENDIF
31385 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31386 NCHN=NCHN+1
31387 ISIG(NCHN,1)=21
31388 ISIG(NCHN,2)=21
31389 ISIG(NCHN,3)=1
31390 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31391 ENDIF
31392
31393 ELSEIF(ISUB.EQ.434) THEN
31394C...q + g -> q + QQ~[3P01]
31395 IF(MSTP(145).EQ.0) THEN
31396 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
31397 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31398 ELSE
31399 FA=-PARU(1)*AS**3*(16D0/243D0)*
31400 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31401 IF(MSTP(147).EQ.0) THEN
31402 FACQQG=COMFAC*FA
31403 ELSEIF(MSTP(147).EQ.1) THEN
31404 FACQQG=COMFAC*2D0*FA
31405 ELSEIF(MSTP(147).EQ.3) THEN
31406 FACQQG=COMFAC*FA
31407 ELSEIF(MSTP(147).EQ.4) THEN
31408 FACQQG=COMFAC*FA
31409 ELSEIF(MSTP(147).EQ.5) THEN
31410 FACQQG=0D0
31411 ELSEIF(MSTP(147).EQ.6) THEN
31412 FACQQG=0D0
31413 ENDIF
31414 ENDIF
31415 DO 2452 I=MMINA,MMAXA
31416 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
31417 DO 2451 ISDE=1,2
31418 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
31419 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
31420 NCHN=NCHN+1
31421 ISIG(NCHN,ISDE)=I
31422 ISIG(NCHN,3-ISDE)=21
31423 ISIG(NCHN,3)=1
31424 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31425 2451 CONTINUE
31426 2452 CONTINUE
31427
31428 ELSEIF(ISUB.EQ.435) THEN
31429C...q + g -> q + QQ~[3P11]
31430 IF(MSTP(145).EQ.0) THEN
31431 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
31432 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
31433 ELSE
31434 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
31435 C1=SH*UH
31436 C2=2D0*SH
31437 C3=0D0
31438 C4=2D0*(SH-UH)
31439 IF(MSTP(147).EQ.0) THEN
31440 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31441 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31442 ELSEIF(MSTP(147).EQ.1) THEN
31443 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31444 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31445 ELSEIF(MSTP(147).EQ.3) THEN
31446 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31447 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31448 ELSEIF(MSTP(147).EQ.4) THEN
31449 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31450 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31451 ELSEIF(MSTP(147).EQ.5) THEN
31452 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31453 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31454 ELSEIF(MSTP(147).EQ.6) THEN
31455 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31456 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31457 ENDIF
31458 FACQQG=COMFAC*FF*FACQQG
31459 ENDIF
31460 DO 2454 I=MMINA,MMAXA
31461 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
31462 DO 2453 ISDE=1,2
31463 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
31464 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
31465 NCHN=NCHN+1
31466 ISIG(NCHN,ISDE)=I
31467 ISIG(NCHN,3-ISDE)=21
31468 ISIG(NCHN,3)=1
31469 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31470 2453 CONTINUE
31471 2454 CONTINUE
31472
31473 ELSEIF(ISUB.EQ.436) THEN
31474C...q + g -> q + QQ~[3P21]
31475 IF(MSTP(145).EQ.0) THEN
31476 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
31477 & ((6D0*SQMQQ**2+TH2)*UHSH2
31478 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
31479 & (SQMQQR*TH*UHSH2**2)
31480 ELSE
31481 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
31482 C1=TH*UHSH2
31483 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
31484 C3=4D0*UHSH2
31485 C4=8D0*SH*UHSH
31486 C5=8D0*TH
31487 C6=0D0
31488 C7=16D0*TH
31489 C8=0D0
31490 C9=-16D0*UHSH
31491 C0=16D0*SQMQQ
31492 IF(MSTP(147).EQ.0) THEN
31493 FACQQG=1D0/3D0*(C1*3D0
31494 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31495 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31496 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31497 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31498 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31499 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31500 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31501 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31502 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31503 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31504 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31505 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31506 ELSEIF(MSTP(147).EQ.1) THEN
31507 FACQQG=C1*2D0
31508 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31509 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31510 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31511 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31512 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31513 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31514 & +EL1K10*EL2K20*EL1K11*EL2K11)
31515 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31516 & +EL1K10*EL2K20*EL1K21*EL2K21)
31517 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31518 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31519 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31520 & +EL1K20*EL2K20*EL1K11*EL2K11)
31521 ELSEIF(MSTP(147).EQ.2) THEN
31522 FACQQG=2D0*(C1
31523 & -C2*EL1K11*EL2K11
31524 & -C3*EL1K21*EL2K21
31525 & -C4*EL1K11*EL2K21
31526 & +C5*(EL1K11*EL2K11)**2
31527 & +C6*(EL1K21*EL2K21)**2
31528 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31529 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31530 & +(C9+C0)*(EL1K11*EL2K21)**2)
31531 ENDIF
31532 FACQQG=COMFAC*FF*FACQQG
31533 ENDIF
31534 DO 2456 I=MMINA,MMAXA
31535 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
31536 DO 2455 ISDE=1,2
31537 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
31538 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
31539 NCHN=NCHN+1
31540 ISIG(NCHN,ISDE)=I
31541 ISIG(NCHN,3-ISDE)=21
31542 ISIG(NCHN,3)=1
31543 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31544 2455 CONTINUE
31545 2456 CONTINUE
31546
31547 ELSEIF(ISUB.EQ.437) THEN
31548C...q + q~ -> g + QQ~[3P01]
31549 IF(MSTP(145).EQ.0) THEN
31550 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
31551 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31552 ELSE
31553 FA=PARU(1)*AS**3*(128D0/729D0)*
31554 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31555 IF(MSTP(147).EQ.0) THEN
31556 FACQQG=COMFAC*FA
31557 ELSEIF(MSTP(147).EQ.1) THEN
31558 FACQQG=COMFAC*2D0*FA
31559 ELSEIF(MSTP(147).EQ.3) THEN
31560 FACQQG=COMFAC*FA
31561 ELSEIF(MSTP(147).EQ.4) THEN
31562 FACQQG=COMFAC*FA
31563 ELSEIF(MSTP(147).EQ.5) THEN
31564 FACQQG=0D0
31565 ELSEIF(MSTP(147).EQ.6) THEN
31566 FACQQG=0D0
31567 ENDIF
31568 ENDIF
31569 DO 2457 I=MMINA,MMAXA
31570 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31571 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
31572 NCHN=NCHN+1
31573 ISIG(NCHN,1)=I
31574 ISIG(NCHN,2)=-I
31575 ISIG(NCHN,3)=1
31576 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31577 2457 CONTINUE
31578
31579 ELSEIF(ISUB.EQ.438) THEN
31580C...q + q~ -> g + QQ~[3P11]
31581 IF(MSTP(145).EQ.0) THEN
31582 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
31583 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
31584 ELSE
31585 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
31586 C1=TH*UH
31587 C2=2D0*UH
31588 C3=2D0*TH
31589 C4=2D0*THUH
31590 IF(MSTP(147).EQ.0) THEN
31591 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31592 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31593 ELSEIF(MSTP(147).EQ.1) THEN
31594 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31595 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31596 ELSEIF(MSTP(147).EQ.3) THEN
31597 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31598 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31599 ELSEIF(MSTP(147).EQ.4) THEN
31600 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31601 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31602 ELSEIF(MSTP(147).EQ.5) THEN
31603 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31604 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31605 ELSEIF(MSTP(147).EQ.6) THEN
31606 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31607 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31608 ENDIF
31609 FACQQG=COMFAC*FF*FACQQG
31610 ENDIF
31611 DO 2458 I=MMINA,MMAXA
31612 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31613 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
31614 NCHN=NCHN+1
31615 ISIG(NCHN,1)=I
31616 ISIG(NCHN,2)=-I
31617 ISIG(NCHN,3)=1
31618 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31619 2458 CONTINUE
31620
31621 ELSEIF(ISUB.EQ.439) THEN
31622C...q + q~ -> g + QQ~[3P21]
31623 IF(MSTP(145).EQ.0) THEN
31624 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
31625 & ((6D0*SQMQQ**2+SH2)*THUH2
31626 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
31627 & (SQMQQR*SH*THUH2**2)
31628 ELSE
31629 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
31630 C1=SH*THUH2
31631 C2=4D0*(SH2+UH2+2D0*SH*THUH)
31632 C3=4D0*(SH2+TH2+2D0*SH*THUH)
31633 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
31634 C5=8D0*SH
31635 C6=C5
31636 C7=16D0*SH
31637 C8=C7
31638 C9=-16D0*THUH
31639 C0=16D0*SQMQQ
31640 IF(MSTP(147).EQ.0) THEN
31641 FACQQG=1D0/3D0*(C1*3D0
31642 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31643 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31644 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31645 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31646 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31647 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31648 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31649 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31650 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31651 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31652 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31653 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31654 ELSEIF(MSTP(147).EQ.1) THEN
31655 FACQQG=C1*2D0
31656 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31657 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31658 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31659 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31660 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31661 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31662 & +EL1K10*EL2K20*EL1K11*EL2K11)
31663 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31664 & +EL1K10*EL2K20*EL1K21*EL2K21)
31665 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31666 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31667 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31668 & +EL1K20*EL2K20*EL1K11*EL2K11)
31669 ELSEIF(MSTP(147).EQ.2) THEN
31670 FACQQG=2D0*(C1
31671 & -C2*EL1K11*EL2K11
31672 & -C3*EL1K21*EL2K21
31673 & -C4*EL1K11*EL2K21
31674 & +C5*(EL1K11*EL2K11)**2
31675 & +C6*(EL1K21*EL2K21)**2
31676 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31677 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31678 & +(C9+C0)*(EL1K11*EL2K21)**2)
31679 ENDIF
31680 FACQQG=COMFAC*FF*FACQQG
31681 ENDIF
31682 DO 2459 I=MMINA,MMAXA
31683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31684 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
31685 NCHN=NCHN+1
31686 ISIG(NCHN,1)=I
31687 ISIG(NCHN,2)=-I
31688 ISIG(NCHN,3)=1
31689 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31690 2459 CONTINUE
31691 ENDIF
31692C...QUARKONIA---
31693
31694 ENDIF
31695
31696 RETURN
31697 END
31698
31699C*********************************************************************
31700
31701C...PYSGWZ
31702C...Subprocess cross sections for W/Z processes,
31703C...except that longitudinal WW scattering is in Higgs sector.
31704C...Auxiliary to PYSIGH.
31705
31706 SUBROUTINE PYSGWZ(NCHN,SIGS)
31707
31708C...Double precision and integer declarations
31709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31710 IMPLICIT INTEGER(I-N)
31711 INTEGER PYK,PYCHGE,PYCOMP
31712C...Parameter statement to help give large particle numbers.
31713 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31714 &KEXCIT=4000000,KDIMEN=5000000)
31715C...Commonblocks
31716 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31717 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31718 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31719 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31720 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31721 COMMON/PYINT1/MINT(400),VINT(400)
31722 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31723 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31724 COMMON/PYINT4/MWID(500),WIDS(500,5)
31725 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
31726 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31727 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31728 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31729 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31730 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
31731 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
31732C...Local arrays and complex numbers
31733 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
31734 &HL4(3),HR4(3)
31735 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
31736
31737C...Differential cross section expressions.
31738
31739 IF(ISUB.LE.20) THEN
31740 IF(ISUB.EQ.1) THEN
31741C...f + fbar -> gamma*/Z0
31742 MINT(61)=2
31743 CALL PYWIDT(23,SH,WDTP,WDTE)
31744 HS=SHR*WDTP(0)
31745 FACZ=4D0*COMFAC*3D0
31746 HP0=AEM/3D0*SH
31747 HP1=AEM/3D0*XWC*SH
31748 DO 100 I=MMINA,MMAXA
31749 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31750 EI=KCHG(IABS(I),1)/3D0
31751 AI=SIGN(1D0,EI)
31752 VI=AI-4D0*EI*XWV
31753 HI0=HP0
31754 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
31755 HI1=HP1
31756 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
31757 NCHN=NCHN+1
31758 ISIG(NCHN,1)=I
31759 ISIG(NCHN,2)=-I
31760 ISIG(NCHN,3)=1
31761 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
31762 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
31763 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
31764 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
31765 100 CONTINUE
31766
31767 ELSEIF(ISUB.EQ.2) THEN
31768C...f + fbar' -> W+/-
31769 CALL PYWIDT(24,SH,WDTP,WDTE)
31770 HS=SHR*WDTP(0)
31771 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
31772 HP=AEM/(24D0*XW)*SH
31773 DO 120 I=MMIN1,MMAX1
31774 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31775 IA=IABS(I)
31776 DO 110 J=MMIN2,MMAX2
31777 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31778 JA=IABS(J)
31779 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
31780 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31781 & GOTO 110
31782 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31783 HI=HP*2D0
31784 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
31785 NCHN=NCHN+1
31786 ISIG(NCHN,1)=I
31787 ISIG(NCHN,2)=J
31788 ISIG(NCHN,3)=1
31789 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
31790 SIGH(NCHN)=HI*FACBW*HF
31791 110 CONTINUE
31792 120 CONTINUE
31793
31794 ELSEIF(ISUB.EQ.15) THEN
31795C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
31796 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31797C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31798 HFGG=0D0
31799 HFGZ=0D0
31800 HFZZ=0D0
31801 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31802 DO 130 I=1,MIN(16,MDCY(23,3))
31803 IDC=I+MDCY(23,2)-1
31804 IF(MDME(IDC,1).LT.0) GOTO 130
31805 IMDM=0
31806 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31807 & IMDM=1
31808 IF(I.LE.8) THEN
31809 EF=KCHG(I,1)/3D0
31810 AF=SIGN(1D0,EF+0.1D0)
31811 VF=AF-4D0*EF*XWV
31812 ELSEIF(I.LE.16) THEN
31813 EF=KCHG(I+2,1)/3D0
31814 AF=SIGN(1D0,EF+0.1D0)
31815 VF=AF-4D0*EF*XWV
31816 ENDIF
31817 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31818 IF(4D0*RM1.LT.1D0) THEN
31819 FCOF=1D0
31820 IF(I.LE.8) FCOF=3D0*RADC4
31821 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31822 IF(IMDM.EQ.1) THEN
31823 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31824 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31825 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31826 & AF**2*(1D0-4D0*RM1))*BE34
31827 ENDIF
31828 ENDIF
31829 130 CONTINUE
31830C...Propagators: as simulated in PYOFSH and as desired
31831 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31832 MINT15=MINT(15)
31833 MINT(15)=1
31834 MINT(61)=1
31835 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31836 MINT(15)=MINT15
31837 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31838 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31839 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31840 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31841C...Loop over flavours; consider full gamma/Z structure
31842 DO 140 I=MMINA,MMAXA
31843 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31844 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
31845 EI=KCHG(IABS(I),1)/3D0
31846 AI=SIGN(1D0,EI)
31847 VI=AI-4D0*EI*XWV
31848 NCHN=NCHN+1
31849 ISIG(NCHN,1)=I
31850 ISIG(NCHN,2)=-I
31851 ISIG(NCHN,3)=1
31852 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
31853 & (VI**2+AI**2)*HFZZ)/HBW4
31854 140 CONTINUE
31855
31856 ELSEIF(ISUB.EQ.16) THEN
31857C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
31858 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31859C...Propagators: as simulated in PYOFSH and as desired
31860 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31861 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31862 GMMWC=SQRT(SQM4)*WDTP(0)
31863 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31864 FACWG=FACWG*HBW4C/HBW4
31865 DO 160 I=MMIN1,MMAX1
31866 IA=IABS(I)
31867 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
31868 DO 150 J=MMIN2,MMAX2
31869 JA=IABS(J)
31870 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
31871 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
31872 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31873 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31874 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31875 NCHN=NCHN+1
31876 ISIG(NCHN,1)=I
31877 ISIG(NCHN,2)=J
31878 ISIG(NCHN,3)=1
31879 SIGH(NCHN)=FACWG*FCKM*WIDSC
31880 150 CONTINUE
31881 160 CONTINUE
31882
31883 ELSEIF(ISUB.EQ.19) THEN
31884C...f + fbar -> gamma + (gamma*/Z0)
31885 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31886C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31887 HFGG=0D0
31888 HFGZ=0D0
31889 HFZZ=0D0
31890 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31891 DO 170 I=1,MIN(16,MDCY(23,3))
31892 IDC=I+MDCY(23,2)-1
31893 IF(MDME(IDC,1).LT.0) GOTO 170
31894 IMDM=0
31895 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31896 & IMDM=1
31897 IF(I.LE.8) THEN
31898 EF=KCHG(I,1)/3D0
31899 AF=SIGN(1D0,EF+0.1D0)
31900 VF=AF-4D0*EF*XWV
31901 ELSEIF(I.LE.16) THEN
31902 EF=KCHG(I+2,1)/3D0
31903 AF=SIGN(1D0,EF+0.1D0)
31904 VF=AF-4D0*EF*XWV
31905 ENDIF
31906 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31907 IF(4D0*RM1.LT.1D0) THEN
31908 FCOF=1D0
31909 IF(I.LE.8) FCOF=3D0*RADC4
31910 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31911 IF(IMDM.EQ.1) THEN
31912 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31913 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31914 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31915 & AF**2*(1D0-4D0*RM1))*BE34
31916 ENDIF
31917 ENDIF
31918 170 CONTINUE
31919C...Propagators: as simulated in PYOFSH and as desired
31920 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31921 MINT15=MINT(15)
31922 MINT(15)=1
31923 MINT(61)=1
31924 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31925 MINT(15)=MINT15
31926 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31927 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31928 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31929 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31930C...Loop over flavours; consider full gamma/Z structure
31931 DO 180 I=MMINA,MMAXA
31932 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31933 EI=KCHG(IABS(I),1)/3D0
31934 AI=SIGN(1D0,EI)
31935 VI=AI-4D0*EI*XWV
31936 FCOI=1D0
31937 IF(IABS(I).LE.10) FCOI=FACA/3D0
31938 NCHN=NCHN+1
31939 ISIG(NCHN,1)=I
31940 ISIG(NCHN,2)=-I
31941 ISIG(NCHN,3)=1
31942 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31943 & (VI**2+AI**2)*HFZZ)/HBW4
31944 180 CONTINUE
31945
31946 ELSEIF(ISUB.EQ.20) THEN
31947C...f + fbar' -> gamma + W+/-
31948 FACGW=COMFAC*0.5D0*AEM**2/XW
31949C...Propagators: as simulated in PYOFSH and as desired
31950 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31951 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31952 GMMWC=SQRT(SQM4)*WDTP(0)
31953 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31954 FACGW=FACGW*HBW4C/HBW4
31955C...Anomalous couplings
31956 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31957 TERM2=0D0
31958 TERM3=0D0
31959 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31960 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31961 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31962 & (4D0*SQMW))/(TH+UH)**2
31963 ENDIF
31964 DO 200 I=MMIN1,MMAX1
31965 IA=IABS(I)
31966 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31967 DO 190 J=MMIN2,MMAX2
31968 JA=IABS(J)
31969 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31970 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31971 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31972 & GOTO 190
31973 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31974 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31975 IF(IA.LE.10) THEN
31976 FACWR=UH/(TH+UH)-1D0/3D0
31977 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31978 FCOI=FACA/3D0
31979 ELSE
31980 FACWR=-TH/(TH+UH)
31981 FCKM=1D0
31982 FCOI=1D0
31983 ENDIF
31984 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
31985 NCHN=NCHN+1
31986 ISIG(NCHN,1)=I
31987 ISIG(NCHN,2)=J
31988 ISIG(NCHN,3)=1
31989 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
31990 190 CONTINUE
31991 200 CONTINUE
31992 ENDIF
31993
31994 ELSEIF(ISUB.LE.40) THEN
31995 IF(ISUB.EQ.22) THEN
31996C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
31997C...Kinematics dependence
31998 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
31999 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32000C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32001 DO 220 I=1,6
32002 DO 210 J=1,3
32003 HGZ(I,J)=0D0
32004 210 CONTINUE
32005 220 CONTINUE
32006 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32007 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32008 DO 230 I=1,MIN(16,MDCY(23,3))
32009 IDC=I+MDCY(23,2)-1
32010 IF(MDME(IDC,1).LT.0) GOTO 230
32011 IMDM=0
32012 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32013 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32014 IF(I.LE.8) THEN
32015 EF=KCHG(I,1)/3D0
32016 AF=SIGN(1D0,EF+0.1D0)
32017 VF=AF-4D0*EF*XWV
32018 ELSEIF(I.LE.16) THEN
32019 EF=KCHG(I+2,1)/3D0
32020 AF=SIGN(1D0,EF+0.1D0)
32021 VF=AF-4D0*EF*XWV
32022 ENDIF
32023 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32024 IF(4D0*RM1.LT.1D0) THEN
32025 FCOF=1D0
32026 IF(I.LE.8) FCOF=3D0*RADC3
32027 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32028 IF(IMDM.GE.1) THEN
32029 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32030 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32031 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32032 & AF**2*(1D0-4D0*RM1))*BE34
32033 ENDIF
32034 ENDIF
32035 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32036 IF(4D0*RM1.LT.1D0) THEN
32037 FCOF=1D0
32038 IF(I.LE.8) FCOF=3D0*RADC4
32039 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32040 IF(IMDM.GE.1) THEN
32041 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32042 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32043 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32044 & AF**2*(1D0-4D0*RM1))*BE34
32045 ENDIF
32046 ENDIF
32047 230 CONTINUE
32048C...Propagators: as simulated in PYOFSH and as desired
32049 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32050 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32051 MINT15=MINT(15)
32052 MINT(15)=1
32053 MINT(61)=1
32054 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32055 MINT(15)=MINT15
32056 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32057 DO 240 J=1,3
32058 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32059 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32060 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32061 240 CONTINUE
32062 MINT15=MINT(15)
32063 MINT(15)=1
32064 MINT(61)=1
32065 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32066 MINT(15)=MINT15
32067 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32068 DO 250 J=1,3
32069 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32070 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32071 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32072 250 CONTINUE
32073C...Loop over flavours; separate left- and right-handed couplings
32074 DO 270 I=MMINA,MMAXA
32075 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32076 EI=KCHG(IABS(I),1)/3D0
32077 AI=SIGN(1D0,EI)
32078 VI=AI-4D0*EI*XWV
32079 VALI=VI-AI
32080 VARI=VI+AI
32081 FCOI=1D0
32082 IF(IABS(I).LE.10) FCOI=FACA/3D0
32083 DO 260 J=1,3
32084 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32085 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32086 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32087 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32088 260 CONTINUE
32089 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32090 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32091 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32092 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32093 NCHN=NCHN+1
32094 ISIG(NCHN,1)=I
32095 ISIG(NCHN,2)=-I
32096 ISIG(NCHN,3)=1
32097 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32098 270 CONTINUE
32099
32100 ELSEIF(ISUB.EQ.23) THEN
32101C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32102 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32103 FACZW=FACZW*WIDS(23,2)
32104 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32105 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32106 DO 290 I=MMIN1,MMAX1
32107 IA=IABS(I)
32108 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32109 DO 280 J=MMIN2,MMAX2
32110 JA=IABS(J)
32111 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32112 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32113 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32114 & GOTO 280
32115 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32116 EI=KCHG(IA,1)/3D0
32117 AI=SIGN(1D0,EI+0.1D0)
32118 VI=AI-4D0*EI*XWV
32119 EJ=KCHG(JA,1)/3D0
32120 AJ=SIGN(1D0,EJ+0.1D0)
32121 VJ=AJ-4D0*EJ*XWV
32122 IF(VI+AI.GT.0) THEN
32123 VISAV=VI
32124 AISAV=AI
32125 VI=VJ
32126 AI=AJ
32127 VJ=VISAV
32128 AJ=AISAV
32129 ENDIF
32130 FCKM=1D0
32131 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32132 FCOI=1D0
32133 IF(IA.LE.10) FCOI=FACA/3D0
32134 NCHN=NCHN+1
32135 ISIG(NCHN,1)=I
32136 ISIG(NCHN,2)=J
32137 ISIG(NCHN,3)=1
32138 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
32139 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
32140 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
32141 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
32142 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
32143 & WIDS(24,(5-KCHW)/2)
32144C***Protect against slightly negative cross sections. (Reason yet to be
32145C***sorted out. One possibility: addition of width to the W propagator.)
32146 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
32147 280 CONTINUE
32148 290 CONTINUE
32149
32150 ELSEIF(ISUB.EQ.25) THEN
32151C...f + fbar -> W+ + W-
32152C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32153 GMMZC=GMMZ
32154 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
32155 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32156 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32157 GMMW3=SQRT(SQM3)*WDTP(0)
32158 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32159 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32160 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32161 GMMW4=SQRT(SQM4)*WDTP(0)
32162 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
32163C...Kinematical functions
32164 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32165 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
32166 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
32167 GT=THUH34+4D0*THUH/TH2
32168 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
32169 GU=THUH34+4D0*THUH/UH2
32170 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
32171C...Common factors and couplings
32172 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
32173 FACWW=FACWW*WIDS(24,1)
32174 CGG=AEM**2/2D0
32175 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
32176 CZZ=AEM**2/(32D0*XW**2)*HBWZC
32177 CNG=AEM**2/(4D0*XW)
32178 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
32179 CNN=AEM**2/(16D0*XW**2)
32180C...Coulomb factor for W+W- pair
32181 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
32182 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
32183 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
32184 IF(COULE.LT.100D0*PMAS(24,2)) THEN
32185 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32186 & PMAS(24,2)**2)-COULE))
32187 ELSE
32188 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
32189 ENDIF
32190 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
32191 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32192 & PMAS(24,2)**2)+COULE))
32193 ELSE
32194 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
32195 & ABS(COULE)))
32196 ENDIF
32197 IF(MSTP(40).EQ.1) THEN
32198 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
32199 & MAX(1D-10,2D0*COULP*COULP1))
32200 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32201 ELSEIF(MSTP(40).EQ.2) THEN
32202 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
32203 COULCP=DCMPLX(0D0,DBLE(COULP))
32204 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
32205 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
32206 & (4D0*COULCP)*LOG(COULCD)
32207 COULCS=DCMPLX(0D0,0D0)
32208 NSTP=100
32209 DO 300 ISTP=1,NSTP
32210 COULXX=(ISTP-0.5)/NSTP
32211 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
32212 & (1D0+COULXX/COULCD))
32213 300 CONTINUE
32214 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
32215 & (COULCS/NSTP)
32216 FACCOU=ABS(COULCR)**2
32217 ELSEIF(MSTP(40).EQ.3) THEN
32218 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
32219 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
32220 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32221 ENDIF
32222 ELSEIF(MSTP(40).EQ.4) THEN
32223 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
32224 ELSE
32225 FACCOU=1D0
32226 ENDIF
32227 VINT(95)=FACCOU
32228 FACWW=FACWW*FACCOU
32229C...Loop over allowed flavours
32230 DO 310 I=MMINA,MMAXA
32231 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
32232 EI=KCHG(IABS(I),1)/3D0
32233 AI=SIGN(1D0,EI+0.1D0)
32234 VI=AI-4D0*EI*XWV
32235 FCOI=1D0
32236 IF(IABS(I).LE.10) FCOI=FACA/3D0
32237 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
32238 IF(AI.LT.0D0) THEN
32239 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
32240 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
32241 ELSE
32242 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
32243 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
32244 ENDIF
32245 ELSE
32246 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
32247 BET=SQRT(1D0-4D0*XMW02/SH)
32248 GAT=1D0/SQRT(1D0-BET**2)
32249 STHE2=1D0-CTH**2
32250 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
32251 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
32252 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
32253 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
32254 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
32255 & (1D0-2D0*BET*CTH+BET**2))
32256 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
32257 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
32258 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
32259 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
32260 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
32261 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
32262 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
32263 DSIGWW=ATOT
32264 ENDIF
32265 NCHN=NCHN+1
32266 ISIG(NCHN,1)=I
32267 ISIG(NCHN,2)=-I
32268 ISIG(NCHN,3)=1
32269 SIGH(NCHN)=FACWW*FCOI*DSIGWW
32270 310 CONTINUE
32271
32272 ELSEIF(ISUB.EQ.30) THEN
32273C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
32274 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
32275 & (-SH*UH)
32276C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32277 HFGG=0D0
32278 HFGZ=0D0
32279 HFZZ=0D0
32280 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32281 DO 320 I=1,MIN(16,MDCY(23,3))
32282 IDC=I+MDCY(23,2)-1
32283 IF(MDME(IDC,1).LT.0) GOTO 320
32284 IMDM=0
32285 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32286 & IMDM=1
32287 IF(I.LE.8) THEN
32288 EF=KCHG(I,1)/3D0
32289 AF=SIGN(1D0,EF+0.1D0)
32290 VF=AF-4D0*EF*XWV
32291 ELSEIF(I.LE.16) THEN
32292 EF=KCHG(I+2,1)/3D0
32293 AF=SIGN(1D0,EF+0.1D0)
32294 VF=AF-4D0*EF*XWV
32295 ENDIF
32296 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32297 IF(4D0*RM1.LT.1D0) THEN
32298 FCOF=1D0
32299 IF(I.LE.8) FCOF=3D0*RADC4
32300 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32301 IF(IMDM.EQ.1) THEN
32302 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32303 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32304 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32305 & AF**2*(1D0-4D0*RM1))*BE34
32306 ENDIF
32307 ENDIF
32308 320 CONTINUE
32309C...Propagators: as simulated in PYOFSH and as desired
32310 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32311 MINT15=MINT(15)
32312 MINT(15)=1
32313 MINT(61)=1
32314 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32315 MINT(15)=MINT15
32316 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32317 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32318 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32319 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32320C...Loop over flavours; consider full gamma/Z structure
32321 DO 340 I=MMINA,MMAXA
32322 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
32323 EI=KCHG(IABS(I),1)/3D0
32324 AI=SIGN(1D0,EI)
32325 VI=AI-4D0*EI*XWV
32326 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
32327 & (VI**2+AI**2)*HFZZ)/HBW4
32328 DO 330 ISDE=1,2
32329 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
32330 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
32331 NCHN=NCHN+1
32332 ISIG(NCHN,ISDE)=I
32333 ISIG(NCHN,3-ISDE)=21
32334 ISIG(NCHN,3)=1
32335 SIGH(NCHN)=FACZQ
32336 330 CONTINUE
32337 340 CONTINUE
32338
32339 ELSEIF(ISUB.EQ.31) THEN
32340C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
32341 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
32342 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
32343C...Propagators: as simulated in PYOFSH and as desired
32344 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32345 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32346 GMMWC=SQRT(SQM4)*WDTP(0)
32347 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32348 FACWQ=FACWQ*HBW4C/HBW4
32349 DO 360 I=MMINA,MMAXA
32350 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
32351 IA=IABS(I)
32352 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32353 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32354 DO 350 ISDE=1,2
32355 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
32356 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
32357 NCHN=NCHN+1
32358 ISIG(NCHN,ISDE)=I
32359 ISIG(NCHN,3-ISDE)=21
32360 ISIG(NCHN,3)=1
32361 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32362 350 CONTINUE
32363 360 CONTINUE
32364
32365 ELSEIF(ISUB.EQ.35) THEN
32366C...f + gamma -> f + (gamma*/Z0)
32367 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
32368 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
32369 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
32370 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
32371 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
32372 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
32373 ELSE
32374 FZQN=SH2+UH2+2D0*SQM4*TH
32375 FZQDTM=-SH*UH
32376 ENDIF
32377 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
32378C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32379 HFGG=0D0
32380 HFGZ=0D0
32381 HFZZ=0D0
32382 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32383 DO 370 I=1,MIN(16,MDCY(23,3))
32384 IDC=I+MDCY(23,2)-1
32385 IF(MDME(IDC,1).LT.0) GOTO 370
32386 IMDM=0
32387 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32388 & IMDM=1
32389 IF(I.LE.8) THEN
32390 EF=KCHG(I,1)/3D0
32391 AF=SIGN(1D0,EF+0.1D0)
32392 VF=AF-4D0*EF*XWV
32393 ELSEIF(I.LE.16) THEN
32394 EF=KCHG(I+2,1)/3D0
32395 AF=SIGN(1D0,EF+0.1D0)
32396 VF=AF-4D0*EF*XWV
32397 ENDIF
32398 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32399 IF(4D0*RM1.LT.1D0) THEN
32400 FCOF=1D0
32401 IF(I.LE.8) FCOF=3D0*RADC4
32402 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32403 IF(IMDM.EQ.1) THEN
32404 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32405 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32406 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32407 & AF**2*(1D0-4D0*RM1))*BE34
32408 ENDIF
32409 ENDIF
32410 370 CONTINUE
32411C...Propagators: as simulated in PYOFSH and as desired
32412 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32413 MINT15=MINT(15)
32414 MINT(15)=1
32415 MINT(61)=1
32416 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32417 MINT(15)=MINT15
32418 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32419 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32420 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32421 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32422C...Loop over flavours; consider full gamma/Z structure
32423 DO 390 I=MMINA,MMAXA
32424 IF(I.EQ.0) GOTO 390
32425 EI=KCHG(IABS(I),1)/3D0
32426 AI=SIGN(1D0,EI)
32427 VI=AI-4D0*EI*XWV
32428 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32429 & (VI**2+AI**2)*HFZZ)/HBW4
32430 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
32431 DO 380 ISDE=1,2
32432 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
32433 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
32434 NCHN=NCHN+1
32435 ISIG(NCHN,ISDE)=I
32436 ISIG(NCHN,3-ISDE)=22
32437 ISIG(NCHN,3)=1
32438 SIGH(NCHN)=FACZQ*FZQN/FZQD
32439 380 CONTINUE
32440 390 CONTINUE
32441
32442 ELSEIF(ISUB.EQ.36) THEN
32443C...f + gamma -> f' + W+/-
32444 FWQ=COMFAC*AEM**2/(2D0*XW)*
32445 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
32446C...Propagators: as simulated in PYOFSH and as desired
32447 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32448 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32449 GMMWC=SQRT(SQM4)*WDTP(0)
32450 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32451 FWQ=FWQ*HBW4C/HBW4
32452 DO 410 I=MMINA,MMAXA
32453 IF(I.EQ.0) GOTO 410
32454 IA=IABS(I)
32455 EIA=ABS(KCHG(IABS(I),1)/3D0)
32456 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
32457 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32458 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32459 DO 400 ISDE=1,2
32460 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
32461 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
32462 NCHN=NCHN+1
32463 ISIG(NCHN,ISDE)=I
32464 ISIG(NCHN,3-ISDE)=22
32465 ISIG(NCHN,3)=1
32466 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32467 400 CONTINUE
32468 410 CONTINUE
32469 ENDIF
32470
32471 ELSEIF(ISUB.LE.100) THEN
32472 IF(ISUB.EQ.69) THEN
32473C...gamma + gamma -> W+ + W-
32474 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32475 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
32476 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
32477 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
32478 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
32479 NCHN=NCHN+1
32480 ISIG(NCHN,1)=22
32481 ISIG(NCHN,2)=22
32482 ISIG(NCHN,3)=1
32483 SIGH(NCHN)=FACWW
32484 420 CONTINUE
32485
32486 ELSEIF(ISUB.EQ.70) THEN
32487C...gamma + W+/- -> Z0 + W+/-
32488 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32489 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
32490 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
32491 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
32492 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
32493 DO 440 KCHW=1,-1,-2
32494 DO 430 ISDE=1,2
32495 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
32496 NCHN=NCHN+1
32497 ISIG(NCHN,ISDE)=22
32498 ISIG(NCHN,3-ISDE)=24*KCHW
32499 ISIG(NCHN,3)=1
32500 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
32501 430 CONTINUE
32502 440 CONTINUE
32503 ENDIF
32504 ENDIF
32505
32506 RETURN
32507 END
32508
32509C*********************************************************************
32510
32511C...PYSGHG
32512C...Subprocess cross sections for Higgs processes,
32513C...except Higgs pairs in PYSGSU, but including WW scattering.
32514C...Auxiliary to PYSIGH.
32515
32516 SUBROUTINE PYSGHG(NCHN,SIGS)
32517
32518C...Double precision and integer declarations
32519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32520 IMPLICIT INTEGER(I-N)
32521 INTEGER PYK,PYCHGE,PYCOMP
32522C...Parameter statement to help give large particle numbers.
32523 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32524 &KEXCIT=4000000,KDIMEN=5000000)
32525C...Commonblocks
32526 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32527 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32528 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32529 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32530 COMMON/PYINT1/MINT(400),VINT(400)
32531 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32532 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32533 COMMON/PYINT4/MWID(500),WIDS(500,5)
32534 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32535 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32536 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32537 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32538 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32539 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32540 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
32541 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
32542C...Local arrays and complex variables
32543 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32544 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
32545 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
32546
32547C...Convert H or A process into equivalent h one
32548 IHIGG=1
32549 KFHIGG=25
32550 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
32551 KFHIGG=KFPR(ISUB,1)
32552 END IF
32553 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
32554 &ISUB.LE.190)) THEN
32555 IHIGG=2
32556 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
32557 KFHIGG=33+IHIGG
32558 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
32559 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
32560 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
32561 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
32562 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
32563 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
32564 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
32565 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
32566 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
32567 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
32568 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
32569 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
32570 ENDIF
32571 SQMH=PMAS(KFHIGG,1)**2
32572 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
32573
32574C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32575 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
32576 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
32577C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
32578 IF(MSTP(46).LE.4) THEN
32579 HDTLH=LOG(PMAS(25,1)/PARP(44))
32580 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
32581 HDTNR=-1D0/18D0+HDTLH/6D0
32582 ELSE
32583 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
32584 HDTLQ=LOG(PARP(45)/PARP(44))
32585 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
32586 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
32587 ENDIF
32588
32589C...Calculate lowest and next-to-lowest order partial wave amplitudes
32590 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
32591 A00L=DBLE(HDTV*SH)
32592 A20L=-0.5D0*A00L
32593 A11L=A00L/6D0
32594 HDTLS=LOG(SH/PARP(44)**2)
32595 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32596 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
32597 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
32598 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32599 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
32600 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
32601 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
32602 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
32603
32604C...Unitarize partial wave amplitudes with Pade or K-matrix method
32605 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
32606 A00U=A00L/(1D0-A004/A00L)
32607 A20U=A20L/(1D0-A204/A20L)
32608 A11U=A11L/(1D0-A114/A11L)
32609 ELSE
32610 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
32611 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
32612 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
32613 ENDIF
32614 ENDIF
32615
32616C...Differential cross section expressions.
32617
32618 IF(ISUB.LE.60) THEN
32619 IF(ISUB.EQ.3) THEN
32620C...f + fbar -> h0 (or H0, or A0)
32621 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32622 HS=SHR*WDTP(0)
32623 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32624 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32625 & FACBW=0D0
32626 HP=AEM/(8D0*XW)*SH/SQMW*SH
32627 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32628 DO 100 I=MMINA,MMAXA
32629 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32630 IA=IABS(I)
32631 RMQ=PYMRUN(IA,SH)**2/SH
32632 HI=HP*RMQ
32633 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
32634 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32635 IKFI=1
32636 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32637 IF(IA.GT.10) IKFI=3
32638 HI=HI*PARU(150+10*IHIGG+IKFI)**2
32639 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32640 HI=HI/(1D0+RMSS(41))**2
32641 IF(IHIGG.NE.3) THEN
32642 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32643 & PARU(151+10*IHIGG))**2
32644 ENDIF
32645 ENDIF
32646 ENDIF
32647 NCHN=NCHN+1
32648 ISIG(NCHN,1)=I
32649 ISIG(NCHN,2)=-I
32650 ISIG(NCHN,3)=1
32651 SIGH(NCHN)=HI*FACBW*HF
32652 100 CONTINUE
32653
32654 ELSEIF(ISUB.EQ.5) THEN
32655C...Z0 + Z0 -> h0
32656 CALL PYWIDT(25,SH,WDTP,WDTE)
32657 HS=SHR*WDTP(0)
32658 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32659 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32660 HP=AEM/(8D0*XW)*SH/SQMW*SH
32661 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32662 HI=HP/4D0
32663 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
32664 DO 120 I=MMIN1,MMAX1
32665 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32666 DO 110 J=MMIN2,MMAX2
32667 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32668 EI=KCHG(IABS(I),1)/3D0
32669 AI=SIGN(1D0,EI)
32670 VI=AI-4D0*EI*XWV
32671 EJ=KCHG(IABS(J),1)/3D0
32672 AJ=SIGN(1D0,EJ)
32673 VJ=AJ-4D0*EJ*XWV
32674 NCHN=NCHN+1
32675 ISIG(NCHN,1)=I
32676 ISIG(NCHN,2)=J
32677 ISIG(NCHN,3)=1
32678 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
32679 110 CONTINUE
32680 120 CONTINUE
32681
32682 ELSEIF(ISUB.EQ.8) THEN
32683C...W+ + W- -> h0
32684 CALL PYWIDT(25,SH,WDTP,WDTE)
32685 HS=SHR*WDTP(0)
32686 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32687 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32688 HP=AEM/(8D0*XW)*SH/SQMW*SH
32689 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32690 HI=HP/2D0
32691 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
32692 DO 140 I=MMIN1,MMAX1
32693 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
32694 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32695 DO 130 J=MMIN2,MMAX2
32696 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
32697 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32698 IF(EI*EJ.GT.0D0) GOTO 130
32699 NCHN=NCHN+1
32700 ISIG(NCHN,1)=I
32701 ISIG(NCHN,2)=J
32702 ISIG(NCHN,3)=1
32703 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
32704 130 CONTINUE
32705 140 CONTINUE
32706
32707 ELSEIF(ISUB.EQ.24) THEN
32708C...f + fbar -> Z0 + h0 (or H0, or A0)
32709C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
32710 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32711 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32712 GMMZ3=SQRT(SQM3)*WDTP(0)
32713 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
32714 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32715 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32716 GMMH4=SQRT(SQM4)*WDTP(0)
32717 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32718 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32719 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
32720 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
32721 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
32722 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
32723 & PARU(154+10*IHIGG)**2
32724 DO 150 I=MMINA,MMAXA
32725 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
32726 EI=KCHG(IABS(I),1)/3D0
32727 AI=SIGN(1D0,EI)
32728 VI=AI-4D0*EI*XWV
32729 FCOI=1D0
32730 IF(IABS(I).LE.10) FCOI=FACA/3D0
32731 NCHN=NCHN+1
32732 ISIG(NCHN,1)=I
32733 ISIG(NCHN,2)=-I
32734 ISIG(NCHN,3)=1
32735 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
32736 150 CONTINUE
32737
32738 ELSEIF(ISUB.EQ.26) THEN
32739C...f + fbar' -> W+/- + h0 (or H0, or A0)
32740C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
32741 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32742 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32743 GMMW3=SQRT(SQM3)*WDTP(0)
32744 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32745 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32746 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32747 GMMH4=SQRT(SQM4)*WDTP(0)
32748 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32749 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32750 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
32751 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
32752 FACHW=FACHW*WIDS(KFHIGG,2)
32753 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
32754 & PARU(155+10*IHIGG)**2
32755 DO 170 I=MMIN1,MMAX1
32756 IA=IABS(I)
32757 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
32758 DO 160 J=MMIN2,MMAX2
32759 JA=IABS(J)
32760 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
32761 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
32762 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32763 & GOTO 160
32764 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32765 FCKM=1D0
32766 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32767 FCOI=1D0
32768 IF(IA.LE.10) FCOI=FACA/3D0
32769 NCHN=NCHN+1
32770 ISIG(NCHN,1)=I
32771 ISIG(NCHN,2)=J
32772 ISIG(NCHN,3)=1
32773 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
32774 160 CONTINUE
32775 170 CONTINUE
32776
32777 ELSEIF(ISUB.EQ.32) THEN
32778C...f + g -> f + h0 (q + g -> q + h0 only)
32779 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
32780C...H propagator: as simulated in PYOFSH and as desired
32781 SQMHC=PMAS(25,1)**2
32782 GMMHC=PMAS(25,1)*PMAS(25,2)
32783 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32784 CALL PYWIDT(25,SQM4,WDTP,WDTE)
32785 GMMHCC=SQRT(SQM4)*WDTP(0)
32786 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32787 FHCQ=FHCQ*HBW4C/HBW4
32788 DO 190 I=MMINA,MMAXA
32789 IA=IABS(I)
32790 IF(IA.NE.5) GOTO 190
32791 SQML=PYMRUN(IA,SH)**2
32792 SQMQ=PMAS(IA,1)**2
32793 FACHCQ=FHCQ*SQML/SQMW*
32794 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32795 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
32796 & (SQM4-SQMQ-SH)/SH)
32797 DO 180 ISDE=1,2
32798 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
32799 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
32800 NCHN=NCHN+1
32801 ISIG(NCHN,ISDE)=I
32802 ISIG(NCHN,3-ISDE)=21
32803 ISIG(NCHN,3)=1
32804 SIGH(NCHN)=FACHCQ*WIDS(25,2)
32805 180 CONTINUE
32806 190 CONTINUE
32807 ENDIF
32808
32809 ELSEIF(ISUB.LE.80) THEN
32810 IF(ISUB.EQ.71) THEN
32811C...Z0 + Z0 -> Z0 + Z0
32812 IF(SH.LE.4.01D0*SQMZ) GOTO 220
32813
32814 IF(MSTP(46).LE.2) THEN
32815C...Exact scattering ME:s for on-mass-shell gauge bosons
32816 BE2=1D0-4D0*SQMZ/SH
32817 TH=-0.5D0*SH*BE2*(1D0-CTH)
32818 UH=-0.5D0*SH*BE2*(1D0+CTH)
32819 IF(MAX(TH,UH).GT.-1D0) GOTO 220
32820 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
32821 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32822 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32823 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
32824 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32825 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32826 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
32827 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32828 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32829 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32830 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32831 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32832 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
32833 & (ASHIM+ATHIM+AUHIM)**2)
32834 IF(MSTP(46).EQ.2) FACZZ=0D0
32835
32836 ELSE
32837C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32838 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32839 & ABS(A00U+2D0*A20U)**2
32840 ENDIF
32841 FACZZ=FACZZ*WIDS(23,1)
32842
32843 DO 210 I=MMIN1,MMAX1
32844 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
32845 EI=KCHG(IABS(I),1)/3D0
32846 AI=SIGN(1D0,EI)
32847 VI=AI-4D0*EI*XWV
32848 AVI=AI**2+VI**2
32849 DO 200 J=MMIN2,MMAX2
32850 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
32851 EJ=KCHG(IABS(J),1)/3D0
32852 AJ=SIGN(1D0,EJ)
32853 VJ=AJ-4D0*EJ*XWV
32854 AVJ=AJ**2+VJ**2
32855 NCHN=NCHN+1
32856 ISIG(NCHN,1)=I
32857 ISIG(NCHN,2)=J
32858 ISIG(NCHN,3)=1
32859 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
32860 200 CONTINUE
32861 210 CONTINUE
32862 220 CONTINUE
32863
32864 ELSEIF(ISUB.EQ.72) THEN
32865C...Z0 + Z0 -> W+ + W-
32866 IF(SH.LE.4.01D0*SQMZ) GOTO 250
32867
32868 IF(MSTP(46).LE.2) THEN
32869C...Exact scattering ME:s for on-mass-shell gauge bosons
32870 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32871 CTH2=CTH**2
32872 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32873 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32874 IF(MAX(TH,UH).GT.-1D0) GOTO 250
32875 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32876 & (1D0-2D0*SQMZ/SH)
32877 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32878 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32879 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32880 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32881 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32882 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32883 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32884 ATWIM=0D0
32885 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32886 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32887 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32888 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32889 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32890 AUWIM=0D0
32891 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32892 A4IM=0D0
32893 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32894 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32895 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
32896 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32897 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32898 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
32899 & (ATWIM+AUWIM+A4IM)**2)
32900
32901 ELSE
32902C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32903 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32904 & ABS(A00U-A20U)**2
32905 ENDIF
32906 FACWW=FACWW*WIDS(24,1)
32907
32908 DO 240 I=MMIN1,MMAX1
32909 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32910 EI=KCHG(IABS(I),1)/3D0
32911 AI=SIGN(1D0,EI)
32912 VI=AI-4D0*EI*XWV
32913 AVI=AI**2+VI**2
32914 DO 230 J=MMIN2,MMAX2
32915 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32916 EJ=KCHG(IABS(J),1)/3D0
32917 AJ=SIGN(1D0,EJ)
32918 VJ=AJ-4D0*EJ*XWV
32919 AVJ=AJ**2+VJ**2
32920 NCHN=NCHN+1
32921 ISIG(NCHN,1)=I
32922 ISIG(NCHN,2)=J
32923 ISIG(NCHN,3)=1
32924 SIGH(NCHN)=FACWW*AVI*AVJ
32925 230 CONTINUE
32926 240 CONTINUE
32927 250 CONTINUE
32928
32929 ELSEIF(ISUB.EQ.73) THEN
32930C...Z0 + W+/- -> Z0 + W+/-
32931 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32932
32933 IF(MSTP(46).LE.2) THEN
32934C...Exact scattering ME:s for on-mass-shell gauge bosons
32935 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32936 EP1=1D0-(SQMZ-SQMW)/SH
32937 EP2=1D0+(SQMZ-SQMW)/SH
32938 TH=-0.5D0*SH*BE2*(1D0-CTH)
32939 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32940 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32941 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32942 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32943 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32944 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32945 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32946 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32947 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32948 ASWIM=0D0
32949 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32950 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32951 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32952 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32953 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32954 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32955 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32956 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32957 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32958 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32959 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32960 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32961 AUWIM=0D0
32962 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32963 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32964 A4IM=0D0
32965 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32966 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32967 IF(MSTP(46).LE.0) FACZW=0D0
32968 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32969 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32970 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32971 & (ASWIM+AUWIM+A4IM)**2)
32972
32973 ELSE
32974C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32975 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32976 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32977 ENDIF
32978 FACZW=FACZW*WIDS(23,2)
32979
32980 DO 270 I=MMIN1,MMAX1
32981 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
32982 EI=KCHG(IABS(I),1)/3D0
32983 AI=SIGN(1D0,EI)
32984 VI=AI-4D0*EI*XWV
32985 AVI=AI**2+VI**2
32986 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
32987 DO 260 J=MMIN2,MMAX2
32988 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
32989 EJ=KCHG(IABS(J),1)/3D0
32990 AJ=SIGN(1D0,EJ)
32991 VJ=AI-4D0*EJ*XWV
32992 AVJ=AJ**2+VJ**2
32993 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
32994 NCHN=NCHN+1
32995 ISIG(NCHN,1)=I
32996 ISIG(NCHN,2)=J
32997 ISIG(NCHN,3)=1
32998 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
32999 NCHN=NCHN+1
33000 ISIG(NCHN,1)=I
33001 ISIG(NCHN,2)=J
33002 ISIG(NCHN,3)=2
33003 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33004 260 CONTINUE
33005 270 CONTINUE
33006 280 CONTINUE
33007
33008 ELSEIF(ISUB.EQ.75) THEN
33009C...W+ + W- -> gamma + gamma
33010
33011 ELSEIF(ISUB.EQ.76) THEN
33012C...W+ + W- -> Z0 + Z0
33013 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33014
33015 IF(MSTP(46).LE.2) THEN
33016C...Exact scattering ME:s for on-mass-shell gauge bosons
33017 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33018 CTH2=CTH**2
33019 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33020 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33021 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33022 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33023 & (1D0-2D0*SQMZ/SH)
33024 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33025 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33026 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33027 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33028 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33029 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33030 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33031 ATWIM=0D0
33032 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33033 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33034 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33035 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33036 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33037 AUWIM=0D0
33038 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33039 A4IM=0D0
33040 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33041 & (SH/SQMW)**2*SH2
33042 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33043 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33044 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33045 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33046 & (ATWIM+AUWIM+A4IM)**2)
33047
33048 ELSE
33049C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33050 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33051 & ABS(A00U-A20U)**2
33052 ENDIF
33053 FACZZ=FACZZ*WIDS(23,1)
33054
33055 DO 300 I=MMIN1,MMAX1
33056 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33057 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33058 DO 290 J=MMIN2,MMAX2
33059 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33060 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33061 IF(EI*EJ.GT.0D0) GOTO 290
33062 NCHN=NCHN+1
33063 ISIG(NCHN,1)=I
33064 ISIG(NCHN,2)=J
33065 ISIG(NCHN,3)=1
33066 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33067 290 CONTINUE
33068 300 CONTINUE
33069 310 CONTINUE
33070
33071 ELSEIF(ISUB.EQ.77) THEN
33072C...W+/- + W+/- -> W+/- + W+/-
33073 IF(SH.LE.4.01D0*SQMW) GOTO 340
33074
33075 IF(MSTP(46).LE.2) THEN
33076C...Exact scattering ME:s for on-mass-shell gauge bosons
33077 BE2=1D0-4D0*SQMW/SH
33078 BE4=BE2**2
33079 CTH2=CTH**2
33080 CTH3=CTH**3
33081 TH=-0.5D0*SH*BE2*(1D0-CTH)
33082 UH=-0.5D0*SH*BE2*(1D0+CTH)
33083 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33084 SHANG=(1D0+BE2)**2
33085 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33086 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33087 THANG=(BE2-CTH)**2
33088 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33089 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33090 UHANG=(BE2+CTH)**2
33091 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33092 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33093 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33094 ASGRE=XW*SGZANG
33095 ASGIM=0D0
33096 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33097 ASZIM=0D0
33098 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33099 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33100 ATGRE=0.5D0*XW*SH/TH*TGZANG
33101 ATGIM=0D0
33102 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33103 ATZIM=0D0
33104 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33105 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33106 AUGRE=0.5D0*XW*SH/UH*UGZANG
33107 AUGIM=0D0
33108 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33109 AUZIM=0D0
33110 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33111 A4AIM=0D0
33112 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33113 A4SIM=0D0
33114 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33115 & (SH/SQMW)**2*SH2
33116 IF(MSTP(46).LE.0) THEN
33117 AWWARE=ASHRE
33118 AWWAIM=ASHIM
33119 AWWSRE=0D0
33120 AWWSIM=0D0
33121 ELSEIF(MSTP(46).EQ.1) THEN
33122 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33123 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33124 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33125 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33126 ELSE
33127 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33128 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33129 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33130 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33131 ENDIF
33132 AWWA2=AWWARE**2+AWWAIM**2
33133 AWWS2=AWWSRE**2+AWWSIM**2
33134
33135 ELSE
33136C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33137 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33138 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
33139 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
33140 ENDIF
33141
33142 DO 330 I=MMIN1,MMAX1
33143 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
33144 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33145 DO 320 J=MMIN2,MMAX2
33146 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
33147 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33148 IF(EI*EJ.LT.0D0) THEN
33149C...W+W-
33150 IF(MSTP(45).EQ.1) GOTO 320
33151 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
33152 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
33153 ELSE
33154C...W+W+/W-W-
33155 IF(MSTP(45).EQ.2) GOTO 320
33156 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
33157 IF(MSTP(46).GE.3) FACWW=FWWS
33158 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
33159 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
33160 ENDIF
33161 NCHN=NCHN+1
33162 ISIG(NCHN,1)=I
33163 ISIG(NCHN,2)=J
33164 ISIG(NCHN,3)=1
33165 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
33166 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
33167 320 CONTINUE
33168 330 CONTINUE
33169 340 CONTINUE
33170 ENDIF
33171
33172 ELSEIF(ISUB.LE.120) THEN
33173 IF(ISUB.EQ.102) THEN
33174C...g + g -> h0 (or H0, or A0)
33175 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33176 WDTP13=0D0
33177 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33178 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33179 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33180 345 CONTINUE
33181 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33182 & '(PYSGHG:) did not find Higgs -> g g channel')
33183 HS=SHR*WDTP(0)
33184 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33185 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33186 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33187 & FACBW=0D0
33188 HI=SHR*WDTP13/32D0
33189 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
33190 NCHN=NCHN+1
33191 ISIG(NCHN,1)=21
33192 ISIG(NCHN,2)=21
33193 ISIG(NCHN,3)=1
33194 SIGH(NCHN)=HI*FACBW*HF
33195 350 CONTINUE
33196
33197 ELSEIF(ISUB.EQ.103) THEN
33198C...gamma + gamma -> h0 (or H0, or A0)
33199 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33200 WDTP14=0D0
33201 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33202 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
33203 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
33204 355 CONTINUE
33205 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
33206 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33207 HS=SHR*WDTP(0)
33208 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33209 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33210 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33211 & FACBW=0D0
33212 HI=SHR*WDTP14*2D0
33213 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
33214 NCHN=NCHN+1
33215 ISIG(NCHN,1)=22
33216 ISIG(NCHN,2)=22
33217 ISIG(NCHN,3)=1
33218 SIGH(NCHN)=HI*FACBW*HF
33219 360 CONTINUE
33220
33221 ELSEIF(ISUB.EQ.110) THEN
33222C...f + fbar -> gamma + h0
33223 THUH=MAX(TH*UH,SH*CKIN(3)**2)
33224 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
33225 FACHG=FACHG*WIDS(KFHIGG,2)
33226C...Calculate loop contributions for intermediate gamma* and Z0
33227 CIGTOT=DCMPLX(0D0,0D0)
33228 CIZTOT=DCMPLX(0D0,0D0)
33229 JMAX=3*MSTP(1)+1
33230 DO 370 J=1,JMAX
33231 IF(J.LE.2*MSTP(1)) THEN
33232 FNC=1D0
33233 EJ=KCHG(J,1)/3D0
33234 AJ=SIGN(1D0,EJ+0.1D0)
33235 VJ=AJ-4D0*EJ*XWV
33236 BALP=SQM4/(2D0*PMAS(J,1))**2
33237 BBET=SH/(2D0*PMAS(J,1))**2
33238 ELSEIF(J.LE.3*MSTP(1)) THEN
33239 FNC=3D0
33240 JL=2*(J-2*MSTP(1))-1
33241 EJ=KCHG(10+JL,1)/3D0
33242 AJ=SIGN(1D0,EJ+0.1D0)
33243 VJ=AJ-4D0*EJ*XWV
33244 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
33245 BBET=SH/(2D0*PMAS(10+JL,1))**2
33246 ELSE
33247 BALP=SQM4/(2D0*PMAS(24,1))**2
33248 BBET=SH/(2D0*PMAS(24,1))**2
33249 ENDIF
33250 BABI=1D0/(BALP-BBET)
33251 IF(BALP.LT.1D0) THEN
33252 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
33253 F1ALP=F0ALP**2
33254 ELSE
33255 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
33256 & -DBLE(0.5D0*PARU(1)))
33257 F1ALP=-F0ALP**2
33258 ENDIF
33259 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
33260 IF(BBET.LT.1D0) THEN
33261 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
33262 F1BET=F0BET**2
33263 ELSE
33264 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
33265 & -DBLE(0.5D0*PARU(1)))
33266 F1BET=-F0BET**2
33267 ENDIF
33268 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
33269 IF(J.LE.3*MSTP(1)) THEN
33270 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
33271 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
33272 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
33273 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
33274 ELSE
33275 TXW=XW/XW1
33276 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
33277 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
33278 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
33279 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
33280 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
33281 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
33282 & (F1BET-F1ALP))
33283 ENDIF
33284 370 CONTINUE
33285 CIGTOT=CIGTOT/DBLE(SH)
33286 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
33287C...Loop over initial flavours
33288 DO 380 I=MMINA,MMAXA
33289 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
33290 EI=KCHG(IABS(I),1)/3D0
33291 AI=SIGN(1D0,EI)
33292 VI=AI-4D0*EI*XWV
33293 FCOI=1D0
33294 IF(IABS(I).LE.10) FCOI=FACA/3D0
33295 NCHN=NCHN+1
33296 ISIG(NCHN,1)=I
33297 ISIG(NCHN,2)=-I
33298 ISIG(NCHN,3)=1
33299 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
33300 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
33301 380 CONTINUE
33302
33303 ELSEIF(ISUB.EQ.111) THEN
33304C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
33305 IF(MSTP(38).NE.0) THEN
33306C...Simple case: only do gg <-> h exactly.
33307 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33308 WDTP13=0D0
33309 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33310 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33311 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33312 385 CONTINUE
33313 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33314 & '(PYSGHG:) did not find Higgs -> g g channel')
33315 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
33316 & (TH**2+UH**2)/(SH*SQM4)
33317C...Propagators: as simulated in PYOFSH and as desired
33318 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33319 GMMHC=SQRT(SQM4)*WDTP(0)
33320 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33321 & ((SQM4-SQMH)**2+GMMHC**2)
33322 FACGH=FACGH*HBW4C/HBW4
33323 ELSE
33324C...Messy case: do full loop integrals
33325 A5STUR=0D0
33326 A5STUI=0D0
33327 DO 390 I=1,2*MSTP(1)
33328 SQMQ=PMAS(I,1)**2
33329 EPSS=4D0*SQMQ/SH
33330 EPSH=4D0*SQMQ/SQMH
33331 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33332 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33333 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33334 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33335 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
33336 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
33337 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
33338 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
33339 390 CONTINUE
33340 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33341 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
33342 FACGH=FACGH*WIDS(25,2)
33343 ENDIF
33344 DO 400 I=MMINA,MMAXA
33345 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33346 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33347 NCHN=NCHN+1
33348 ISIG(NCHN,1)=I
33349 ISIG(NCHN,2)=-I
33350 ISIG(NCHN,3)=1
33351 SIGH(NCHN)=FACGH
33352 400 CONTINUE
33353
33354 ELSEIF(ISUB.EQ.112) THEN
33355C...f + g -> f + h0 (q + g -> q + h0 only)
33356 IF(MSTP(38).NE.0) THEN
33357C...Simple case: only do gg <-> h exactly.
33358 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33359 WDTP13=0D0
33360 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33361 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33362 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33363 405 CONTINUE
33364 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33365 & '(PYSGHG:) did not find Higgs -> g g channel')
33366 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
33367 & (SH**2+UH**2)/(-TH*SQM4)
33368C...Propagators: as simulated in PYOFSH and as desired
33369 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33370 GMMHC=SQRT(SQM4)*WDTP(0)
33371 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33372 & ((SQM4-SQMH)**2+GMMHC**2)
33373 FACQH=FACQH*HBW4C/HBW4
33374 ELSE
33375C...Messy case: do full loop integrals
33376 A5TSUR=0D0
33377 A5TSUI=0D0
33378 DO 410 I=1,2*MSTP(1)
33379 SQMQ=PMAS(I,1)**2
33380 EPST=4D0*SQMQ/TH
33381 EPSH=4D0*SQMQ/SQMH
33382 CALL PYWAUX(1,EPST,W1TR,W1TI)
33383 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33384 CALL PYWAUX(2,EPST,W2TR,W2TI)
33385 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33386 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
33387 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
33388 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
33389 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
33390 410 CONTINUE
33391 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33392 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
33393 FACQH=FACQH*WIDS(25,2)
33394 ENDIF
33395 DO 430 I=MMINA,MMAXA
33396 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
33397 DO 420 ISDE=1,2
33398 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
33399 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
33400 NCHN=NCHN+1
33401 ISIG(NCHN,ISDE)=I
33402 ISIG(NCHN,3-ISDE)=21
33403 ISIG(NCHN,3)=1
33404 SIGH(NCHN)=FACQH
33405 420 CONTINUE
33406 430 CONTINUE
33407
33408 ELSEIF(ISUB.EQ.113) THEN
33409C...g + g -> g + h0
33410 IF(MSTP(38).NE.0) THEN
33411C...Simple case: only do gg <-> h exactly.
33412 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33413 WDTP13=0D0
33414 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33415 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33416 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33417 435 CONTINUE
33418 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33419 & '(PYSGHG:) did not find Higgs -> g g channel')
33420 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
33421 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
33422C...Propagators: as simulated in PYOFSH and as desired
33423 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33424 GMMHC=SQRT(SQM4)*WDTP(0)
33425 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33426 & ((SQM4-SQMH)**2+GMMHC**2)
33427 FACGH=FACGH*HBW4C/HBW4
33428 ELSE
33429C...Messy case: do full loop integrals
33430 A2STUR=0D0
33431 A2STUI=0D0
33432 A2USTR=0D0
33433 A2USTI=0D0
33434 A2TUSR=0D0
33435 A2TUSI=0D0
33436 A4STUR=0D0
33437 A4STUI=0D0
33438 DO 440 I=1,2*MSTP(1)
33439 SQMQ=PMAS(I,1)**2
33440 EPSS=4D0*SQMQ/SH
33441 EPST=4D0*SQMQ/TH
33442 EPSU=4D0*SQMQ/UH
33443 EPSH=4D0*SQMQ/SQMH
33444 IF(EPSH.LT.1D-6) GOTO 440
33445 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33446 CALL PYWAUX(1,EPST,W1TR,W1TI)
33447 CALL PYWAUX(1,EPSU,W1UR,W1UI)
33448 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33449 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33450 CALL PYWAUX(2,EPST,W2TR,W2TI)
33451 CALL PYWAUX(2,EPSU,W2UR,W2UI)
33452 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33453 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
33454 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
33455 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
33456 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
33457 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
33458 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
33459 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
33460 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
33461 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
33462 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
33463 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
33464 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
33465 W3STUR=YHSTUR-Y3STUR-Y3UTSR
33466 W3STUI=YHSTUI-Y3STUI-Y3UTSI
33467 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
33468 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
33469 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
33470 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
33471 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
33472 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
33473 W3USTR=YHUSTR-Y3USTR-Y3TSUR
33474 W3USTI=YHUSTI-Y3USTI-Y3TSUI
33475 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
33476 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
33477 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
33478 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
33479 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
33480 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
33481 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
33482 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
33483 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
33484 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
33485 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
33486 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
33487 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
33488 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
33489 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
33490 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
33491 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
33492 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
33493 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
33494 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
33495 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
33496 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
33497 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
33498 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
33499 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
33500 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
33501 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
33502 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
33503 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
33504 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
33505 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
33506 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
33507 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
33508 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
33509 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
33510 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
33511 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
33512 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
33513 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
33514 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
33515 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
33516 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
33517 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
33518 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
33519 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
33520 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
33521 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
33522 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
33523 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
33524 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
33525 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
33526 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
33527 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
33528 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
33529 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
33530 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
33531 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
33532 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
33533 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
33534 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
33535 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
33536 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
33537 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33538 & (W2SR-W2HR+W3STUR))
33539 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
33540 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33541 & (W2TR-W2HR+W3TUSR))
33542 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
33543 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33544 & (W2UR-W2HR+W3USTR))
33545 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
33546 A2STUR=A2STUR+B2STUR+B2SUTR
33547 A2STUI=A2STUI+B2STUI+B2SUTI
33548 A2USTR=A2USTR+B2USTR+B2UTSR
33549 A2USTI=A2USTI+B2USTI+B2UTSI
33550 A2TUSR=A2TUSR+B2TUSR+B2TSUR
33551 A2TUSI=A2TUSI+B2TUSI+B2TSUI
33552 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
33553 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
33554 440 CONTINUE
33555 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
33556 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
33557 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
33558 FACGH=FACGH*WIDS(25,2)
33559 ENDIF
33560 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
33561 NCHN=NCHN+1
33562 ISIG(NCHN,1)=21
33563 ISIG(NCHN,2)=21
33564 ISIG(NCHN,3)=1
33565 SIGH(NCHN)=FACGH
33566 450 CONTINUE
33567 ENDIF
33568
33569 ELSEIF(ISUB.LE.170) THEN
33570 IF(ISUB.EQ.121) THEN
33571C...g + g -> Q + Qbar + h0
33572 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
33573 IA=KFPR(ISUBSV,2)
33574 PMF=PYMRUN(IA,SH)
33575 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33576 & (0.5D0*PMF/PMAS(24,1))**2
33577 WID2=1D0
33578 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33579 FACQQH=FACQQH*WID2
33580 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33581 IKFI=1
33582 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33583 IF(IA.GT.10) IKFI=3
33584 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33585 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33586 FACQQH=FACQQH/(1D0+RMSS(41))**2
33587 IF(IHIGG.NE.3) THEN
33588 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33589 & PARU(151+10*IHIGG))**2
33590 ENDIF
33591 ENDIF
33592 ENDIF
33593 CALL PYQQBH(WTQQBH)
33594 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33595 HS=SHR*WDTP(0)
33596 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33597 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33598 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33599 & FACBW=0D0
33600 NCHN=NCHN+1
33601 ISIG(NCHN,1)=21
33602 ISIG(NCHN,2)=21
33603 ISIG(NCHN,3)=1
33604 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33605 460 CONTINUE
33606
33607 ELSEIF(ISUB.EQ.122) THEN
33608C...q + qbar -> Q + Qbar + h0
33609 IA=KFPR(ISUBSV,2)
33610 PMF=PYMRUN(IA,SH)
33611 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33612 & (0.5D0*PMF/PMAS(24,1))**2
33613 WID2=1D0
33614 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33615 FACQQH=FACQQH*WID2
33616 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33617 IKFI=1
33618 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33619 IF(IA.GT.10) IKFI=3
33620 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33621 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33622 FACQQH=FACQQH/(1D0+RMSS(41))**2
33623 IF(IHIGG.NE.3) THEN
33624 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33625 & PARU(151+10*IHIGG))**2
33626 ENDIF
33627 ENDIF
33628 ENDIF
33629 CALL PYQQBH(WTQQBH)
33630 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33631 HS=SHR*WDTP(0)
33632 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33633 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33634 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33635 & FACBW=0D0
33636 DO 470 I=MMINA,MMAXA
33637 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33638 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
33639 NCHN=NCHN+1
33640 ISIG(NCHN,1)=I
33641 ISIG(NCHN,2)=-I
33642 ISIG(NCHN,3)=1
33643 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33644 470 CONTINUE
33645
33646 ELSEIF(ISUB.EQ.123) THEN
33647C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
33648C...inner process)
33649 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
33650 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33651 & PARU(154+10*IHIGG)**2
33652 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33653 & (VINT(216)-VINT(209)**2))**2
33654 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33655 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
33656 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33657 HS=SHR*WDTP(0)
33658 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33659 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33660 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33661 & FACBW=0D0
33662 DO 490 I=MMIN1,MMAX1
33663 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
33664 IA=IABS(I)
33665 DO 480 J=MMIN2,MMAX2
33666 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
33667 JA=IABS(J)
33668 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
33669 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
33670 VI=AI-4D0*EI*XWV
33671 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
33672 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
33673 VJ=AJ-4D0*EJ*XWV
33674 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
33675 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
33676 NCHN=NCHN+1
33677 ISIG(NCHN,1)=I
33678 ISIG(NCHN,2)=J
33679 ISIG(NCHN,3)=1
33680 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
33681 480 CONTINUE
33682 490 CONTINUE
33683
33684 ELSEIF(ISUB.EQ.124) THEN
33685C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
33686C...inner process)
33687 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
33688 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33689 & PARU(155+10*IHIGG)**2
33690 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33691 & (VINT(216)-VINT(209)**2))**2
33692 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33693 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33694 HS=SHR*WDTP(0)
33695 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33696 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33697 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33698 & FACBW=0D0
33699 DO 510 I=MMIN1,MMAX1
33700 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
33701 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33702 DO 500 J=MMIN2,MMAX2
33703 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
33704 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33705 IF(EI*EJ.GT.0D0) GOTO 500
33706 FACLR=VINT(180+I)*VINT(180+J)
33707 NCHN=NCHN+1
33708 ISIG(NCHN,1)=I
33709 ISIG(NCHN,2)=J
33710 ISIG(NCHN,3)=1
33711 SIGH(NCHN)=FACLR*FACWW*FACBW
33712 500 CONTINUE
33713 510 CONTINUE
33714
33715 ELSEIF(ISUB.EQ.143) THEN
33716C...f + fbar' -> H+/-
33717 SQMHC=PMAS(37,1)**2
33718 CALL PYWIDT(37,SH,WDTP,WDTE)
33719 HS=SHR*WDTP(0)
33720 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
33721 HP=AEM/(8D0*XW)*SH/SQMW*SH
33722 DO 530 I=MMIN1,MMAX1
33723 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
33724 IA=IABS(I)
33725 IM=(MOD(IA,10)+1)/2
33726 DO 520 J=MMIN2,MMAX2
33727 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
33728 JA=IABS(J)
33729 JM=(MOD(JA,10)+1)/2
33730 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
33731 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33732 & GOTO 520
33733 IF(MOD(IA,2).EQ.0) THEN
33734 IU=IA
33735 IL=JA
33736 ELSE
33737 IU=JA
33738 IL=IA
33739 ENDIF
33740 RML=PYMRUN(IL,SH)**2/SH
33741 RMU=PYMRUN(IU,SH)**2/SH
33742 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
33743 IF(IA.LE.10) HI=HI*FACA/3D0
33744 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33745 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
33746 NCHN=NCHN+1
33747 ISIG(NCHN,1)=I
33748 ISIG(NCHN,2)=J
33749 ISIG(NCHN,3)=1
33750 SIGH(NCHN)=HI*FACBW*HF
33751 520 CONTINUE
33752 530 CONTINUE
33753
33754 ELSEIF(ISUB.EQ.161) THEN
33755C...f + g -> f' + H+/- (b + g -> t + H+/- only)
33756C...(choice of only b and t to avoid kinematics problems)
33757 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
33758C...H propagator: as simulated in PYOFSH and as desired
33759 SQMHC=PMAS(37,1)**2
33760 GMMHC=PMAS(37,1)*PMAS(37,2)
33761 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33762 CALL PYWIDT(37,SQM4,WDTP,WDTE)
33763 GMMHCC=SQRT(SQM4)*WDTP(0)
33764 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33765 FHCQ=FHCQ*HBW4C/HBW4
33766 Q2RM=SH
33767 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
33768 DO 550 I=MMINA,MMAXA
33769 IA=IABS(I)
33770 IF(IA.NE.5) GOTO 550
33771 SQML=PYMRUN(IA,Q2RM)**2
33772 IUA=IA+MOD(IA,2)
33773 SQMQ=PYMRUN(IUA,Q2RM)**2
33774 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
33775 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33776 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
33777 & (SQMHC-SQMQ-SH)/SH)
33778 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33779 DO 540 ISDE=1,2
33780 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
33781 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
33782 NCHN=NCHN+1
33783 ISIG(NCHN,ISDE)=I
33784 ISIG(NCHN,3-ISDE)=21
33785 ISIG(NCHN,3)=1
33786 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
33787 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
33788 540 CONTINUE
33789 550 CONTINUE
33790 ENDIF
33791
33792 ELSEIF(ISUB.LE.402) THEN
33793 IF(ISUB.EQ.401) THEN
33794C... g + g -> t + bbar + H-
33795 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
33796 IA=KFPR(ISUBSV,2)
33797 CALL PYSTBH(WTTBH)
33798 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33799 HS=SHR*WDTP(0)
33800 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33801 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33802 & FACBW=0D0
33803 NCHN=NCHN+1
33804 ISIG(NCHN,1)=21
33805 ISIG(NCHN,2)=21
33806 ISIG(NCHN,3)=1
33807 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33808c Since we don't know yet if H+ or H-, assume H+
33809c when calculating suppression due to closed channels.
33810 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33811 IF(ABS(WIDS(37,2)-WIDS(37,3))
33812 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
33813 & ABS(WIDS(6,2)-WIDS(6,3))
33814 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
33815 WRITE(*,*)'Error: Process 401 cannot handle different'
33816 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33817 WRITE(*,*)'Execution stopped.'
33818 CALL PYSTOP(108)
33819 END IF
33820 560 CONTINUE
33821
33822 ELSEIF(ISUB.EQ.402) THEN
33823C... q + qbar -> t + bbar + H-
33824 IA=KFPR(ISUBSV,2)
33825 CALL PYSTBH(WTTBH)
33826 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33827 HS=SHR*WDTP(0)
33828 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33829 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33830 & FACBW=0D0
33831 DO 570 I=MMINA,MMAXA
33832 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33833 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
33834 NCHN=NCHN+1
33835 ISIG(NCHN,1)=I
33836 ISIG(NCHN,2)=-I
33837 ISIG(NCHN,3)=1
33838 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33839c Since we don't know yet if H+ or H-, assume H+
33840c when calculating suppression due to closed channels.
33841 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33842 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
33843 & .GE.1D-6.OR.
33844 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
33845 & .GE.1D-6) THEN
33846 WRITE(*,*)'Error: Process 402 cannot handle different'
33847 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33848 WRITE(*,*)'Execution stopped.'
33849 CALL PYSTOP(108)
33850 END IF
33851 570 CONTINUE
33852 ENDIF
33853 ENDIF
33854
33855 RETURN
33856 END
33857
33858C*********************************************************************
33859
33860C...PYSGSU
33861C...Subprocess cross sections for SUSY processes,
33862C...including Higgs pair production.
33863C...Auxiliary to PYSIGH.
33864
33865 SUBROUTINE PYSGSU(NCHN,SIGS)
33866
33867C...Double precision and integer declarations
33868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33869 IMPLICIT INTEGER(I-N)
33870 INTEGER PYK,PYCHGE,PYCOMP
33871C...Parameter statement to help give large particle numbers.
33872 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33873 &KEXCIT=4000000,KDIMEN=5000000)
33874C...Commonblocks
33875 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33876 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33877 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33878 COMMON/PYINT1/MINT(400),VINT(400)
33879 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33880 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33881 COMMON/PYINT4/MWID(500),WIDS(500,5)
33882 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33883 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33884 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33885 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33886 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33887 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33888 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33889 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
33890 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
33891C...Local arrays and complex variables
33892 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33893 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
33894 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
33895 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
33896
33897CMRENNA++
33898C...Z and W width, combinations of weak mixing angle
33899 ZWID=PMAS(23,2)
33900 WWID=PMAS(24,2)
33901 TANW=SQRT(XW/XW1)
33902 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33903
33904C...Convert almost equivalent SUSY processes into each other
33905C...Extract differences in flavours and couplings
33906
33907C...Sleptons and sneutrinos
33908 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33909 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33910 ISUB=201
33911 ILR=0
33912 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33913 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33914 ISUB=201
33915 ILR=1
33916 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33917 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33918 ISUB=203
33919 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33920 IF(ISUB.EQ.210) THEN
33921 RKF=2.0D0
33922 ELSEIF(ISUB.EQ.211) THEN
33923 RKF=SFMIX(15,1)**2
33924 ELSEIF(ISUB.EQ.212) THEN
33925 RKF=SFMIX(15,2)**2
33926 ENDIF
33927 ISUB=210
33928 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33929 IF(ISUB.EQ.213) THEN
33930 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33931 RKF=2.0D0
33932 ELSEIF(ISUB.EQ.214) THEN
33933 KFID=16
33934 RKF=1.0D0
33935 ENDIF
33936 ISUB=213
33937
33938C...Neutralinos
33939 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33940 IF(ISUB.EQ.216) THEN
33941 IZID1=1
33942 IZID2=1
33943 ELSEIF(ISUB.EQ.217) THEN
33944 IZID1=2
33945 IZID2=2
33946 ELSEIF(ISUB.EQ.218) THEN
33947 IZID1=3
33948 IZID2=3
33949 ELSEIF(ISUB.EQ.219) THEN
33950 IZID1=4
33951 IZID2=4
33952 ELSEIF(ISUB.EQ.220) THEN
33953 IZID1=1
33954 IZID2=2
33955 ELSEIF(ISUB.EQ.221) THEN
33956 IZID1=1
33957 IZID2=3
33958 ELSEIF(ISUB.EQ.222) THEN
33959 IZID1=1
33960 IZID2=4
33961 ELSEIF(ISUB.EQ.223) THEN
33962 IZID1=2
33963 IZID2=3
33964 ELSEIF(ISUB.EQ.224) THEN
33965 IZID1=2
33966 IZID2=4
33967 ELSEIF(ISUB.EQ.225) THEN
33968 IZID1=3
33969 IZID2=4
33970 ENDIF
33971 ISUB=216
33972
33973C...Charginos
33974 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33975 IF(ISUB.EQ.226) THEN
33976 IZID1=1
33977 IZID2=1
33978 ELSEIF(ISUB.EQ.227) THEN
33979 IZID1=2
33980 IZID2=2
33981 ELSEIF(ISUB.EQ.228) THEN
33982 IZID1=1
33983 IZID2=2
33984 ENDIF
33985 ISUB=226
33986
33987C...Neutralino + chargino
33988 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
33989 IF(ISUB.EQ.229) THEN
33990 IZID1=1
33991 IZID2=1
33992 ELSEIF(ISUB.EQ.230) THEN
33993 IZID1=1
33994 IZID2=2
33995 ELSEIF(ISUB.EQ.231) THEN
33996 IZID1=1
33997 IZID2=3
33998 ELSEIF(ISUB.EQ.232) THEN
33999 IZID1=1
34000 IZID2=4
34001 ELSEIF(ISUB.EQ.233) THEN
34002 IZID1=2
34003 IZID2=1
34004 ELSEIF(ISUB.EQ.234) THEN
34005 IZID1=2
34006 IZID2=2
34007 ELSEIF(ISUB.EQ.235) THEN
34008 IZID1=2
34009 IZID2=3
34010 ELSEIF(ISUB.EQ.236) THEN
34011 IZID1=2
34012 IZID2=4
34013 ENDIF
34014 ISUB=229
34015
34016C...Gluino + neutralino
34017 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34018 IF(ISUB.EQ.237) THEN
34019 IZID=1
34020 ELSEIF(ISUB.EQ.238) THEN
34021 IZID=2
34022 ELSEIF(ISUB.EQ.239) THEN
34023 IZID=3
34024 ELSEIF(ISUB.EQ.240) THEN
34025 IZID=4
34026 ENDIF
34027 ISUB=237
34028
34029C...Gluino + chargino
34030 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34031 IF(ISUB.EQ.241) THEN
34032 IZID=1
34033 ELSEIF(ISUB.EQ.242) THEN
34034 IZID=2
34035 ENDIF
34036 ISUB=241
34037
34038C...Squark + neutralino
34039 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34040 ILR=0
34041 IF(MOD(ISUB,2).NE.0) ILR=1
34042 IF(ISUB.LE.247) THEN
34043 IZID=1
34044 ELSEIF(ISUB.LE.249) THEN
34045 IZID=2
34046 ELSEIF(ISUB.LE.251) THEN
34047 IZID=3
34048 ELSEIF(ISUB.LE.253) THEN
34049 IZID=4
34050 ENDIF
34051 ISUB=246
34052 RKF=5D0
34053
34054C...Squark + chargino
34055 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34056 IF(ISUB.LE.255) THEN
34057 IZID=1
34058 ELSEIF(ISUB.LE.257) THEN
34059 IZID=2
34060 ENDIF
34061 IF(MOD(ISUB,2).EQ.0) THEN
34062 ILR=0
34063 ELSE
34064 ILR=1
34065 ENDIF
34066 ISUB=254
34067 RKF=5D0
34068
34069C...Squark + gluino
34070 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34071 ISUB=258
34072 RKF=4D0
34073
34074C...Stops
34075 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34076 ILR=0
34077 IF(ISUB.EQ.262) ILR=1
34078 ISUB=261
34079 ELSEIF(ISUB.EQ.265) THEN
34080 ISUB=264
34081
34082C...Squarks
34083 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34084 ILR=0
34085 IF(ISUB.LE.273) THEN
34086 IF(ISUB.EQ.273) ILR=1
34087 ISUB=271
34088 RKF=16D0
34089 ELSEIF(ISUB.LE.276) THEN
34090 IF(ISUB.EQ.276) ILR=1
34091 ISUB=274
34092 RKF=16D0
34093 ELSEIF(ISUB.LE.278) THEN
34094 IF(ISUB.EQ.278) ILR=1
34095 ISUB=277
34096 RKF=4D0
34097 ELSE
34098 IF(ISUB.EQ.280) ILR=1
34099 ISUB=279
34100 RKF=4D0
34101 ENDIF
34102C...Sbottoms
34103 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
34104 ILR=0
34105 IF(ISUB.LE.283) THEN
34106 IF(ISUB.EQ.283) ILR=1
34107 ISUB=271
34108 RKF=4D0
34109 ELSEIF(ISUB.LE.286) THEN
34110 IF(ISUB.EQ.286) ILR=1
34111 ISUB=274
34112 RKF=4D0
34113 ELSEIF(ISUB.LE.288) THEN
34114 IF(ISUB.EQ.288) ILR=1
34115 ISUB=277
34116 RKF=1D0
34117 ELSEIF(ISUB.LE.290) THEN
34118 IF(ISUB.EQ.290) ILR=1
34119 ISUB=279
34120 RKF=1D0
34121 ELSEIF(ISUB.LE.293) THEN
34122 IF(ISUB.EQ.293) ILR=1
34123 ISUB=271
34124 RKF=1D0
34125 ELSEIF(ISUB.EQ.296) THEN
34126 ILR=1
34127 ISUB=274
34128 RKF=1D0
34129C...Squark + gluino
34130 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
34131 ISUB=258
34132 RKF=1D0
34133 ENDIF
34134C...H+/- + H0
34135 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
34136 IF(ISUB.EQ.297) THEN
34137 RKF=.5D0*PARU(195)**2
34138 ELSEIF(ISUB.EQ.298) THEN
34139 RKF=.5D0*(1D0-PARU(195)**2)
34140 ENDIF
34141 ISUB=210
34142C...A0 + H0
34143 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
34144 IF(ISUB.EQ.299) THEN
34145 RKF=PARU(186)**2
34146 KFID=25
34147 ELSEIF(ISUB.EQ.300) THEN
34148 RKF=PARU(187)**2
34149 KFID=35
34150 ENDIF
34151 ISUB=213
34152C...H+ + H-
34153 ELSEIF(ISUB.EQ.301) THEN
34154 KFID=37
34155 RKF=1D0
34156 ISUB=201
34157 ENDIF
34158
34159C...Supersymmetric processes - all of type 2 -> 2 :
34160C...correct final-state Breit-Wigners from fixed to running width.
34161 IF(MSTP(42).GT.0) THEN
34162 DO 100 I=1,2
34163 KFLW=KFPR(ISUBSV,I)
34164 KCW=PYCOMP(KFLW)
34165 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
34166 IF(I.EQ.1) SQMI=SQM3
34167 IF(I.EQ.2) SQMI=SQM4
34168 SQMS=PMAS(KCW,1)**2
34169 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
34170 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
34171 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
34172 GMMI=SQRT(SQMI)*WDTP(0)
34173 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
34174 COMFAC=COMFAC*(HBWI/HBWS)
34175 100 CONTINUE
34176 ENDIF
34177
34178C...Differential cross section expressions.
34179
34180 IF(ISUB.LE.210) THEN
34181 IF(ISUB.EQ.201) THEN
34182C...f + fbar -> e_L + e_Lbar
34183 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34184 DO 130 I=MMIN1,MMAX1
34185 IA=IABS(I)
34186 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
34187 EI=KCHG(IA,1)/3D0
34188 TT3I=SIGN(1D0,EI+1D-6)/2D0
34189 EJ=-1D0
34190 TT3J=-1D0/2D0
34191 FCOL=1D0
34192C...Color factor for e+ e-
34193 IF(IA.GE.11) FCOL=3D0
34194 IF(ISUBSV.EQ.301) THEN
34195 A1=1D0
34196 A2=0D0
34197 ELSEIF(ILR.EQ.1) THEN
34198 A1=SFMIX(KFID,3)**2
34199 A2=SFMIX(KFID,4)**2
34200 ELSEIF(ILR.EQ.0) THEN
34201 A1=SFMIX(KFID,1)**2
34202 A2=SFMIX(KFID,2)**2
34203 ENDIF
34204 XLQ=(TT3J-EJ*XW)*A1
34205 XRQ=(-EJ*XW)*A2
34206 XLF=(TT3I-EI*XW)
34207 XRF=(-EI*XW)
34208 TAA=(EI*EJ)**2*(POLL+POLR)
34209 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
34210 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
34211 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
34212 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34213 TNN=0.0D0
34214 TAN=0.0D0
34215 TZN=0.0D0
34216 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34217 FAC2=SQRT(2D0)
34218 TNN1=0D0
34219 TNN2=0D0
34220 TNN3=0D0
34221 DO 120 II=1,4
34222 DK=1D0/(TH-SMZ(II)**2)
34223 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34224 & ZMIX(II,1))
34225 FREK=FAC2*TANW*EI*ZMIX(II,1)
34226 TNN1=TNN1+FLEK**2*DK
34227 TNN2=TNN2+FREK**2*DK
34228 DO 110 JJ=1,4
34229 DL=1D0/(TH-SMZ(JJ)**2)
34230 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34231 & ZMIX(JJ,1))
34232 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34233 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34234 110 CONTINUE
34235 120 CONTINUE
34236 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
34237 & A2**2*TNN2**2*POLR)
34238 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
34239 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
34240 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
34241 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
34242 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34243 & (1D0-SQMZ/SH)/SH
34244 TZN=TZN/XW**2/XW1
34245 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
34246 & A2*TNN2*POLR)/XW
34247 ENDIF
34248 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
34249 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
34250 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
34251 NCHN=NCHN+1
34252 ISIG(NCHN,1)=I
34253 ISIG(NCHN,2)=-I
34254 ISIG(NCHN,3)=1
34255 SIGH(NCHN)=FACQQ1+FACQQ2
34256 130 CONTINUE
34257
34258 ELSEIF(ISUB.EQ.203) THEN
34259C...f + fbar -> e_L + e_Rbar
34260 DO 160 I=MMIN1,MMAX1
34261 IA=IABS(I)
34262 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
34263 EI=KCHG(IABS(I),1)/3D0
34264 TT3I=SIGN(1D0,EI)/2D0
34265 EJ=-1
34266 TT3J=-1D0/2D0
34267 FCOL=1D0
34268C...Color factor for e+ e-
34269 IF(IA.GE.11) FCOL=3D0
34270 A1=SFMIX(KFID,1)**2
34271 A2=SFMIX(KFID,2)**2
34272 XLQ=(TT3J-EJ*XW)
34273 XRQ=(-EJ*XW)
34274 XLF=(TT3I-EI*XW)
34275 XRF=(-EI*XW)
34276 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
34277 & /XW**2/XW1**2*A1*A2
34278 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34279 TNN=0.0D0
34280 TZN=0.0D0
34281 TNNA=0D0
34282 TNNB=0D0
34283 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34284 FAC2=SQRT(2D0)
34285 TNN1=0D0
34286 TNN2=0D0
34287 TNN3=0D0
34288 DO 150 II=1,4
34289 DK=1D0/(TH-SMZ(II)**2)
34290 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34291 & ZMIX(II,1))
34292 FREK=FAC2*TANW*EI*ZMIX(II,1)
34293 TNN1=TNN1+FLEK**2*DK
34294 TNN2=TNN2+FREK**2*DK
34295 DO 140 JJ=1,4
34296 DL=1D0/(TH-SMZ(JJ)**2)
34297 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34298 & ZMIX(JJ,1))
34299 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34300 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34301 140 CONTINUE
34302 150 CONTINUE
34303 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
34304 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
34305 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
34306 TZN=(UH*TH-SQM3*SQM4)*A1*A2
34307 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
34308 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34309 & (1D0-SQMZ/SH)/SH
34310 ENDIF
34311 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
34312 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
34313 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
34314C%%%%%%%%%%%
34315 NCHN=NCHN+1
34316 ISIG(NCHN,1)=I
34317 ISIG(NCHN,2)=-I
34318 ISIG(NCHN,3)=1
34319 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34320 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34321 NCHN=NCHN+1
34322 ISIG(NCHN,1)=I
34323 ISIG(NCHN,2)=-I
34324 ISIG(NCHN,3)=2
34325 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34326 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34327 160 CONTINUE
34328
34329 ELSEIF(ISUB.EQ.210) THEN
34330C...q + qbar' -> W*- > ~l_L + ~nu_L
34331 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
34332 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
34333 DO 180 I=MMIN1,MMAX1
34334 IA=IABS(I)
34335 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
34336 DO 170 J=MMIN2,MMAX2
34337 JA=IABS(J)
34338 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
34339 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
34340 FCKM=3D0
34341 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34342 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34343 KCHW=2
34344 IF(KCHSUM.LT.0) KCHW=3
34345 NCHN=NCHN+1
34346 ISIG(NCHN,1)=I
34347 ISIG(NCHN,2)=J
34348 ISIG(NCHN,3)=1
34349 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
34350 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34351 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34352 ELSE
34353 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34354 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34355 ENDIF
34356 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
34357 170 CONTINUE
34358 180 CONTINUE
34359 ENDIF
34360
34361 ELSEIF(ISUB.LE.220) THEN
34362 IF(ISUB.EQ.213) THEN
34363C...f + fbar -> ~nu_L + ~nu_Lbar
34364 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
34365 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34366 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34367 ELSE
34368 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34369 ENDIF
34370 COMFAC=COMFAC*FACR
34371 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
34372 XLL=0.5D0
34373 XLR=0.0D0
34374 DO 190 I=MMIN1,MMAX1
34375 IA=IABS(I)
34376 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
34377 EI=KCHG(IA,1)/3D0
34378 FCOL=1D0
34379C...Color factor for e+ e-
34380 IF(IA.GE.11) FCOL=3D0
34381 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
34382 XRQ=-EI*XW
34383 TZC=0.0D0
34384 TCC=0.0D0
34385 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
34386 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
34387 & (TH-SMW(2)**2)
34388 TCC=TZC**2
34389 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
34390 ENDIF
34391 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
34392 FACQQ2=TZC+TCC/4D0
34393 NCHN=NCHN+1
34394 ISIG(NCHN,1)=I
34395 ISIG(NCHN,2)=-I
34396 ISIG(NCHN,3)=1
34397 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
34398 & *AEM**2*FCOL/3D0/XW**2
34399 190 CONTINUE
34400
34401 ELSEIF(ISUB.EQ.216) THEN
34402C...q + qbar -> ~chi0_1 + ~chi0_1
34403 IF(IZID1.EQ.IZID2) THEN
34404 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34405 ELSE
34406 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34407 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34408 ENDIF
34409 FACXX=COMFAC*AEM**2/3D0/XW**2
34410 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
34411 ZM12=SQM3
34412 ZM22=SQM4
34413 WU2 = (UH-ZM12)*(UH-ZM22)
34414 WT2 = (TH-ZM12)*(TH-ZM22)
34415 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
34416 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34417 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34418 DO 200 I=1,4
34419 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
34420 IF(IZID2.NE.IZID1) THEN
34421 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34422 ENDIF
34423 200 CONTINUE
34424 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
34425 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
34426 ORPP=DCONJG(OLPP)
34427 DO 210 I=MMINA,MMAXA
34428 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
34429 EI=KCHG(IABS(I),1)/3D0
34430 T3I=SIGN(1D0,EI+1D-6)/2D0
34431 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
34432 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
34433 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
34434 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
34435 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
34436 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
34437 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
34438 & /DCMPLX(TH-XML2)
34439 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
34440 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
34441 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
34442 FCOL=1D0
34443 IF(IABS(I).GE.11) FCOL=3D0
34444 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34445 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34446 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34447 & QRL*DCONJG(QRR)*POLR)*WS2
34448 NCHN=NCHN+1
34449 ISIG(NCHN,1)=I
34450 ISIG(NCHN,2)=-I
34451 ISIG(NCHN,3)=1
34452 SIGH(NCHN)=FACXX*FACGG1*FCOL
34453 210 CONTINUE
34454 ENDIF
34455
34456 ELSEIF(ISUB.LE.230) THEN
34457 IF(ISUB.EQ.226) THEN
34458C...f + fbar -> ~chi+_1 + ~chi-_1
34459 FACXX=COMFAC*AEM**2/3D0
34460 ZM12=SQM3
34461 ZM22=SQM4
34462 WU2 = (UH-ZM12)*(UH-ZM22)
34463 WT2 = (TH-ZM12)*(TH-ZM22)
34464 WS2 = SMW(IZID1)*SMW(IZID2)*SH
34465 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34466 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34467 DIFF=0D0
34468 IF(IZID1.EQ.IZID2) DIFF=1D0
34469 DO 220 I=1,2
34470 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34471 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34472 IF(IZID2.NE.IZID1) THEN
34473 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
34474 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
34475 ENDIF
34476 220 CONTINUE
34477 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
34478 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
34479 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
34480 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
34481 DO 230 I=MMINA,MMAXA
34482 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
34483 EI=KCHG(IABS(I),1)/3D0
34484 T3I=SIGN(1D0,EI+1D-6)/2D0
34485 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
34486 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
34487 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
34488 IF(MOD(I,2).EQ.0) THEN
34489 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
34490 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34491 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
34492 & DCMPLX(T3I/XW/(TH-XML2))
34493 ELSE
34494 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
34495 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34496 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
34497 & DCMPLX(T3I/XW/(TH-XML2))
34498 ENDIF
34499 FCOL=1D0
34500 IF(IABS(I).GE.11) FCOL=3D0
34501 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34502 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34503 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34504 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
34505 NCHN=NCHN+1
34506 ISIG(NCHN,1)=I
34507 ISIG(NCHN,2)=-I
34508 ISIG(NCHN,3)=1
34509 IF(IZID1.EQ.IZID2) THEN
34510 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34511 ELSE
34512 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34513 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34514 NCHN=NCHN+1
34515 ISIG(NCHN,1)=I
34516 ISIG(NCHN,2)=-I
34517 ISIG(NCHN,3)=2
34518 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34519 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34520 ENDIF
34521 230 CONTINUE
34522
34523 ELSEIF(ISUB.EQ.229) THEN
34524C...q + qbar' -> ~chi0_1 + ~chi+-_1
34525 FACXX=COMFAC*AEM**2/6D0/XW**2
34526 ZM12=SQM3
34527 ZM22=SQM4
34528 WU2 = (UH-ZM12)*(UH-ZM22)
34529 WT2 = (TH-ZM12)*(TH-ZM22)
34530 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
34531 RT2I = 1D0/SQRT(2D0)
34532 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
34533 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
34534 DO 240 I=1,2
34535 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34536 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34537 240 CONTINUE
34538 DO 250 I=1,4
34539 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34540 250 CONTINUE
34541 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
34542 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
34543 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
34544 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
34545
34546 DO 270 I=MMIN1,MMAX1
34547 IA=IABS(I)
34548 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
34549 EI=KCHG(IA,1)/3D0
34550 T3I=SIGN(1D0,EI+1D-6)/2D0
34551 DO 260 J=MMIN2,MMAX2
34552 JA=IABS(J)
34553 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
34554 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
34555 EJ=KCHG(JA,1)/3D0
34556 T3J=SIGN(1D0,EJ+1D-6)/2D0
34557 FCKM=3D0
34558 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34559 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34560 KCHW=2
34561 IF(KCHSUM.LT.0) KCHW=3
34562 IF(MOD(IA,2).EQ.0) THEN
34563 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34564 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34565 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
34566 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
34567 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34568 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
34569 & /DCMPLX(TH-ZMJ2)
34570 ELSE
34571 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34572 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34573 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
34574 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
34575 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34576 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
34577 & /DCMPLX(TH-ZMI2)
34578 ENDIF
34579 ZINTR=DBLE(QLR*DCONJG(QLL))
34580 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
34581 & 2D0*ZINTR*WS2)
34582 NCHN=NCHN+1
34583 ISIG(NCHN,1)=I
34584 ISIG(NCHN,2)=J
34585 ISIG(NCHN,3)=1
34586 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34587 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34588 260 CONTINUE
34589 270 CONTINUE
34590 ENDIF
34591
34592 ELSEIF(ISUB.LE.240) THEN
34593 IF(ISUB.EQ.237) THEN
34594C...q + qbar -> gluino + ~chi0_1
34595 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34596 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34597 ASYUK=RMSS(42)*AS
34598 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
34599 GM2=SQM3
34600 ZM2=SQM4
34601 DO 280 I=MMINA,MMAXA
34602 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
34603 EI=KCHG(IABS(I),1)/3D0
34604 IA=IABS(I)
34605 XLQC = -TANW*EI*ZMIX(IZID,1)
34606 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34607 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34608 XLQ2=XLQC**2
34609 XRQ2=XRQC**2
34610 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
34611 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
34612 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
34613 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
34614 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
34615 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34616 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
34617 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
34618 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
34619 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34620 NCHN=NCHN+1
34621 ISIG(NCHN,1)=I
34622 ISIG(NCHN,2)=-I
34623 ISIG(NCHN,3)=1
34624 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
34625 280 CONTINUE
34626 ENDIF
34627
34628 ELSEIF(ISUB.LE.250) THEN
34629 IF(ISUB.EQ.241) THEN
34630C...q + qbar' -> ~chi+-_1 + gluino
34631 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
34632 GM2=SQM3
34633 ZM2=SQM4
34634 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
34635 FAC0=UMIX(IZID,1)**2
34636 FAC1=VMIX(IZID,1)**2
34637 DO 300 I=MMIN1,MMAX1
34638 IA=IABS(I)
34639 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
34640 DO 290 J=MMIN2,MMAX2
34641 JA=IABS(J)
34642 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
34643 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
34644 FCKM=1D0
34645 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34646 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34647 KCHW=2
34648 IF(KCHSUM.LT.0) KCHW=3
34649 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
34650 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
34651 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
34652 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
34653 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
34654 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
34655 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
34656 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
34657 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
34658 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
34659 & SH/(TH-XMU2)/(UH-XMD2))/2D0
34660 NCHN=NCHN+1
34661 ISIG(NCHN,1)=I
34662 ISIG(NCHN,2)=J
34663 ISIG(NCHN,3)=1
34664 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
34665 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34666 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34667 290 CONTINUE
34668 300 CONTINUE
34669
34670 ELSEIF(ISUB.EQ.243) THEN
34671C...q + qbar -> gluino + gluino
34672 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34673 XMT=SQM3-TH
34674 XMU=SQM3-UH
34675 DO 310 I=MMINA,MMAXA
34676 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34677 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
34678 NCHN=NCHN+1
34679 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
34680 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
34681 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34682 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34683 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34684 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34685 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
34686 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
34687 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34688 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34689 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34690 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34691 ISIG(NCHN,1)=I
34692 ISIG(NCHN,2)=-I
34693 ISIG(NCHN,3)=1
34694C...1/2 for identical particles
34695 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
34696 310 CONTINUE
34697
34698 ELSEIF(ISUB.EQ.244) THEN
34699C...g + g -> gluino + gluino
34700 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34701 XMT=SQM3-TH
34702 XMU=SQM3-UH
34703 FACQQ1=COMFAC*AS**2*9D0/4D0*(
34704 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
34705 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
34706 FACQQ2=COMFAC*AS**2*9D0/4D0*(
34707 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
34708 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
34709 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
34710 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
34711 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
34712 NCHN=NCHN+1
34713 ISIG(NCHN,1)=21
34714 ISIG(NCHN,2)=21
34715 ISIG(NCHN,3)=1
34716 SIGH(NCHN)=FACQQ1/2D0
34717 NCHN=NCHN+1
34718 ISIG(NCHN,1)=21
34719 ISIG(NCHN,2)=21
34720 ISIG(NCHN,3)=2
34721 SIGH(NCHN)=FACQQ2/2D0
34722 NCHN=NCHN+1
34723 ISIG(NCHN,1)=21
34724 ISIG(NCHN,2)=21
34725 ISIG(NCHN,3)=3
34726 SIGH(NCHN)=FACQQ3/2D0
34727 320 CONTINUE
34728
34729 ELSEIF(ISUB.EQ.246) THEN
34730C...g + q_j -> ~chi0_1 + ~q_j
34731 FAC0=COMFAC*AS*AEM/6D0/XW
34732 ZM2=SQM4
34733 QM2=SQM3
34734 FACZQ0=FAC0*( (ZM2-TH)/SH +
34735 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34736 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34737 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34738 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
34739 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
34740 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
34741 EI=KCHG(IABS(I),1)/3D0
34742 IA=IABS(I)
34743 XRQZ = -TANW*EI*ZMIX(IZID,1)
34744 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34745 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34746 IF(ILR.EQ.0) THEN
34747 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
34748 ELSE
34749 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
34750 ENDIF
34751 FACZQ=FACZQ0*BS
34752 KCHQ=2
34753 IF(I.LT.0) KCHQ=3
34754 DO 330 ISDE=1,2
34755 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
34756 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
34757 NCHN=NCHN+1
34758 ISIG(NCHN,ISDE)=I
34759 ISIG(NCHN,3-ISDE)=21
34760 ISIG(NCHN,3)=1
34761 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34762 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34763 330 CONTINUE
34764 340 CONTINUE
34765 ENDIF
34766
34767 ELSEIF(ISUB.LE.260) THEN
34768 IF(ISUB.EQ.254) THEN
34769C...g + q_j -> ~chi1_1 + ~q_i
34770 FAC0=COMFAC*AS*AEM/12D0/XW
34771 ZM2=SQM4
34772 QM2=SQM3
34773 AU=UMIX(IZID,1)**2
34774 AD=VMIX(IZID,1)**2
34775 FACZQ0=FAC0*( (ZM2-TH)/SH +
34776 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34777 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34778 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
34779 IF(MOD(KFNSQ1,2).EQ.0) THEN
34780 KFNSQ=KFNSQ1-1
34781 KCHW=2
34782 ELSE
34783 KFNSQ=KFNSQ1+1
34784 KCHW=3
34785 ENDIF
34786 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
34787 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
34788 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
34789 IA=IABS(I)
34790 IF(MOD(IA,2).EQ.0) THEN
34791 FACZQ=FACZQ0*AU
34792 ELSE
34793 FACZQ=FACZQ0*AD
34794 ENDIF
34795 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
34796 KCHQ=2
34797 IF(I.LT.0) KCHQ=3
34798 KCHWQ=KCHW
34799 IF(I.LT.0) KCHWQ=5-KCHW
34800 DO 350 ISDE=1,2
34801 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
34802 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
34803 NCHN=NCHN+1
34804 ISIG(NCHN,ISDE)=I
34805 ISIG(NCHN,3-ISDE)=21
34806 ISIG(NCHN,3)=1
34807 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34808 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
34809 350 CONTINUE
34810 360 CONTINUE
34811
34812 ELSEIF(ISUB.EQ.258) THEN
34813C...g + q_j -> gluino + ~q_i
34814 XG2=SQM4
34815 XQ2=SQM3
34816 XMT=XG2-TH
34817 XMU=XG2-UH
34818 XST=XQ2-TH
34819 XSU=XQ2-UH
34820 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
34821 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
34822 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
34823 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
34824 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
34825 & (SH*(UH+XG2)
34826 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
34827 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
34828 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
34829 ASYUK=RMSS(42)*AS
34830 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
34831 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
34832 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34833 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
34834 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
34835 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
34836 KCHQ=2
34837 IF(I.LT.0) KCHQ=3
34838 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34839 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34840 DO 370 ISDE=1,2
34841 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
34842 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
34843 NCHN=NCHN+1
34844 ISIG(NCHN,ISDE)=I
34845 ISIG(NCHN,3-ISDE)=21
34846 ISIG(NCHN,3)=1
34847 SIGH(NCHN)=FACQG1*FACSEL
34848 NCHN=NCHN+1
34849 ISIG(NCHN,ISDE)=I
34850 ISIG(NCHN,3-ISDE)=21
34851 ISIG(NCHN,3)=2
34852 SIGH(NCHN)=FACQG2*FACSEL
34853 370 CONTINUE
34854 380 CONTINUE
34855 ENDIF
34856
34857 ELSEIF(ISUB.LE.270) THEN
34858 IF(ISUB.EQ.261) THEN
34859C...q_i + q_ibar -> ~t_1 + ~t_1bar
34860 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
34861 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34862 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34863 FAC0=AS**2*4D0/9D0
34864 DO 390 I=MMIN1,MMAX1
34865 IA=IABS(I)
34866 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
34867 IF(IA.GE.11.AND.IA.LE.18) THEN
34868 EI=KCHG(IA,1)/3D0
34869 EJ=KCHG(KFNSQ,1)/3D0
34870 T3I=SIGN(1D0,EI)/2D0
34871 T3J=SIGN(1D0,EJ)/2D0
34872 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
34873 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
34874 XLF=2D0*(T3I-EI*XW)
34875 XRF=2D0*(-EI*XW)
34876 TAA=0.5D0*(EI*EJ)**2
34877 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34878 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34879 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34880 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34881 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34882 ENDIF
34883 NCHN=NCHN+1
34884 ISIG(NCHN,1)=I
34885 ISIG(NCHN,2)=-I
34886 ISIG(NCHN,3)=1
34887 SIGH(NCHN)=FACQQ1*FAC0
34888 390 CONTINUE
34889
34890 ELSEIF(ISUB.EQ.263) THEN
34891C...f + fbar -> ~t1 + ~t2bar
34892 DO 400 I=MMIN1,MMAX1
34893 IA=IABS(I)
34894 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34895 EI=KCHG(IABS(I),1)/3D0
34896 TT3I=SIGN(1D0,EI)/2D0
34897 EJ=2D0/3D0
34898 TT3J=1D0/2D0
34899 FCOL=1D0
34900C...Color factor for e+ e-
34901 IF(IA.GE.11) FCOL=3D0
34902 XLQ=2D0*(TT3J-EJ*XW)
34903 XRQ=2D0*(-EJ*XW)
34904 XLF=2D0*(TT3I-EI*XW)
34905 XRF=2D0*(-EI*XW)
34906 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34907 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34908 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34909C...Factor of 2 for t1 t2bar + t2 t1bar
34910 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34911 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34912 NCHN=NCHN+1
34913 ISIG(NCHN,1)=I
34914 ISIG(NCHN,2)=-I
34915 ISIG(NCHN,3)=1
34916 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34917 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34918 NCHN=NCHN+1
34919 ISIG(NCHN,1)=I
34920 ISIG(NCHN,2)=-I
34921 ISIG(NCHN,3)=2
34922 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34923 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34924 400 CONTINUE
34925
34926 ELSEIF(ISUB.EQ.264) THEN
34927C...g + g -> ~t_1 + ~t_1bar
34928 XSU=SQM3-UH
34929 XST=SQM3-TH
34930 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34931 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34932 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34933 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34934 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34935 NCHN=NCHN+1
34936 ISIG(NCHN,1)=21
34937 ISIG(NCHN,2)=21
34938 ISIG(NCHN,3)=1
34939 SIGH(NCHN)=FACQQ1
34940 NCHN=NCHN+1
34941 ISIG(NCHN,1)=21
34942 ISIG(NCHN,2)=21
34943 ISIG(NCHN,3)=2
34944 SIGH(NCHN)=FACQQ2
34945 410 CONTINUE
34946 ENDIF
34947
34948 ELSEIF(ISUB.LE.280) THEN
34949 IF(ISUB.EQ.271) THEN
34950C...q + q' -> ~q + ~q' (~g exchange)
34951 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34952 XMT=XMG2-TH
34953 XMU=XMG2-UH
34954 XSU1=SQM3-UH
34955 XSU2=SQM4-UH
34956 XST1=SQM3-TH
34957 XST2=SQM4-TH
34958 ASYUK=RMSS(42)*AS
34959 IF(ILR.EQ.1) THEN
34960 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34961 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34962 FACQQB=0.0D0
34963 ELSE
34964 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34965 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34966 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34967 & XMT/XMU )
34968 ENDIF
34969 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34970 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34971 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34972 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34973 IA=IABS(I)
34974 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34975 KCHQ=2
34976 IF(I.LT.0) KCHQ=3
34977 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34978 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
34979 JA=IABS(J)
34980 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
34981 IF(I*J.LT.0) GOTO 420
34982 NCHN=NCHN+1
34983 ISIG(NCHN,1)=I
34984 ISIG(NCHN,2)=J
34985 ISIG(NCHN,3)=1
34986 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34987 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34988 IF(I.EQ.J) THEN
34989 IF(ILR.EQ.0) THEN
34990 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
34991 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34992 ELSE
34993 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
34994 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34995 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34996 ENDIF
34997 NCHN=NCHN+1
34998 ISIG(NCHN,1)=I
34999 ISIG(NCHN,2)=J
35000 ISIG(NCHN,3)=2
35001 IF(ILR.EQ.0) THEN
35002 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35003 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35004 ELSE
35005 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35006 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35007 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35008 ENDIF
35009 ENDIF
35010 420 CONTINUE
35011 430 CONTINUE
35012
35013 ELSEIF(ISUB.EQ.274) THEN
35014C...q + qbar' -> ~q + ~qbar'
35015 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35016 XMT=XMG2-TH
35017 XMU=XMG2-UH
35018 IF(ILR.EQ.0) THEN
35019C...Mrenna...Normalization.and.1/XMT
35020 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35021 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35022 FACQQB=COMFAC*AS**2*4D0/9D0*(
35023 & (UH*TH-SQM3*SQM4)/SH2 )
35024 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35025 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35026 FACQQB=FACQQB+FACQQ1+FACQQI
35027 ELSE
35028 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35029 FACQQB=FACQQ1
35030 ENDIF
35031 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35032 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35033 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35034 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35035 IA=IABS(I)
35036 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35037 KCHQ=2
35038 IF(I.LT.0) KCHQ=3
35039 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35040 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35041 JA=IABS(J)
35042 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35043 IF(I*J.GT.0) GOTO 440
35044 NCHN=NCHN+1
35045 ISIG(NCHN,1)=I
35046 ISIG(NCHN,2)=J
35047 ISIG(NCHN,3)=1
35048 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35049 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35050 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35051 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35052 440 CONTINUE
35053 450 CONTINUE
35054
35055 ELSEIF(ISUB.EQ.277) THEN
35056C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35057C...if i .eq. j covered in 274
35058 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35059 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35060 FAC0=0D0
35061 DO 460 I=MMIN1,MMAX1
35062 IA=IABS(I)
35063 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35064 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35065 IF(IA.EQ.KFNSQ) GOTO 460
35066 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35067 EI=KCHG(IA,1)/3D0
35068 EJ=KCHG(KFNSQ,1)/3D0
35069 T3J=SIGN(0.5D0,EJ)
35070 T3I=SIGN(1D0,EI)/2D0
35071 IF(ILR.EQ.0) THEN
35072 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35073 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35074 ELSE
35075 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35076 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35077 ENDIF
35078 XLF=2D0*(T3I-EI*XW)
35079 XRF=2D0*(-EI*XW)
35080 IF(ILR.EQ.0) THEN
35081 XRQ=0D0
35082 ELSE
35083 XLQ=0D0
35084 ENDIF
35085 TAA=0.5D0*(EI*EJ)**2
35086 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35087 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35088 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35089 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35090 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35091 ELSEIF(IA.LE.6) THEN
35092 FAC0=AS**2*8D0/9D0/2D0
35093 ENDIF
35094 NCHN=NCHN+1
35095 ISIG(NCHN,1)=I
35096 ISIG(NCHN,2)=-I
35097 ISIG(NCHN,3)=1
35098 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35099 460 CONTINUE
35100
35101 ELSEIF(ISUB.EQ.279) THEN
35102C...g + g -> ~q_j + ~q_jbar
35103 XSU=SQM3-UH
35104 XST=SQM3-TH
35105C...5=RKF because ~t ~tbar treated separately
35106 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
35107 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35108 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35109 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
35110 NCHN=NCHN+1
35111 ISIG(NCHN,1)=21
35112 ISIG(NCHN,2)=21
35113 ISIG(NCHN,3)=1
35114 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35115 NCHN=NCHN+1
35116 ISIG(NCHN,1)=21
35117 ISIG(NCHN,2)=21
35118 ISIG(NCHN,3)=2
35119 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35120 470 CONTINUE
35121
35122 ENDIF
35123 ENDIF
35124CMRENNA--
35125
35126 RETURN
35127 END
35128
35129C*********************************************************************
35130
35131C...PYSGTC
35132C...Subprocess cross sections for Technicolor processes.
35133C...Auxiliary to PYSIGH.
35134
35135 SUBROUTINE PYSGTC(NCHN,SIGS)
35136
35137C...Double precision and integer declarations
35138 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35139 IMPLICIT INTEGER(I-N)
35140 INTEGER PYK,PYCHGE,PYCOMP
35141C...Parameter statement to help give large particle numbers.
35142 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35143 &KEXCIT=4000000,KDIMEN=5000000)
35144C...Commonblocks
35145 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35146 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35147 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35148 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35149 COMMON/PYINT1/MINT(400),VINT(400)
35150 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35151 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35152 COMMON/PYINT4/MWID(500),WIDS(500,5)
35153 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35154 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35155 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35156 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35157 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35158 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35159 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35160C...Local arrays and complex variables
35161 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35162 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35163 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35164 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35165 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35166 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35167 COMPLEX*16 DVVS,DVVT,DVVU
35168 INTEGER INDX(6)
35169
35170C...Combinations of weak mixing angle.
35171 TANW=SQRT(XW/XW1)
35172 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35173
35174C...Convert almost equivalent technicolor processes into
35175C...a few basic processes, and set distinguishing parameters.
35176 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
35177 SQTV=RTCM(12)**2
35178 SQTA=RTCM(13)**2
35179 SN2W=2D0*SQRT(XW*XW1)
35180 CS2W=1D0-2D0*XW
35181 CT2W=CS2W/SN2W
35182 CSXI=COS(ASIN(RTCM(3)))
35183 CSXIP=COS(ASIN(RTCM(4)))
35184 QUPD=2D0*RTCM(2)-1D0
35185 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
35186 CAB2=0D0
35187 VOGP=0D0
35188 VRGP=0D0
35189 AOGP=0D0
35190 ARGP=0D0
35191 VXGP=0D0
35192 AXGP=0D0
35193 VAGP=0D0
35194 VZGP=0D0
35195 VWGP=0D0
35196C... rho_tc0, etc. -> W_L W_L, W_L W_T
35197 IF(ISUB.EQ.361) THEN
35198 KFA=24
35199 KFB=24
35200 CAB2=RTCM(3)**4
35201 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35202 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35203 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
35204C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
35205 AXGP = SQRT(2D0)*AXGP
35206 ARGP = SQRT(2D0)*ARGP
35207 VOGP = SQRT(2D0)*VOGP
35208C... rho_tc0 -> W_L pi_tc-
35209 ELSEIF(ISUB.EQ.362) THEN
35210 KFA=24
35211 KFB=KTECHN+211
35212 ISUB=361
35213 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35214C... pi_tc pi_tc
35215 ELSEIF(ISUB.EQ.363) THEN
35216 KFA=KTECHN+211
35217 KFB=KTECHN+211
35218 ISUB=361
35219 CAB2=(1D0-RTCM(3)**2)**2
35220C... rho_tc0/omega_tc -> gamma pi_tc
35221 ELSEIF(ISUB.EQ.364) THEN
35222 KFA=22
35223 KFB=KTECHN+111
35224 ISUB=361
35225 VOGP=CSXI/RTCM(12)
35226 VRGP=VOGP*QUPD
35227 VAGP=2D0*QUPD*CSXI
35228 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35229C... gamma pi_tc'
35230 ELSEIF(ISUB.EQ.365) THEN
35231 KFA=22
35232 KFB=KTECHN+221
35233 ISUB=361
35234 VRGP=CSXIP/RTCM(12)
35235 VOGP=VRGP*QUPD
35236 VAGP=2D0*Q2UD*CSXIP
35237 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
35238C... Z pi_tc
35239 ELSEIF(ISUB.EQ.366) THEN
35240 KFA=23
35241 KFB=KTECHN+111
35242 ISUB=361
35243 VOGP=CSXI*CT2W/RTCM(12)
35244 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35245 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35246 VZGP=-QUPD*CSXI*CS2W/XW1
35247C... Z pi_tc'
35248 ELSEIF(ISUB.EQ.367) THEN
35249 KFA=23
35250 KFB=KTECHN+221
35251 ISUB=361
35252C...RTCM(48) is the M_V for the techni-a
35253 VXGP=-CSXIP/SN2W/RTCM(48)
35254 VRGP=CSXIP*CT2W/RTCM(12)
35255 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
35256 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
35257 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
35258C... W_T pi_tc
35259 ELSEIF(ISUB.EQ.368) THEN
35260 KFA=24
35261 KFB=KTECHN+211
35262 ISUB=361
35263C...RTCM(49) is the M_A for the techni-a
35264 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
35265 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
35266 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
35267 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
35268 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35269C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
35270 ELSEIF(ISUB.EQ.370) THEN
35271 KFA=24
35272 KFB=23
35273 CAB2=RTCM(3)**4
35274 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35275 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35276C... W_L pi_tc0
35277 ELSEIF(ISUB.EQ.371) THEN
35278 KFA=24
35279 KFB=KTECHN+111
35280 ISUB=370
35281 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35282C... Z_L pi_tc+
35283 ELSEIF(ISUB.EQ.372) THEN
35284 KFA=KTECHN+211
35285 KFB=23
35286 ISUB=370
35287 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35288C... pi_tc+ pi_tc0
35289 ELSEIF(ISUB.EQ.373) THEN
35290 KFA=KTECHN+211
35291 KFB=KTECHN+111
35292 ISUB=370
35293 CAB2=(1D0-RTCM(3)**2)**2
35294C... gamma pi_tc+
35295 ELSEIF(ISUB.EQ.374) THEN
35296 KFA=KTECHN+211
35297 KFB=22
35298 ISUB=370
35299 VRGP=QUPD*CSXI/RTCM(12)
35300 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
35301 AXGP=-CSXI/RTCM(49)
35302C... Z_T pi_tc+
35303 ELSEIF(ISUB.EQ.375) THEN
35304 KFA=KTECHN+211
35305 KFB=23
35306 ISUB=370
35307 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35308 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
35309 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35310 AXGP=-CSXI*CT2W/RTCM(49)
35311C... W_T pi_tc0
35312 ELSEIF(ISUB.EQ.376) THEN
35313 KFA=24
35314 KFB=KTECHN+111
35315 ISUB=370
35316 VRGP=0D0
35317 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
35318 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
35319C... W_T pi_tc0'
35320 ELSEIF(ISUB.EQ.377) THEN
35321 KFA=24
35322 KFB=KTECHN+221
35323 ISUB=370
35324 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
35325 VWGP=CSXIP/(2D0*XW)
35326 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
35327C... gamma W+
35328 ELSEIF(ISUB.EQ.378) THEN
35329 KFA=24
35330 KFB=22
35331 ISUB=370
35332 VRGP=QUPD*RTCM(3)/RTCM(12)
35333 AXGP=-RTCM(3)/RTCM(49)
35334C... gamma Z
35335 ELSEIF(ISUB.EQ.379) THEN
35336 KFA=23
35337 KFB=22
35338 ISUB=361
35339 VOGP=RTCM(3)/RTCM(12)
35340 VRGP=QUPD*RTCM(3)/RTCM(12)
35341 ELSEIF(ISUB.EQ.380) THEN
35342 KFA=23
35343 KFB=23
35344 ISUB=361
35345 VOGP=RTCM(3)*CT2W/RTCM(12)
35346 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
35347 ENDIF
35348 ENDIF
35349
35350C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
35351 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
35352 IF(ITCM(5).LE.4) THEN
35353 SQDQQS=1D0/SH2
35354 SQDQQT=1D0/TH2
35355 SQDQQU=1D0/UH2
35356 SQDGGS=SQDQQS
35357 SQDGGT=SQDQQT
35358 SQDGGU=SQDQQU
35359 REDGGS=1D0/SH
35360 REDGGT=1D0/TH
35361 REDGGU=1D0/UH
35362 REDGTU=1D0/UH/TH
35363 REDGSU=1D0/SH/UH
35364 REDGST=1D0/SH/TH
35365 REDQST=1D0/SH/TH
35366 REDQTU=1D0/UH/TH
35367 SQDLGS=0D0
35368 SQDLGT=0D0
35369 SQDQTS=SQDQQS
35370 ELSEIF(ITCM(5).EQ.5) THEN
35371 TANT3=RTCM(21)
35372 IF(ITCM(2).EQ.0) THEN
35373 IMDL=1
35374 ELSE
35375 IMDL=2
35376 ENDIF
35377 ALPRHT=2.16D0*(3D0/ITCM(1))
35378 SIN2T=2D0*TANT3/(TANT3**2+1D0)
35379 SINT3=TANT3/SQRT(TANT3**2+1D0)
35380 XIG=SQRT(PYALPS(SH)/ALPRHT)
35381 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
35382 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
35383 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
35384 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
35385 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
35386 & SINT3**2)*2D0/SIN2T
35387 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
35388 & SINT3**2)*2D0/SIN2T
35389
35390 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
35391 SM1112=X12*RTCM(28)**2*SIN2T
35392 SM1121=-X21*RTCM(28)**2*SIN2T
35393 SM2212=-SM1112
35394 SM2221=-SM1121
35395 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
35396 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
35397
35398C.........SH LOOP
35399 ZTC(1,1)=DCMPLX(SH,0D0)
35400 CALL PYWIDT(3100021,SH,WDTP,WDTE)
35401 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
35402 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
35403 CALL PYWIDT(3100113,SH,WDTP,WDTE)
35404 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
35405 CALL PYWIDT(3400113,SH,WDTP,WDTE)
35406 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
35407 CALL PYWIDT(3200113,SH,WDTP,WDTE)
35408 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
35409 CALL PYWIDT(3300113,SH,WDTP,WDTE)
35410 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
35411 ZTC(1,2)=(0D0,0D0)
35412 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
35413 ZTC(1,4)=ZTC(1,3)
35414 ZTC(1,5)=ZTC(1,2)
35415 ZTC(1,6)=ZTC(1,2)
35416 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
35417 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
35418 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
35419 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
35420 ZTC(3,4)=-SM1122
35421 ZTC(3,5)=-SM1112
35422 ZTC(3,6)=-SM1121
35423 ZTC(4,5)=-SM2212
35424 ZTC(4,6)=-SM2221
35425 ZTC(5,6)=-SM1221
35426
35427 DO 110 I=1,5
35428 DO 100 J=I+1,6
35429 ZTC(J,I)=ZTC(I,J)
35430 100 CONTINUE
35431 110 CONTINUE
35432 CALL PYLDCM(ZTC,6,6,INDX,D)
35433 DO 130 I=1,6
35434 DO 120 J=1,6
35435 YTC(I,J)=(0D0,0D0)
35436 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35437 120 CONTINUE
35438 130 CONTINUE
35439
35440 DO 140 I=1,6
35441 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35442 140 CONTINUE
35443 DGGS=YTC(1,1)
35444 DVVS=YTC(2,2)
35445 DGVS=YTC(1,2)
35446
35447 XIG=SQRT(PYALPS(-TH)/ALPRHT)
35448C.........TH LOOP
35449 ZTC(1,1)=DCMPLX(TH)
35450 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
35451 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
35452 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
35453 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
35454 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
35455 ZTC(1,2)=(0D0,0D0)
35456 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
35457 ZTC(1,4)=ZTC(1,3)
35458 ZTC(1,5)=ZTC(1,2)
35459 ZTC(1,6)=ZTC(1,2)
35460 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
35461 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
35462 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
35463 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
35464 ZTC(3,4)=-SM1122
35465 ZTC(3,5)=-SM1112
35466 ZTC(3,6)=-SM1121
35467 ZTC(4,5)=-SM2212
35468 ZTC(4,6)=-SM2221
35469 ZTC(5,6)=-SM1221
35470 DO 160 I=1,5
35471 DO 150 J=I+1,6
35472 ZTC(J,I)=ZTC(I,J)
35473 150 CONTINUE
35474 160 CONTINUE
35475 CALL PYLDCM(ZTC,6,6,INDX,D)
35476 DO 180 I=1,6
35477 DO 170 J=1,6
35478 YTC(I,J)=(0D0,0D0)
35479 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35480 170 CONTINUE
35481 180 CONTINUE
35482 DO 190 I=1,6
35483 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35484 190 CONTINUE
35485 DGGT=YTC(1,1)
35486 DVVT=YTC(2,2)
35487 DGVT=YTC(1,2)
35488
35489 XIG=SQRT(PYALPS(-UH)/ALPRHT)
35490C.........UH LOOP
35491 ZTC(1,1)=DCMPLX(UH,0D0)
35492 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
35493 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
35494 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
35495 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
35496 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
35497 ZTC(1,2)=(0D0,0D0)
35498 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
35499 ZTC(1,4)=ZTC(1,3)
35500 ZTC(1,5)=ZTC(1,2)
35501 ZTC(1,6)=ZTC(1,2)
35502 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
35503 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
35504 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
35505 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
35506 ZTC(3,4)=-SM1122
35507 ZTC(3,5)=-SM1112
35508 ZTC(3,6)=-SM1121
35509 ZTC(4,5)=-SM2212
35510 ZTC(4,6)=-SM2221
35511 ZTC(5,6)=-SM1221
35512 DO 210 I=1,5
35513 DO 200 J=I+1,6
35514 ZTC(J,I)=ZTC(I,J)
35515 200 CONTINUE
35516 210 CONTINUE
35517 CALL PYLDCM(ZTC,6,6,INDX,D)
35518 DO 230 I=1,6
35519 DO 220 J=1,6
35520 YTC(I,J)=(0D0,0D0)
35521 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35522 220 CONTINUE
35523 230 CONTINUE
35524 DO 240 I=1,6
35525 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35526 240 CONTINUE
35527 DGGU=YTC(1,1)
35528 DVVU=YTC(2,2)
35529 DGVU=YTC(1,2)
35530
35531 IF(IMDL.EQ.1) THEN
35532 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
35533 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
35534 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
35535 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
35536 DQGS=DGGS-DGVS*DCMPLX(TANT3)
35537 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35538 ELSE
35539 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35540 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
35541 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
35542 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35543 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35544 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35545 ENDIF
35546
35547 SQDQTS=ABS(DQTS)**2
35548 SQDQQS=ABS(DQQS)**2
35549 SQDQQT=ABS(DQQT)**2
35550 SQDQQU=ABS(DQQU)**2
35551 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
35552 REDLGS=DBLE(DQGS)
35553 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
35554 REDHGS=DBLE(DTGS)
35555 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
35556
35557 SQDGGS=ABS(DGGS)**2
35558 SQDGGT=ABS(DGGT)**2
35559 SQDGGU=ABS(DGGU)**2
35560 REDGGS=DBLE(DGGS)
35561 REDGGT=DBLE(DGGT)
35562 REDGGU=DBLE(DGGU)
35563 REDGTU=DBLE(DGGU*DCONJG(DGGT))
35564 REDGSU=DBLE(DGGU*DCONJG(DGGS))
35565 REDGST=DBLE(DGGS*DCONJG(DGGT))
35566 REDQST=DBLE(DQQS*DCONJG(DQQT))
35567 REDQTU=DBLE(DQQT*DCONJG(DQQU))
35568 ENDIF
35569 ENDIF
35570
35571
35572C...Differential cross section expressions.
35573
35574 IF(ISUB.LE.190) THEN
35575 IF(ISUB.EQ.149) THEN
35576C...g + g -> eta_tc
35577 KCTC=PYCOMP(KTECHN+331)
35578 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
35579 HS=SHR*WDTP(0)
35580 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
35581 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35582 HP=SH
35583 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
35584 HI=HP*WDTP(3)
35585 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35586 NCHN=NCHN+1
35587 ISIG(NCHN,1)=21
35588 ISIG(NCHN,2)=21
35589 ISIG(NCHN,3)=1
35590 SIGH(NCHN)=HI*FACBW*HF
35591 250 CONTINUE
35592
35593 ELSEIF(ISUB.EQ.165) THEN
35594C...q + qbar -> l+ + l- (including contact term for compositeness)
35595 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35596 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35597 KFF=IABS(KFPR(ISUB,1))
35598 EF=KCHG(KFF,1)/3D0
35599 AF=SIGN(1D0,EF+0.1D0)
35600 VF=AF-4D0*EF*XWV
35601 VALF=VF+AF
35602 VARF=VF-AF
35603 FCOF=1D0
35604 IF(KFF.LE.10) FCOF=3D0
35605 WID2=1D0
35606 IF(KFF.EQ.6) WID2=WIDS(6,1)
35607 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
35608 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35609 DO 260 I=MMINA,MMAXA
35610 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
35611 EI=KCHG(IABS(I),1)/3D0
35612 AI=SIGN(1D0,EI+0.1D0)
35613 VI=AI-4D0*EI*XWV
35614 VALI=VI+AI
35615 VARI=VI-AI
35616 FCOI=1D0
35617 IF(IABS(I).LE.10) FCOI=FACA/3D0
35618 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
35619 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
35620 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
35621 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35622 ELSE
35623 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
35624 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35625 ENDIF
35626 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
35627 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
35628 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
35629 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
35630 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
35631 NCHN=NCHN+1
35632 ISIG(NCHN,1)=I
35633 ISIG(NCHN,2)=-I
35634 ISIG(NCHN,3)=1
35635 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
35636 260 CONTINUE
35637
35638 ELSEIF(ISUB.EQ.166) THEN
35639C...q + q'bar -> l + nu_l (including contact term for compositeness)
35640 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
35641 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
35642 KFF=IABS(KFPR(ISUB,1))
35643 FCOF=1D0
35644 IF(KFF.LE.10) FCOF=3D0
35645 DO 280 I=MMIN1,MMAX1
35646 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
35647 IA=IABS(I)
35648 DO 270 J=MMIN2,MMAX2
35649 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
35650 JA=IABS(J)
35651 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
35652 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35653 & GOTO 270
35654 FCOI=1D0
35655 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35656 WID2=1D0
35657 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
35658 & MOD(J,2).EQ.0)) THEN
35659 IF(KFF.EQ.5) WID2=WIDS(6,2)
35660 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
35661 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
35662 ELSE
35663 IF(KFF.EQ.5) WID2=WIDS(6,3)
35664 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
35665 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
35666 ENDIF
35667 NCHN=NCHN+1
35668 ISIG(NCHN,1)=I
35669 ISIG(NCHN,2)=J
35670 ISIG(NCHN,3)=1
35671 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
35672 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
35673 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
35674 270 CONTINUE
35675 280 CONTINUE
35676 ENDIF
35677
35678 ELSEIF(ISUB.LE.200) THEN
35679 IF(ISUB.EQ.191) THEN
35680C...q + qbar -> rho_tc0.
35681 KCTC=PYCOMP(KTECHN+113)
35682 SQMRHT=PMAS(KCTC,1)**2
35683 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35684 HS=SHR*WDTP(0)
35685 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35686 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35687 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35688 ALPRHT=2.16D0*(3D0/ITCM(1))
35689 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
35690 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
35691 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35692 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35693 DO 290 I=MMINA,MMAXA
35694 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
35695 IA=IABS(I)
35696 EI=KCHG(IABS(I),1)/3D0
35697 AI=SIGN(1D0,EI+0.1D0)
35698 VI=AI-4D0*EI*XWV
35699 VALI=0.5D0*(VI+AI)
35700 VARI=0.5D0*(VI-AI)
35701 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
35702 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
35703 IF(IA.LE.10) HI=HI*FACA/3D0
35704 NCHN=NCHN+1
35705 ISIG(NCHN,1)=I
35706 ISIG(NCHN,2)=-I
35707 ISIG(NCHN,3)=1
35708 SIGH(NCHN)=HI*FACBW*HF
35709 290 CONTINUE
35710
35711 ELSEIF(ISUB.EQ.192) THEN
35712C...q + qbar' -> rho_tc+/-.
35713 KCTC=PYCOMP(KTECHN+213)
35714 SQMRHT=PMAS(KCTC,1)**2
35715 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35716 HS=SHR*WDTP(0)
35717 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35718 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35719 ALPRHT=2.16D0*(3D0/ITCM(1))
35720 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
35721 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
35722 DO 310 I=MMIN1,MMAX1
35723 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
35724 IA=IABS(I)
35725 DO 300 J=MMIN2,MMAX2
35726 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
35727 JA=IABS(J)
35728 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
35729 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35730 & GOTO 300
35731 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35732 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
35733 HI=HP
35734 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35735 NCHN=NCHN+1
35736 ISIG(NCHN,1)=I
35737 ISIG(NCHN,2)=J
35738 ISIG(NCHN,3)=1
35739 SIGH(NCHN)=HI*FACBW*HF
35740 300 CONTINUE
35741 310 CONTINUE
35742
35743 ELSEIF(ISUB.EQ.193) THEN
35744C...q + qbar -> omega_tc0.
35745 KCTC=PYCOMP(KTECHN+223)
35746 SQMOMT=PMAS(KCTC,1)**2
35747 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35748 HS=SHR*WDTP(0)
35749 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
35750 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35751 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35752 ALPRHT=2.16D0*(3D0/ITCM(1))
35753 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
35754 & (2D0*RTCM(2)-1D0)**2
35755 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35756 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35757 DO 320 I=MMINA,MMAXA
35758 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
35759 IA=IABS(I)
35760 EI=KCHG(IABS(I),1)/3D0
35761 AI=SIGN(1D0,EI+0.1D0)
35762 VI=AI-4D0*EI*XWV
35763 VALI=0.5D0*(VI+AI)
35764 VARI=0.5D0*(VI-AI)
35765 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
35766 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
35767 IF(IA.LE.10) HI=HI*FACA/3D0
35768 NCHN=NCHN+1
35769 ISIG(NCHN,1)=I
35770 ISIG(NCHN,2)=-I
35771 ISIG(NCHN,3)=1
35772 SIGH(NCHN)=HI*FACBW*HF
35773 320 CONTINUE
35774
35775 ELSEIF(ISUB.EQ.194) THEN
35776C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
35777C...Default final state is e+e-
35778 KFA=KFPR(ISUBSV,1)
35779 ALPRHT=2.16D0*(3D0/ITCM(1))
35780 HP=AEM**2*COMFAC
35781
35782 SN2W=2D0*SQRT(XW*XW1)
35783C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
35784C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
35785
35786 QUPD=2D0*RTCM(2)-1D0
35787 FAR=SQRT(AEM/ALPRHT)
35788 FAO=FAR*QUPD
35789 FZR=FAR*CT2W
35790 FZO=-FAO*TANW
35791C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35792 FZX=-FAR/SN2W*RTCM(47)
35793 SFAR=FAR**2
35794 SFAO=FAO**2
35795 SFZR=FZR**2
35796 SFZO=FZO**2
35797 SFZX=FZX**2
35798 CALL PYWIDT(23,SH,WDTP,WDTE)
35799 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35800 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35801 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35802 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35803 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35804 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35805 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35806C...Propagator including a_T^0
35807 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35808 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35809C...Add in techni-a contribution
35810 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35811 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35812 $ SFZX*SSMR*SSMO)/DETD/SH
35813 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35814 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35815
35816 XWRHT=1D0/(4D0*XW*(1D0-XW))
35817 KFF=IABS(KFPR(ISUB,1))
35818 EF=KCHG(KFF,1)/3D0
35819 AF=SIGN(1D0,EF+0.1D0)
35820 VF=AF-4D0*EF*XWV
35821 VALF=0.5D0*(VF+AF)
35822 VARF=0.5D0*(VF-AF)
35823 FCOF=1D0
35824 IF(KFF.LE.10) FCOF=3D0
35825
35826 WID2=1D0
35827 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
35828 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35829 DZZ=DZZ*DCMPLX(XWRHT,0D0)
35830 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
35831
35832 DO 330 I=MMINA,MMAXA
35833 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
35834 EI=KCHG(IABS(I),1)/3D0
35835 AI=SIGN(1D0,EI+0.1D0)
35836 VI=AI-4D0*EI*XWV
35837 VALI=0.5D0*(VI+AI)
35838 VARI=0.5D0*(VI-AI)
35839 FCOI=FCOF
35840 IF(IABS(I).LE.10) FCOI=FCOI/3D0
35841 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
35842 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
35843 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
35844 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
35845 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
35846 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
35847 NCHN=NCHN+1
35848 ISIG(NCHN,1)=I
35849 ISIG(NCHN,2)=-I
35850 ISIG(NCHN,3)=1
35851 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
35852 330 CONTINUE
35853
35854 ELSEIF(ISUB.EQ.195) THEN
35855C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
35856 KFA=KFPR(ISUBSV,1)
35857 KFB=KFA+1
35858 ALPRHT=2.16D0*(3D0/ITCM(1))
35859 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
35860
35861 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35862C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35863C
35864C...Propagator including a_T^+
35865 FWX=-FWR*RTCM(47)
35866 CALL PYWIDT(24,SH,WDTP,WDTE)
35867 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35868 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35869 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35870 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
35871 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
35872 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
35873 & DCMPLX(FWX**2,0D0)*SSMR
35874 DWW=SSMR*SSMX/DETD/SH
35875 FCOF=1D0
35876 IF(KFA.LE.8) FCOF=3D0
35877 HP=FACTC*ABS(DWW)**2*FCOF
35878
35879 DO 350 I=MMIN1,MMAX1
35880 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
35881 IA=IABS(I)
35882 DO 340 J=MMIN2,MMAX2
35883 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
35884 JA=IABS(J)
35885 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
35886 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35887 & GOTO 340
35888 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35889 HI=HP
35890 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35891 NCHN=NCHN+1
35892 ISIG(NCHN,1)=I
35893 ISIG(NCHN,2)=J
35894 ISIG(NCHN,3)=1
35895 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
35896 340 CONTINUE
35897 350 CONTINUE
35898 ENDIF
35899
35900 ELSEIF(ISUB.LE.380) THEN
35901 ALPRHT=2.16D0*(3D0/ITCM(1))
35902 IF(ISUB.EQ.361) THEN
35903 FAR=SQRT(AEM/ALPRHT)
35904 FAO=FAR*QUPD
35905 FZR=FAR*CT2W
35906 FZO=-FAO*TANW
35907C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35908 FZX=-FAR/SN2W*RTCM(47)
35909 SFAR=FAR**2
35910 SFAO=FAO**2
35911 SFZR=FZR**2
35912 SFZO=FZO**2
35913 SFZX=FZX**2
35914 CALL PYWIDT(23,SH,WDTP,WDTE)
35915 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35916 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35917 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35918 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35919 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35920 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35921 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35922 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35923 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35924C...Add in techni-a contribution
35925 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35926 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
35927 $ SFZX*FAR*SSMO)/DETD/SH
35928 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
35929 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
35930 $ SFZX*FAO*SSMR)/DETD/SH
35931 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
35932 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
35933 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
35934 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35935 $ SFZX*SSMR*SSMO)/DETD/SH
35936 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35937 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35938
35939C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35940C...W+W-, W pi_tc, pi_T pi_T, etc.
35941 FACA=(SH**2*BE34**2-(TH-UH)**2)
35942 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35943 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35944 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35945 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35946 DO 370 I=MMINA,MMAXA
35947 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35948 IA=IABS(I)
35949 EI=KCHG(IABS(I),1)/3D0
35950 AI=SIGN(1D0,EI+0.1D0)
35951 VI=AI-4D0*EI*XWV
35952 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
35953 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
35954C...........Eqs. (5) and (6) in LSTC-rates.pdf
35955 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35956 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35957 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
35958 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35959 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35960 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35961 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35962 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
35963 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35964 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35965 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35966C...........Eqs. (5) and (7) in LSTC-rates.pdf
35967 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35968 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35969 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
35970 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35971 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35972 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
35973 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35974C
35975C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
35976C
35977c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35978c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
35979c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35980c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
35981 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
35982 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
35983 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
35984 HI=HI+HJ+HK
35985 IF(IA.LE.10) HI=HI/3D0
35986 NCHN=NCHN+1
35987 ISIG(NCHN,1)=I
35988 ISIG(NCHN,2)=-I
35989 ISIG(NCHN,3)=1
35990 IF(KFA.EQ.KFB) THEN
35991 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
35992 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
35993 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
35994 NCHN=NCHN+1
35995 ISIG(NCHN,1)=I
35996 ISIG(NCHN,2)=-I
35997 ISIG(NCHN,3)=2
35998 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
35999 ELSE
36000 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36001 ENDIF
36002 370 CONTINUE
36003
36004 ELSEIF(ISUB.EQ.370) THEN
36005C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
36006C...f + fbar' -> gamma pi_tc, etc.
36007 FACA=(SH**2*BE34**2-(TH-UH)**2)
36008 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36009 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36010 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36011 ALPRHT=2.16D0*(3D0/ITCM(1))
36012 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36013 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36014C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36015 FWX=-FWR*RTCM(47)
36016 CALL PYWIDT(24,SH,WDTP,WDTE)
36017 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36018 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36019 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36020 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36021 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36022 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36023 & DCMPLX(FWX**2,0D0)*SSMR
36024 DWW=SSMR*SSMX/DETD/SH
36025 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36026 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36027 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36028 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36029C
36030C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36031C
36032c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36033 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36034C...Add in W_L Z_T axial and vector contributions.
36035 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36036 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36037 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36038 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36039 DO 410 I=MMIN1,MMAX1
36040 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36041 IA=IABS(I)
36042 DO 400 J=MMIN2,MMAX2
36043 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36044 JA=IABS(J)
36045 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36046 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36047 & GOTO 400
36048 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36049 HI=HP
36050 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36051 NCHN=NCHN+1
36052 ISIG(NCHN,1)=I
36053 ISIG(NCHN,2)=J
36054 ISIG(NCHN,3)=1
36055 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36056 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36057 ELSE
36058 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36059 & WIDS(PYCOMP(KFB),2)
36060 ENDIF
36061 400 CONTINUE
36062 410 CONTINUE
36063 ENDIF
36064
36065 ELSEIF(ISUB.LE.390) THEN
36066 IF(ISUB.EQ.381) THEN
36067C...f + f' -> f + f' (g exchange)
36068 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36069 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36070 & MSTP(34)*2D0/3D0*UH2*REDQST)
36071 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36072 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36073 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36074 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36075C...Modifications from contact interactions (compositeness)
36076 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36077 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36078 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36079 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36080 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36081 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36082 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36083 ELSEIF(ITCM(5).EQ.5) THEN
36084 FACCI1=FACQQ1
36085 FACCIB=FACQQB
36086 FACCI2=FACQQ2
36087 FACCI3=FACQQ1
36088CSM.......Check this change from
36089CSM RATCII=1D0
36090 RATCII=RATQQI
36091 ENDIF
36092 DO 430 I=MMIN1,MMAX1
36093 IA=IABS(I)
36094 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36095 DO 420 J=MMIN2,MMAX2
36096 JA=IABS(J)
36097 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36098 NCHN=NCHN+1
36099 ISIG(NCHN,1)=I
36100 ISIG(NCHN,2)=J
36101 ISIG(NCHN,3)=1
36102 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
36103 & JA.GE.3))) THEN
36104 SIGH(NCHN)=FACQQ1
36105 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
36106 ELSE
36107 SIGH(NCHN)=FACCI1
36108 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
36109 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
36110 ENDIF
36111 IF(I.EQ.J) THEN
36112 NCHN=NCHN+1
36113 ISIG(NCHN,1)=I
36114 ISIG(NCHN,2)=J
36115 ISIG(NCHN,3)=2
36116 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
36117 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
36118 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
36119 ELSE
36120 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
36121 SIGH(NCHN)=0.5D0*FACCI2*RATCII
36122 ENDIF
36123 ENDIF
36124 420 CONTINUE
36125 430 CONTINUE
36126
36127 ELSEIF(ISUB.EQ.382) THEN
36128C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36129 CALL PYWIDT(21,SH,WDTP,WDTE)
36130 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
36131 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36132 IF(ITCM(5).EQ.1) THEN
36133C...Modifications from contact interactions (compositeness)
36134 FACCIB=FACQQB
36135 DO 440 I=1,2
36136 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
36137 & WDTE(I,2)+WDTE(I,4))
36138 440 CONTINUE
36139 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
36140 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
36141 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36142 ELSEIF(ITCM(5).EQ.5) THEN
36143 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
36144 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
36145 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
36146 ENDIF
36147 DO 450 I=MMINA,MMAXA
36148 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36149 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
36150 NCHN=NCHN+1
36151 ISIG(NCHN,1)=I
36152 ISIG(NCHN,2)=-I
36153 ISIG(NCHN,3)=1
36154 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
36155 SIGH(NCHN)=FACQQB
36156 ELSEIF(ITCM(5).EQ.5) THEN
36157 SIGH(NCHN)=FACQQB
36158 NCHN=NCHN+1
36159 ISIG(NCHN,1)=I
36160 ISIG(NCHN,2)=-I
36161 ISIG(NCHN,3)=2
36162 SIGH(NCHN)=FACCIB
36163 ELSE
36164 SIGH(NCHN)=FACCIB
36165 ENDIF
36166 450 CONTINUE
36167
36168 ELSEIF(ISUB.EQ.383) THEN
36169C...f + fbar -> g + g (q + qbar -> g + g only)
36170 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36171 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36172 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36173 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36174 IF(ITCM(5).EQ.5) THEN
36175 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36176 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36177 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36178 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36179 ENDIF
36180 DO 460 I=MMINA,MMAXA
36181 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36182 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36183 NCHN=NCHN+1
36184 ISIG(NCHN,1)=I
36185 ISIG(NCHN,2)=-I
36186 ISIG(NCHN,3)=1
36187 SIGH(NCHN)=0.5D0*FACGG1
36188 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
36189 NCHN=NCHN+1
36190 ISIG(NCHN,1)=I
36191 ISIG(NCHN,2)=-I
36192 ISIG(NCHN,3)=2
36193 SIGH(NCHN)=0.5D0*FACGG2
36194 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
36195 460 CONTINUE
36196
36197 ELSEIF(ISUB.EQ.384) THEN
36198C...f + g -> f + g (q + g -> q + g only)
36199 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
36200 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
36201 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
36202 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
36203 DO 480 I=MMINA,MMAXA
36204 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
36205 DO 470 ISDE=1,2
36206 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
36207 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
36208 NCHN=NCHN+1
36209 ISIG(NCHN,ISDE)=I
36210 ISIG(NCHN,3-ISDE)=21
36211 ISIG(NCHN,3)=1
36212 SIGH(NCHN)=FACQG1
36213 NCHN=NCHN+1
36214 ISIG(NCHN,ISDE)=I
36215 ISIG(NCHN,3-ISDE)=21
36216 ISIG(NCHN,3)=2
36217 SIGH(NCHN)=FACQG2
36218 470 CONTINUE
36219 480 CONTINUE
36220
36221 ELSEIF(ISUB.EQ.385) THEN
36222C...g + g -> f + fbar (g + g -> q + qbar only)
36223 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
36224 IDC0=MDCY(21,2)-1
36225C...Begin by d, u, s flavours.
36226 FLAVWT=0D0
36227 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
36228 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
36229 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
36230 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
36231 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
36232 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
36233 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36234 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36235 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36236 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36237 NCHN=NCHN+1
36238 ISIG(NCHN,1)=21
36239 ISIG(NCHN,2)=21
36240 ISIG(NCHN,3)=1
36241 SIGH(NCHN)=FACQQ1
36242 NCHN=NCHN+1
36243 ISIG(NCHN,1)=21
36244 ISIG(NCHN,2)=21
36245 ISIG(NCHN,3)=2
36246 SIGH(NCHN)=FACQQ2
36247C...Next c and b flavours: modified that and uhat for fixed
36248C...cos(theta-hat).
36249 DO 490 IFL=4,5
36250 SQMAVG=PMAS(IFL,1)**2
36251 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
36252 BE34=SQRT(1D0-4D0*SQMAVG/SH)
36253 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36254 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36255 THUHQ=THQ*UHQ-SQMAVG*SH
36256 IF(MSTP(34).EQ.0) THEN
36257 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36258 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36259 ELSE
36260 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36261 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36262 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36263 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36264 ENDIF
36265 IF(ITCM(5).GE.5) THEN
36266 IF(IFL.EQ.4) THEN
36267 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36268 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36269 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36270 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36271 ELSE
36272 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36273 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36274 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36275 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36276 ENDIF
36277 ENDIF
36278 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
36279 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
36280 NCHN=NCHN+1
36281 ISIG(NCHN,1)=21
36282 ISIG(NCHN,2)=21
36283 ISIG(NCHN,3)=1+2*(IFL-3)
36284 SIGH(NCHN)=FACQQ1
36285 NCHN=NCHN+1
36286 ISIG(NCHN,1)=21
36287 ISIG(NCHN,2)=21
36288 ISIG(NCHN,3)=2+2*(IFL-3)
36289 SIGH(NCHN)=FACQQ2
36290 ENDIF
36291 490 CONTINUE
36292 500 CONTINUE
36293
36294 ELSEIF(ISUB.EQ.386) THEN
36295C...g + g -> g + g
36296 IF(ITCM(5).LE.4) THEN
36297 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
36298 & 2D0*TH/SH+TH2/SH2)*FACA
36299 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
36300 & 2D0*SH/UH+SH2/UH2)*FACA
36301 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
36302 & 2D0*UH/TH+UH2/TH2)
36303 ELSE
36304 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
36305 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
36306 & 4D0*REDGST*(SH + 2D0*TH)*
36307 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
36308 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
36309 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
36310 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
36311 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
36312 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
36313 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
36314 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
36315 & 4D0*REDGSU*(SH + 2D0*UH)*
36316 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
36317 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
36318 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
36319 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
36320 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
36321 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
36322 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
36323 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
36324 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
36325 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
36326 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
36327 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
36328 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
36329 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
36330 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
36331 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
36332 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
36333 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
36334 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
36335 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
36336 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
36337 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
36338 ENDIF
36339 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
36340 NCHN=NCHN+1
36341 ISIG(NCHN,1)=21
36342 ISIG(NCHN,2)=21
36343 ISIG(NCHN,3)=1
36344 SIGH(NCHN)=0.5D0*FACGG1
36345 NCHN=NCHN+1
36346 ISIG(NCHN,1)=21
36347 ISIG(NCHN,2)=21
36348 ISIG(NCHN,3)=2
36349 SIGH(NCHN)=0.5D0*FACGG2
36350 NCHN=NCHN+1
36351 ISIG(NCHN,1)=21
36352 ISIG(NCHN,2)=21
36353 ISIG(NCHN,3)=3
36354 SIGH(NCHN)=0.5D0*FACGG3
36355 510 CONTINUE
36356
36357 ELSEIF(ISUB.EQ.387) THEN
36358C...q + qbar -> Q + Qbar
36359 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36360 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36361 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36362 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
36363 & 2D0*SQMAVG/SH)
36364 IF(ITCM(5).GE.5) THEN
36365 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36366 FACQQB=FACQQB*SH2*SQDQTS
36367 ELSE
36368 FACQQB=FACQQB*SH2*SQDQQS
36369 ENDIF
36370 ENDIF
36371 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
36372 WID2=1D0
36373 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36374 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36375 FACQQB=FACQQB*WID2
36376 DO 520 I=MMINA,MMAXA
36377 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36378 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
36379 NCHN=NCHN+1
36380 ISIG(NCHN,1)=I
36381 ISIG(NCHN,2)=-I
36382 ISIG(NCHN,3)=1
36383 SIGH(NCHN)=FACQQB
36384 520 CONTINUE
36385
36386 ELSEIF(ISUB.EQ.388) THEN
36387C...g + g -> Q + Qbar
36388 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36389 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36390 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36391 THUHQ=THQ*UHQ-SQMAVG*SH
36392 IF(MSTP(34).EQ.0) THEN
36393 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36394 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36395 ELSE
36396 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36397 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36398 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36399 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36400 ENDIF
36401 IF(ITCM(5).GE.5) THEN
36402 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36403 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36404 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36405 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36406 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36407 ELSE
36408 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36409 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36410 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36411 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36412 ENDIF
36413 ENDIF
36414 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
36415 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
36416 IF(MSTP(35).GE.1) THEN
36417 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
36418 FACQQ1=FACQQ1*FATRE
36419 FACQQ2=FACQQ2*FATRE
36420 ENDIF
36421 WID2=1D0
36422 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36423 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36424 FACQQ1=FACQQ1*WID2
36425 FACQQ2=FACQQ2*WID2
36426 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
36427 NCHN=NCHN+1
36428 ISIG(NCHN,1)=21
36429 ISIG(NCHN,2)=21
36430 ISIG(NCHN,3)=1
36431 SIGH(NCHN)=FACQQ1
36432 NCHN=NCHN+1
36433 ISIG(NCHN,1)=21
36434 ISIG(NCHN,2)=21
36435 ISIG(NCHN,3)=2
36436 SIGH(NCHN)=FACQQ2
36437 530 CONTINUE
36438 ENDIF
36439 ENDIF
36440
36441CMRENNA--
36442
36443 RETURN
36444 END
36445
36446C*********************************************************************
36447
36448C...PYSGEX
36449C...Subprocess cross sections for assorted exotic processes,
36450C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
36451C...Auxiliary to PYSIGH.
36452
36453 SUBROUTINE PYSGEX(NCHN,SIGS)
36454
36455C...Double precision and integer declarations
36456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36457 IMPLICIT INTEGER(I-N)
36458 INTEGER PYK,PYCHGE,PYCOMP
36459C...Parameter statement to help give large particle numbers.
36460 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36461 &KEXCIT=4000000,KDIMEN=5000000)
36462C...Commonblocks
36463 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36464 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36465 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36466 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36467 COMMON/PYINT1/MINT(400),VINT(400)
36468 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36469 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36470 COMMON/PYINT4/MWID(500),WIDS(500,5)
36471 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36472 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36473 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36474 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36475 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36476 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36477 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36478C...Local arrays
36479 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36480
36481C...Differential cross section expressions.
36482
36483 IF(ISUB.LE.160) THEN
36484 IF(ISUB.EQ.141) THEN
36485C...f + fbar -> gamma*/Z0/Z'0
36486 SQMZP=PMAS(32,1)**2
36487 MINT(61)=2
36488 CALL PYWIDT(32,SH,WDTP,WDTE)
36489 HP0=AEM/3D0*SH
36490 HP1=AEM/3D0*XWC*SH
36491 HP2=HP1
36492 HS=SHR*VINT(117)
36493 HSP=SHR*WDTP(0)
36494 FACZP=4D0*COMFAC*3D0
36495 DO 100 I=MMINA,MMAXA
36496 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
36497 EI=KCHG(IABS(I),1)/3D0
36498 AI=SIGN(1D0,EI)
36499 VI=AI-4D0*EI*XWV
36500 IA=IABS(I)
36501 IF(IA.LT.10) THEN
36502 IF(IA.LE.2) THEN
36503 VPI=PARU(123-2*MOD(IABS(I),2))
36504 API=PARU(124-2*MOD(IABS(I),2))
36505 ELSEIF(IA.LE.4) THEN
36506 VPI=PARJ(182-2*MOD(IABS(I),2))
36507 API=PARJ(183-2*MOD(IABS(I),2))
36508 ELSE
36509 VPI=PARJ(190-2*MOD(IABS(I),2))
36510 API=PARJ(191-2*MOD(IABS(I),2))
36511 ENDIF
36512 ELSE
36513 IF(IA.LE.12) THEN
36514 VPI=PARU(127-2*MOD(IABS(I),2))
36515 API=PARU(128-2*MOD(IABS(I),2))
36516 ELSEIF(IA.LE.14) THEN
36517 VPI=PARJ(186-2*MOD(IABS(I),2))
36518 API=PARJ(187-2*MOD(IABS(I),2))
36519 ELSE
36520 VPI=PARJ(194-2*MOD(IABS(I),2))
36521 API=PARJ(195-2*MOD(IABS(I),2))
36522 ENDIF
36523 ENDIF
36524 HI0=HP0
36525 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
36526 HI1=HP1
36527 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
36528 HI2=HP2
36529 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
36530 NCHN=NCHN+1
36531 ISIG(NCHN,1)=I
36532 ISIG(NCHN,2)=-I
36533 ISIG(NCHN,3)=1
36534 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
36535 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
36536 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
36537 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
36538 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
36539 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
36540 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
36541 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
36542 100 CONTINUE
36543
36544 ELSEIF(ISUB.EQ.142) THEN
36545C...f + fbar' -> W'+/-
36546 SQMWP=PMAS(34,1)**2
36547 CALL PYWIDT(34,SH,WDTP,WDTE)
36548 HS=SHR*WDTP(0)
36549 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
36550 HP=AEM/(24D0*XW)*SH
36551 DO 120 I=MMIN1,MMAX1
36552 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
36553 IA=IABS(I)
36554 DO 110 J=MMIN2,MMAX2
36555 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
36556 JA=IABS(J)
36557 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
36558 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36559 & GOTO 110
36560 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36561 HI=HP*(PARU(133)**2+PARU(134)**2)
36562 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
36563 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36564 NCHN=NCHN+1
36565 ISIG(NCHN,1)=I
36566 ISIG(NCHN,2)=J
36567 ISIG(NCHN,3)=1
36568 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36569 SIGH(NCHN)=HI*FACBW*HF
36570 110 CONTINUE
36571 120 CONTINUE
36572
36573 ELSEIF(ISUB.EQ.144) THEN
36574C...f + fbar' -> R
36575 SQMR=PMAS(41,1)**2
36576 CALL PYWIDT(41,SH,WDTP,WDTE)
36577 HS=SHR*WDTP(0)
36578 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
36579 HP=AEM/(12D0*XW)*SH
36580 DO 140 I=MMIN1,MMAX1
36581 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
36582 IA=IABS(I)
36583 DO 130 J=MMIN2,MMAX2
36584 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
36585 JA=IABS(J)
36586 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
36587 HI=HP
36588 IF(IA.LE.10) HI=HI*FACA/3D0
36589 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
36590 NCHN=NCHN+1
36591 ISIG(NCHN,1)=I
36592 ISIG(NCHN,2)=J
36593 ISIG(NCHN,3)=1
36594 SIGH(NCHN)=HI*FACBW*HF
36595 130 CONTINUE
36596 140 CONTINUE
36597
36598 ELSEIF(ISUB.EQ.145) THEN
36599C...q + l -> LQ (leptoquark)
36600 SQMLQ=PMAS(42,1)**2
36601 CALL PYWIDT(42,SH,WDTP,WDTE)
36602 HS=SHR*WDTP(0)
36603 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
36604 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
36605 HP=AEM/4D0*SH
36606 KFLQQ=KFDP(MDCY(42,2),1)
36607 KFLQL=KFDP(MDCY(42,2),2)
36608 DO 160 I=MMIN1,MMAX1
36609 IF(KFAC(1,I).EQ.0) GOTO 160
36610 IA=IABS(I)
36611 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
36612 DO 150 J=MMIN2,MMAX2
36613 IF(KFAC(2,J).EQ.0) GOTO 150
36614 JA=IABS(J)
36615 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
36616 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
36617 IF(JA.EQ.IA) GOTO 150
36618 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
36619 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
36620 HI=HP*PARU(151)
36621 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
36622 NCHN=NCHN+1
36623 ISIG(NCHN,1)=I
36624 ISIG(NCHN,2)=J
36625 ISIG(NCHN,3)=1
36626 SIGH(NCHN)=HI*FACBW*HF
36627 150 CONTINUE
36628 160 CONTINUE
36629
36630 ELSEIF(ISUB.EQ.146) THEN
36631C...e + gamma* -> e* (excited lepton)
36632 KFQSTR=KFPR(ISUB,1)
36633 KCQSTR=PYCOMP(KFQSTR)
36634 KFQEXC=MOD(KFQSTR,KEXCIT)
36635 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36636 HS=SHR*WDTP(0)
36637 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36638 QF=-RTCM(43)/2D0-RTCM(44)/2D0
36639 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
36640 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36641 & FACBW=0D0
36642 HP=SH
36643 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
36644 DO 170 ISDE=1,2
36645 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
36646 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
36647 HI=HP
36648 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36649 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36650 NCHN=NCHN+1
36651 ISIG(NCHN,ISDE)=I
36652 ISIG(NCHN,3-ISDE)=22
36653 ISIG(NCHN,3)=1
36654 SIGH(NCHN)=HI*FACBW*HF
36655 170 CONTINUE
36656 180 CONTINUE
36657
36658 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
36659C...d + g -> d* and u + g -> u* (excited quarks)
36660 KFQSTR=KFPR(ISUB,1)
36661 KCQSTR=PYCOMP(KFQSTR)
36662 KFQEXC=MOD(KFQSTR,KEXCIT)
36663 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36664 HS=SHR*WDTP(0)
36665 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36666 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
36667 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36668 & FACBW=0D0
36669 HP=SH
36670 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
36671 DO 190 ISDE=1,2
36672 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
36673 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
36674 HI=HP
36675 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36676 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36677 NCHN=NCHN+1
36678 ISIG(NCHN,ISDE)=I
36679 ISIG(NCHN,3-ISDE)=21
36680 ISIG(NCHN,3)=1
36681 SIGH(NCHN)=HI*FACBW*HF
36682 190 CONTINUE
36683 200 CONTINUE
36684 ENDIF
36685
36686 ELSEIF(ISUB.LE.190) THEN
36687 IF(ISUB.EQ.162) THEN
36688C...q + g -> LQ + lbar; LQ=leptoquark
36689 SQMLQ=PMAS(42,1)**2
36690 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
36691 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
36692 KFLQQ=KFDP(MDCY(42,2),1)
36693 DO 220 I=MMINA,MMAXA
36694 IF(IABS(I).NE.KFLQQ) GOTO 220
36695 KCHLQ=ISIGN(1,I)
36696 DO 210 ISDE=1,2
36697 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
36698 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
36699 NCHN=NCHN+1
36700 ISIG(NCHN,ISDE)=I
36701 ISIG(NCHN,3-ISDE)=21
36702 ISIG(NCHN,3)=1
36703 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
36704 210 CONTINUE
36705 220 CONTINUE
36706
36707 ELSEIF(ISUB.EQ.163) THEN
36708C...g + g -> LQ + LQbar; LQ=leptoquark
36709 SQMLQ=PMAS(42,1)**2
36710 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
36711 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
36712 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
36713 & ((TH-SQMLQ)*(UH-SQMLQ)))
36714 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
36715 NCHN=NCHN+1
36716 ISIG(NCHN,1)=21
36717 ISIG(NCHN,2)=21
36718C...Since don't know proper colour flow, randomize between alternatives
36719 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
36720 SIGH(NCHN)=FACLQ
36721 230 CONTINUE
36722
36723 ELSEIF(ISUB.EQ.164) THEN
36724C...q + qbar -> LQ + LQbar; LQ=leptoquark
36725 DELTA=0.25D0*(SQM3-SQM4)**2/SH
36726 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
36727 TH=TH-DELTA
36728 UH=UH-DELTA
36729C SQMLQ=PMAS(42,1)**2
36730 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
36731 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
36732 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
36733 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
36734 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
36735 KFLQQ=KFDP(MDCY(42,2),1)
36736 DO 240 I=MMINA,MMAXA
36737 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36738 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
36739 NCHN=NCHN+1
36740 ISIG(NCHN,1)=I
36741 ISIG(NCHN,2)=-I
36742 ISIG(NCHN,3)=1
36743 SIGH(NCHN)=FACLQA
36744 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
36745 240 CONTINUE
36746
36747 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
36748C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
36749 KFQSTR=KFPR(ISUB,2)
36750 KCQSTR=PYCOMP(KFQSTR)
36751 KFQEXC=MOD(KFQSTR,KEXCIT)
36752 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
36753 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36754 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36755C...Propagators: as simulated in PYOFSH and as desired
36756 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36757 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36758 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36759 GMMQC=SQRT(SQM4)*WDTP(0)
36760 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36761 FACQSA=FACQSA*HBW4C/HBW4
36762 FACQSB=FACQSB*HBW4C/HBW4
36763C...Branching ratios.
36764 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36765 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36766 DO 260 I=MMIN1,MMAX1
36767 IA=IABS(I)
36768 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
36769 DO 250 J=MMIN2,MMAX2
36770 JA=IABS(J)
36771 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
36772 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
36773 NCHN=NCHN+1
36774 ISIG(NCHN,1)=I
36775 ISIG(NCHN,2)=J
36776 ISIG(NCHN,3)=1
36777 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36778 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36779 NCHN=NCHN+1
36780 ISIG(NCHN,1)=I
36781 ISIG(NCHN,2)=J
36782 ISIG(NCHN,3)=2
36783 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36784 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36785 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
36786 NCHN=NCHN+1
36787 ISIG(NCHN,1)=I
36788 ISIG(NCHN,2)=J
36789 ISIG(NCHN,3)=1
36790 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36791 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
36792 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
36793 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
36794 NCHN=NCHN+1
36795 ISIG(NCHN,1)=I
36796 ISIG(NCHN,2)=J
36797 ISIG(NCHN,3)=1
36798 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36799 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36800 NCHN=NCHN+1
36801 ISIG(NCHN,1)=I
36802 ISIG(NCHN,2)=J
36803 ISIG(NCHN,3)=2
36804 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36805 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36806 ELSEIF(I.EQ.-J) THEN
36807 NCHN=NCHN+1
36808 ISIG(NCHN,1)=I
36809 ISIG(NCHN,2)=J
36810 ISIG(NCHN,3)=1
36811 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36812 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36813 NCHN=NCHN+1
36814 ISIG(NCHN,1)=I
36815 ISIG(NCHN,2)=J
36816 ISIG(NCHN,3)=2
36817 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36818 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36819 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
36820 NCHN=NCHN+1
36821 ISIG(NCHN,1)=I
36822 ISIG(NCHN,2)=J
36823 ISIG(NCHN,3)=1
36824 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36825 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
36826 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
36827 ENDIF
36828 250 CONTINUE
36829 260 CONTINUE
36830
36831 ELSEIF(ISUB.EQ.169) THEN
36832C...q + qbar -> e + e* (excited lepton)
36833 KFQSTR=KFPR(ISUB,2)
36834 KCQSTR=PYCOMP(KFQSTR)
36835 KFQEXC=MOD(KFQSTR,KEXCIT)
36836 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36837 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36838C...Propagators: as simulated in PYOFSH and as desired
36839 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36840 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36841 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36842 GMMQC=SQRT(SQM4)*WDTP(0)
36843 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36844 FACQSB=FACQSB*HBW4C/HBW4
36845C...Branching ratios.
36846 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36847 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36848 DO 270 I=MMIN1,MMAX1
36849 IA=IABS(I)
36850 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
36851 J=-I
36852 JA=IABS(J)
36853 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
36854 NCHN=NCHN+1
36855 ISIG(NCHN,1)=I
36856 ISIG(NCHN,2)=J
36857 ISIG(NCHN,3)=1
36858 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36859 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36860 NCHN=NCHN+1
36861 ISIG(NCHN,1)=I
36862 ISIG(NCHN,2)=J
36863 ISIG(NCHN,3)=2
36864 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36865 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36866 270 CONTINUE
36867 ENDIF
36868
36869 ELSEIF(ISUB.LE.360) THEN
36870 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
36871C...l + l -> H_L++/-- or H_R++/--.
36872 KFRES=KFPR(ISUB,1)
36873 KFREC=PYCOMP(KFRES)
36874 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36875 HS=SHR*WDTP(0)
36876 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
36877 DO 290 I=MMIN1,MMAX1
36878 IA=IABS(I)
36879 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
36880 & GOTO 290
36881 DO 280 J=MMIN2,MMAX2
36882 JA=IABS(J)
36883 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
36884 & GOTO 280
36885 IF(I*J.LT.0) GOTO 280
36886 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36887 NCHN=NCHN+1
36888 ISIG(NCHN,1)=I
36889 ISIG(NCHN,2)=J
36890 ISIG(NCHN,3)=1
36891 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
36892 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36893 SIGH(NCHN)=HI*FACBW*HF
36894 280 CONTINUE
36895 290 CONTINUE
36896
36897 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
36898C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
36899 KFRES=KFPR(ISUB,1)
36900 KFREC=PYCOMP(KFRES)
36901C...Propagators: as simulated in PYOFSH and as desired
36902 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
36903 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
36904 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36905 GMMC=SQRT(SQM3)*WDTP(0)
36906 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
36907 FHCC=COMFAC*AEM*HBW3C/HBW3
36908 DO 310 I=MMINA,MMAXA
36909 IA=IABS(I)
36910 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36911 SQML=PMAS(IA,1)**2
36912 J=ISIGN(KFPR(ISUB,2),-I)
36913 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36914 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36915 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36916 & (UH-SQM3)**2
36917 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36918 & (TH-SQM4)*SH)/(TH-SQM4)**2
36919 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36920 & SH)/(SH-SQML)**2
36921 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36922 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36923 & ((UH-SQM3)*(TH-SQM4))
36924 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36925 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36926 & ((UH-SQM3)*(SH-SQML))
36927 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36928 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36929 & ((SH-SQML)*(TH-SQM4))
36930 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36931 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36932 DO 300 ISDE=1,2
36933 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36934 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36935 NCHN=NCHN+1
36936 ISIG(NCHN,ISDE)=I
36937 ISIG(NCHN,3-ISDE)=22
36938 ISIG(NCHN,3)=0
36939 SIGH(NCHN)=FHCC*SMM*WIDSC
36940 300 CONTINUE
36941 310 CONTINUE
36942
36943 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36944C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36945 KFRES=KFPR(ISUB,1)
36946 KFREC=PYCOMP(KFRES)
36947 SQMH=PMAS(KFREC,1)**2
36948 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36949C...Propagators: H++/-- as simulated in PYOFSH and as desired
36950 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36951 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36952 GMMH3=SQRT(SQM3)*WDTP(0)
36953 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36954 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36955 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36956 GMMH4=SQRT(SQM4)*WDTP(0)
36957 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36958C...Kinematical and coupling functions
36959 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36960 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36961C...Loop over allowed flavours
36962 DO 320 I=MMINA,MMAXA
36963 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36964 EI=KCHG(IABS(I),1)/3D0
36965 AI=SIGN(1D0,EI+0.1D0)
36966 VI=AI-4D0*EI*XWV
36967 FCOI=1D0
36968 IF(IABS(I).LE.10) FCOI=FACA/3D0
36969 IF(ISUB.EQ.349) THEN
36970 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36971 IF(IABS(I).LT.10) THEN
36972 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36973 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36974 & (VI**2+AI**2)*XWHH**2*HBWZ)
36975 ELSE
36976 IAOFF=181+3*((IABS(I)-11)/2)
36977 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36978 & (4D0*PARU(1))
36979 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36980 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36981 & (VI**2+AI**2)*XWHH**2*HBWZ)+
36982 & 8D0*AEM*(EI*HSUM/(SH*TH)+
36983 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
36984 & 4D0*HSUM**2/TH2
36985 ENDIF
36986 ELSE
36987 IF(IABS(I).LT.10) THEN
36988 DSIGHH=8D0*AEM**2*EI**2/SH2
36989 ELSE
36990 IAOFF=181+3*((IABS(I)-11)/2)
36991 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36992 & (4D0*PARU(1))
36993 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
36994 & 4D0*HSUM**2/TH2
36995 ENDIF
36996 ENDIF
36997 NCHN=NCHN+1
36998 ISIG(NCHN,1)=I
36999 ISIG(NCHN,2)=-I
37000 ISIG(NCHN,3)=1
37001 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37002 320 CONTINUE
37003
37004 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37005C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37006 KFRES=KFPR(ISUB,1)
37007 KFREC=PYCOMP(KFRES)
37008 SQMH=PMAS(KFREC,1)**2
37009 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37010 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37011 & PMAS(PYCOMP(9900024),1)**2
37012 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37013 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37014 & (VINT(209)**2-VINT(216)))
37015 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37016 & (VINT(209)**2+2D0*VINT(218)))
37017 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37018 HS=SHR*WDTP(0)
37019 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37020 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37021 & FACBW=0D0
37022 DO 340 I=MMIN1,MMAX1
37023 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37024 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37025 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37026 DO 330 J=MMIN2,MMAX2
37027 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37028 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37029 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37030 KCHH=KCHWI+KCHWJ
37031 IF(IABS(KCHH).NE.2) GOTO 330
37032 FACLR=VINT(180+I)*VINT(180+J)
37033 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37034 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37035 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37036 ELSE
37037 FACPRP=FACPRT**2
37038 ENDIF
37039 NCHN=NCHN+1
37040 ISIG(NCHN,1)=I
37041 ISIG(NCHN,2)=J
37042 ISIG(NCHN,3)=1
37043 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37044 330 CONTINUE
37045 340 CONTINUE
37046
37047 ELSEIF(ISUB.EQ.353) THEN
37048C...f + fbar -> Z_R0
37049 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37050 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37051 HS=SHR*WDTP(0)
37052 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37053 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37054 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37055 DO 350 I=MMINA,MMAXA
37056 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37057 IF(IABS(I).LE.8) THEN
37058 EI=KCHG(IABS(I),1)/3D0
37059 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37060 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37061 ELSE
37062 AI=-(1D0-2D0*XW)
37063 VI=-1D0+4D0*XW
37064 ENDIF
37065 HI=HP*(VI**2+AI**2)
37066 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37067 NCHN=NCHN+1
37068 ISIG(NCHN,1)=I
37069 ISIG(NCHN,2)=-I
37070 ISIG(NCHN,3)=1
37071 SIGH(NCHN)=HI*FACBW*HF
37072 350 CONTINUE
37073
37074 ELSEIF(ISUB.EQ.354) THEN
37075C...f + fbar' -> W_R+/-
37076 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37077 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37078 HS=SHR*WDTP(0)
37079 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
37080 HP=AEM/(24D0*XW)*SH
37081 DO 370 I=MMIN1,MMAX1
37082 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
37083 IA=IABS(I)
37084 DO 360 J=MMIN2,MMAX2
37085 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
37086 JA=IABS(J)
37087 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
37088 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37089 & GOTO 360
37090 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37091 HI=HP*2D0
37092 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37093 NCHN=NCHN+1
37094 ISIG(NCHN,1)=I
37095 ISIG(NCHN,2)=J
37096 ISIG(NCHN,3)=1
37097 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37098 SIGH(NCHN)=HI*FACBW*HF
37099 360 CONTINUE
37100 370 CONTINUE
37101 ENDIF
37102
37103 ELSEIF(ISUB.LE.400) THEN
37104 IF(ISUB.EQ.391) THEN
37105C...f + fbar -> G*.
37106 KFGSTR=KFPR(ISUB,1)
37107 KCGSTR=PYCOMP(KFGSTR)
37108 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37109 HS=SHR*WDTP(0)
37110 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37111 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
37112 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37113C...Modify cross section in wings of peak.
37114 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37115 DO 380 I=MMINA,MMAXA
37116 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
37117 HI=1D0
37118 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37119 NCHN=NCHN+1
37120 ISIG(NCHN,1)=I
37121 ISIG(NCHN,2)=-I
37122 ISIG(NCHN,3)=1
37123 SIGH(NCHN)=FACG*HI
37124 380 CONTINUE
37125
37126 ELSEIF(ISUB.EQ.392) THEN
37127C...g + g -> G*.
37128 KFGSTR=KFPR(ISUB,1)
37129 KCGSTR=PYCOMP(KFGSTR)
37130 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37131 HS=SHR*WDTP(0)
37132 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37133 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
37134 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37135C...Modify cross section in wings of peak.
37136 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37137 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
37138 NCHN=NCHN+1
37139 ISIG(NCHN,1)=21
37140 ISIG(NCHN,2)=21
37141 ISIG(NCHN,3)=1
37142 SIGH(NCHN)=FACG
37143 390 CONTINUE
37144
37145 ELSEIF(ISUB.EQ.393) THEN
37146C...q + qbar -> g + G*.
37147 KFGSTR=KFPR(ISUB,2)
37148 KCGSTR=PYCOMP(KFGSTR)
37149 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
37150 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
37151 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
37152 & 2D0*SH2/(TH*UH))
37153C...Propagators: as simulated in PYOFSH and as desired
37154 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37155 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37156 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37157 HS=SQRT(SQM4)*WDTP(0)
37158 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37159 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37160 FACG=FACG*HBW4C/HBW4
37161 DO 400 I=MMINA,MMAXA
37162 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37163 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
37164 NCHN=NCHN+1
37165 ISIG(NCHN,1)=I
37166 ISIG(NCHN,2)=-I
37167 ISIG(NCHN,3)=1
37168 SIGH(NCHN)=FACG
37169 400 CONTINUE
37170
37171 ELSEIF(ISUB.EQ.394) THEN
37172C...q + g -> q + G*.
37173 KFGSTR=KFPR(ISUB,2)
37174 KCGSTR=PYCOMP(KFGSTR)
37175 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
37176 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
37177 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
37178 & 2D0*TH2*TH/(UH*SH2))
37179C...Propagators: as simulated in PYOFSH and as desired
37180 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37181 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37182 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37183 HS=SQRT(SQM4)*WDTP(0)
37184 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37185 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37186 FACG=FACG*HBW4C/HBW4
37187 DO 420 I=MMINA,MMAXA
37188 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
37189 DO 410 ISDE=1,2
37190 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
37191 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
37192 NCHN=NCHN+1
37193 ISIG(NCHN,ISDE)=I
37194 ISIG(NCHN,3-ISDE)=21
37195 ISIG(NCHN,3)=1
37196 SIGH(NCHN)=FACG
37197 410 CONTINUE
37198 420 CONTINUE
37199
37200 ELSEIF(ISUB.EQ.395) THEN
37201C...g + g -> g + G*.
37202 KFGSTR=KFPR(ISUB,2)
37203 KCGSTR=PYCOMP(KFGSTR)
37204 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
37205 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
37206 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
37207C...Propagators: as simulated in PYOFSH and as desired
37208 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37209 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37210 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37211 HS=SQRT(SQM4)*WDTP(0)
37212 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37213 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37214 FACG=FACG*HBW4C/HBW4
37215 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
37216 NCHN=NCHN+1
37217 ISIG(NCHN,1)=21
37218 ISIG(NCHN,2)=21
37219 ISIG(NCHN,3)=1
37220 SIGH(NCHN)=FACG
37221 ENDIF
37222 ENDIF
37223 ENDIF
37224
37225 RETURN
37226 END
37227
37228C*********************************************************************
37229
37230C...PYPDFU
37231C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
37232C...parton distributions according to a few different parametrizations.
37233C...Note that what is coded is x times the probability distribution,
37234C...i.e. xq(x,Q2) etc.
37235
37236 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
37237
37238C...Double precision and integer declarations.
37239 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37240 IMPLICIT INTEGER(I-N)
37241 INTEGER PYK,PYCHGE,PYCOMP
37242C...Commonblocks.
37243 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37245 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37246 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37247 COMMON/PYINT1/MINT(400),VINT(400)
37248 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37249 &XPDIR(-6:6)
37250 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37251 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
37252 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
37253 & XMI(2,240),PT2MI(240),IMISEP(0:240)
37254 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
37255 &/PYINT9/,/PYINTM/
37256C...Local arrays.
37257 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
37258 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
37259 SAVE PPAR
37260
37261C...Interface to PDFLIB.
11e297eb 37262 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
37263 SAVE /LW50513/
a59803b8 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...Data related to Schuler-Sjostrand photon distributions.
37270 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
37271
37272C...Valence PDF momentum integral parametrizations PER PARTON!
37273 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
37274 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
37275 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
37276 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
37277
37278C...Reset parton distributions.
37279 MINT(92)=0
37280 DO 100 KFL=-25,25
37281 XPQ(KFL)=0D0
37282 100 CONTINUE
37283 DO 110 KFL=-6,6
37284 XPVAL(KFL)=0D0
37285 110 CONTINUE
37286
37287C...Check x and particle species.
37288 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37289 WRITE(MSTU(11),5000) X
37290 GOTO 9999
37291 ENDIF
37292 KFA=IABS(KF)
37293 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
37294 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
37295 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
37296 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
37297 &KFA.NE.310.AND.KFA.NE.130) THEN
37298 WRITE(MSTU(11),5100) KF
37299 GOTO 9999
37300 ENDIF
37301
37302C...Electron (or muon or tau) parton distribution call.
37303 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
37304 CALL PYPDEL(KFA,X,Q2,XPEL)
37305 DO 120 KFL=-25,25
37306 XPQ(KFL)=XPEL(KFL)
37307 120 CONTINUE
37308
37309C...Photon parton distribution call (VDM+anomalous).
37310 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
37311 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
37312 CALL PYPDGA(X,Q2,XPGA)
37313 DO 130 KFL=-6,6
37314 XPQ(KFL)=XPGA(KFL)
37315 130 CONTINUE
37316 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37317 XPVAL(1)=XPVU/4D0
37318 XPVAL(2)=XPVU
37319 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37320 XPVAL(4)=MIN(XPQ(4),XPVU)
37321 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37322 XPVAL(-1)=XPVAL(1)
37323 XPVAL(-2)=XPVAL(2)
37324 XPVAL(-3)=XPVAL(3)
37325 XPVAL(-4)=XPVAL(4)
37326 XPVAL(-5)=XPVAL(5)
37327 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37328 Q2MX=Q2
37329 P2MX=0.36D0
37330 IF(MSTP(55).GE.7) P2MX=4.0D0
37331 IF(MSTP(57).EQ.0) Q2MX=P2MX
37332 P2=0D0
37333 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37334 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37335 DO 140 KFL=-6,6
37336 XPQ(KFL)=XPGA(KFL)
37337 XPVAL(KFL)=VXPDGM(KFL)
37338 140 CONTINUE
37339 VINT(231)=P2MX
37340 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37341 Q2MX=Q2
37342 P2MX=0.36D0
37343 IF(MSTP(55).GE.11) P2MX=4.0D0
37344 IF(MSTP(57).EQ.0) Q2MX=P2MX
37345 P2=0D0
37346 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37347 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37348 DO 150 KFL=-6,6
37349 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37350 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37351 150 CONTINUE
37352 VINT(231)=P2MX
37353 ELSEIF(MSTP(56).EQ.2) THEN
37354C...Call PDFLIB parton distributions.
37355 PARM(1)='NPTYPE'
37356 VALUE(1)=3
37357 PARM(2)='NGROUP'
37358 VALUE(2)=MSTP(55)/1000
37359 PARM(3)='NSET'
37360 VALUE(3)=MOD(MSTP(55),1000)
37361 IF(MINT(93).NE.3000000+MSTP(55)) THEN
37362 CALL PDFSET(PARM,VALUE)
37363 MINT(93)=3000000+MSTP(55)
37364 ENDIF
37365 XX=X
37366 QQ2=MAX(0D0,Q2MIN,Q2)
37367 IF(MSTP(57).EQ.0) QQ2=Q2MIN
37368 P2=0D0
37369 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37370 IP2=MSTP(60)
37371 IF(MSTP(55).EQ.5004) THEN
37372 IF(5D0*P2.LT.QQ2.AND.
37373 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
37374 & P2.GE.0D0.AND.P2.LT.10D0.AND.
37375 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
37376 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37377 & BOT,TOP,GLU)
37378 ELSE
37379 UPV=0D0
37380 DNV=0D0
37381 USEA=0D0
37382 DSEA=0D0
37383 STR=0D0
37384 CHM=0D0
37385 BOT=0D0
37386 TOP=0D0
37387 GLU=0D0
37388 ENDIF
37389 ELSE
37390 IF(P2.LT.QQ2) THEN
37391 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37392 & BOT,TOP,GLU)
37393 ELSE
37394 UPV=0D0
37395 DNV=0D0
37396 USEA=0D0
37397 DSEA=0D0
37398 STR=0D0
37399 CHM=0D0
37400 BOT=0D0
37401 TOP=0D0
37402 GLU=0D0
37403 ENDIF
37404 ENDIF
37405 VINT(231)=Q2MIN
37406 XPQ(0)=GLU
37407 XPQ(1)=DNV
37408 XPQ(-1)=DNV
37409 XPQ(2)=UPV
37410 XPQ(-2)=UPV
37411 XPQ(3)=STR
37412 XPQ(-3)=STR
37413 XPQ(4)=CHM
37414 XPQ(-4)=CHM
37415 XPQ(5)=BOT
37416 XPQ(-5)=BOT
37417 XPQ(6)=TOP
37418 XPQ(-6)=TOP
37419 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37420 XPVAL(1)=XPVU/4D0
37421 XPVAL(2)=XPVU
37422 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37423 XPVAL(4)=MIN(XPQ(4),XPVU)
37424 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37425 XPVAL(-1)=XPVAL(1)
37426 XPVAL(-2)=XPVAL(2)
37427 XPVAL(-3)=XPVAL(3)
37428 XPVAL(-4)=XPVAL(4)
37429 XPVAL(-5)=XPVAL(5)
37430 ELSE
37431 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
37432 ENDIF
37433
37434C...Pion/gammaVDM parton distribution call.
37435 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
37436 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37437 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
37438 & MSTP(55).LE.12) THEN
37439 ISET=1+MOD(MSTP(55)-1,4)
37440 Q2MX=Q2
37441 P2MX=0.36D0
37442 IF(ISET.GE.3) P2MX=4.0D0
37443 IF(MSTP(57).EQ.0) Q2MX=P2MX
37444 P2=0D0
37445 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37446 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37447 DO 160 KFL=-6,6
37448 XPQ(KFL)=XPVMD(KFL)
37449 XPVAL(KFL)=VXPVMD(KFL)
37450 160 CONTINUE
37451 VINT(231)=P2MX
37452 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
37453 CALL PYPDPI(X,Q2,XPPI)
37454 DO 170 KFL=-6,6
37455 XPQ(KFL)=XPPI(KFL)
37456 170 CONTINUE
37457 XPVAL(2)=XPQ(2)-XPQ(-2)
37458 XPVAL(-1)=XPQ(-1)-XPQ(1)
37459 ELSEIF(MSTP(54).EQ.2) THEN
37460C...Call PDFLIB parton distributions.
37461 PARM(1)='NPTYPE'
37462 VALUE(1)=2
37463 PARM(2)='NGROUP'
37464 VALUE(2)=MSTP(53)/1000
37465 PARM(3)='NSET'
37466 VALUE(3)=MOD(MSTP(53),1000)
37467 IF(MINT(93).NE.2000000+MSTP(53)) THEN
37468 CALL PDFSET(PARM,VALUE)
37469 MINT(93)=2000000+MSTP(53)
37470 ENDIF
37471 XX=X
37472 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37473 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37474 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37475 VINT(231)=Q2MIN
37476 XPQ(0)=GLU
37477 XPQ(1)=DSEA
37478 XPQ(-1)=UPV+DSEA
37479 XPQ(2)=UPV+USEA
37480 XPQ(-2)=USEA
37481 XPQ(3)=STR
37482 XPQ(-3)=STR
37483 XPQ(4)=CHM
37484 XPQ(-4)=CHM
37485 XPQ(5)=BOT
37486 XPQ(-5)=BOT
37487 XPQ(6)=TOP
37488 XPQ(-6)=TOP
37489 XPVAL(2)=UPV
37490 XPVAL(-1)=UPV
37491 ELSE
37492 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
37493 ENDIF
37494
37495C...Anomalous photon parton distribution call.
37496 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
37497 Q2MX=Q2
37498 P2MX=PARP(15)**2
37499 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
37500 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
37501 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
37502 IF(MSTP(57).EQ.0) Q2MX=P2MX
37503 P2=0D0
37504 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37505 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37506 DO 180 KFL=-6,6
37507 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
37508 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
37509 180 CONTINUE
37510 VINT(231)=P2MX
37511 ELSEIF(MSTP(56).EQ.1) THEN
37512 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
37513 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
37514 IF(MSTP(57).EQ.0) Q2MX=P2MX
37515 P2=0D0
37516 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37517 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37518 DO 190 KFL=-6,6
37519 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37520 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37521 190 CONTINUE
37522 VINT(231)=P2MX
37523 ELSEIF(MSTP(56).EQ.2) THEN
37524 IF(MSTP(57).EQ.0) Q2MX=P2MX
37525 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
37526 DO 200 KFL=-6,6
37527 XPQ(KFL)=XPGA(KFL)
37528 XPVAL(KFL)=VXPGA(KFL)
37529 200 CONTINUE
37530 VINT(231)=P2MX
37531 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
37532 IF(MSTP(57).EQ.0) Q2MX=P2MX
37533 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37534 DO 210 KFL=-6,6
37535 XPQ(KFL)=XPGA(KFL)
37536 XPVAL(KFL)=VXPGA(KFL)
37537 210 CONTINUE
37538 VINT(231)=P2MX
37539 ELSE
37540 220 RKF=11D0*PYR(0)
37541 KFR=1
37542 IF(RKF.GT.1D0) KFR=2
37543 IF(RKF.GT.5D0) KFR=3
37544 IF(RKF.GT.6D0) KFR=4
37545 IF(RKF.GT.10D0) KFR=5
37546 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
37547 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
37548 IF(MSTP(57).EQ.0) Q2MX=P2MX
37549 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37550 DO 230 KFL=-6,6
37551 XPQ(KFL)=XPGA(KFL)
37552 XPVAL(KFL)=VXPGA(KFL)
37553 230 CONTINUE
37554 VINT(231)=P2MX
37555 ENDIF
37556
37557C...Proton parton distribution call.
37558 ELSE
37559 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
37560 CALL PYPDPR(X,Q2,XPPR)
37561 DO 240 KFL=-6,6
37562 XPQ(KFL)=XPPR(KFL)
37563 240 CONTINUE
37564 XPVAL(1)=XPQ(1)-XPQ(-1)
37565 XPVAL(2)=XPQ(2)-XPQ(-2)
37566 ELSEIF(MSTP(52).EQ.2) THEN
37567C...Call PDFLIB parton distributions.
37568 PARM(1)='NPTYPE'
37569 VALUE(1)=1
37570 PARM(2)='NGROUP'
37571 VALUE(2)=MSTP(51)/1000
37572 PARM(3)='NSET'
37573 VALUE(3)=MOD(MSTP(51),1000)
37574 IF(MINT(93).NE.1000000+MSTP(51)) THEN
37575 CALL PDFSET(PARM,VALUE)
37576 MINT(93)=1000000+MSTP(51)
37577 ENDIF
37578 XX=X
37579 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37580 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37581 CALL STRUCTM_ALICE
37582 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37583 VINT(231)=Q2MIN
37584 XPQ(0)=GLU
37585 XPQ(1)=DNV+DSEA
37586 XPQ(-1)=DSEA
37587 XPQ(2)=UPV+USEA
37588 XPQ(-2)=USEA
37589 XPQ(3)=STR
37590 XPQ(-3)=STR
37591 XPQ(4)=CHM
37592 XPQ(-4)=CHM
37593 XPQ(5)=BOT
37594 XPQ(-5)=BOT
37595 XPQ(6)=TOP
37596 XPQ(-6)=TOP
37597 XPVAL(1)=DNV
37598 XPVAL(2)=UPV
37599 ELSE
37600 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
37601 ENDIF
37602 ENDIF
37603
37604C...Isospin average for pi0/gammaVDM.
37605 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37606 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
37607 XPV=XPQ(2)-XPQ(1)
37608 XPQ(2)=XPQ(1)
37609 XPQ(-2)=XPQ(-1)
37610 ELSE
37611 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37612 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37613 XPQ(2)=XPS
37614 XPQ(-1)=XPS
37615 ENDIF
37616 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
37617 & XPVAL(3)+XPVAL(4)+XPVAL(5)
37618 DO 250 KFL=-6,6
37619 XPVAL(KFL)=0D0
37620 250 CONTINUE
37621 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
37622 XPQ(1)=XPQ(1)+0.2D0*XPV
37623 XPQ(2)=XPQ(2)+0.8D0*XPV
37624 XPVAL(1)=0.2D0*XPVL
37625 XPVAL(2)=0.8D0*XPVL
37626 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
37627 XPQ(3)=XPQ(3)+XPV
37628 XPVAL(3)=XPVL
37629 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
37630 XPQ(4)=XPQ(4)+XPV
37631 XPVAL(4)=XPVL
37632 IF(MSTP(55).GE.9) THEN
37633 DO 260 KFL=-6,6
37634 XPQ(KFL)=0D0
37635 260 CONTINUE
37636 ENDIF
37637 ELSE
37638 XPQ(1)=XPQ(1)+0.5D0*XPV
37639 XPQ(2)=XPQ(2)+0.5D0*XPV
37640 XPVAL(1)=0.5D0*XPVL
37641 XPVAL(2)=0.5D0*XPVL
37642 ENDIF
37643 DO 270 KFL=1,6
37644 XPQ(-KFL)=XPQ(KFL)
37645 XPVAL(-KFL)=XPVAL(KFL)
37646 270 CONTINUE
37647
37648C...Rescale for gammaVDM by effective gamma -> rho coupling.
37649C+++Do not rescale?
37650 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
37651 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
37652 DO 280 KFL=-6,6
37653 XPQ(KFL)=VINT(281)*XPQ(KFL)
37654 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
37655 280 CONTINUE
37656 VINT(232)=VINT(281)*XPV
37657 ENDIF
37658
37659C...Simple recipes for kaons.
37660 ELSEIF(KFA.EQ.321) THEN
37661 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
37662 XPQ(-1)=XPQ(1)
37663 XPVAL(-3)=XPVAL(-1)
37664 XPVAL(-1)=0D0
37665 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
37666 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37667 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37668 XPQ(2)=XPS
37669 XPQ(-1)=XPS
37670 XPQ(1)=XPQ(1)+0.5D0*XPV
37671 XPQ(-1)=XPQ(-1)+0.5D0*XPV
37672 XPQ(3)=XPQ(3)+0.5D0*XPV
37673 XPQ(-3)=XPQ(-3)+0.5D0*XPV
37674 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
37675 XPVAL(2)=0D0
37676 XPVAL(-1)=0D0
37677 XPVAL(1)=0.5D0*XPV
37678 XPVAL(-1)=0.5D0*XPV
37679 XPVAL(3)=0.5D0*XPV
37680 XPVAL(-3)=0.5D0*XPV
37681
37682C...Isospin conjugation for neutron.
37683 ELSEIF(KFA.EQ.2112) THEN
37684 XPSV=XPQ(1)
37685 XPQ(1)=XPQ(2)
37686 XPQ(2)=XPSV
37687 XPSV=XPQ(-1)
37688 XPQ(-1)=XPQ(-2)
37689 XPQ(-2)=XPSV
37690 XPSV=XPVAL(1)
37691 XPVAL(1)=XPVAL(2)
37692 XPVAL(2)=XPSV
37693
37694C...Simple recipes for hyperon (average valence parton distribution).
37695 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
37696 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
37697 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
37698 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
37699 XPQ(1)=XPS
37700 XPQ(2)=XPS
37701 XPQ(-1)=XPS
37702 XPQ(-2)=XPS
37703 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
37704 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
37705 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
37706 XPV=(XPVAL(1)+XPVAL(2))/3D0
37707 XPVAL(1)=0D0
37708 XPVAL(2)=0D0
37709 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
37710 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
37711 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
37712 ENDIF
37713
37714C...Charge conjugation for antiparticle.
37715 IF(KF.LT.0) THEN
37716 DO 290 KFL=1,25
37717 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
37718 XPSV=XPQ(KFL)
37719 XPQ(KFL)=XPQ(-KFL)
37720 XPQ(-KFL)=XPSV
37721 290 CONTINUE
37722 DO 300 KFL=1,6
37723 XPSV=XPVAL(KFL)
37724 XPVAL(KFL)=XPVAL(-KFL)
37725 XPVAL(-KFL)=XPSV
37726 300 CONTINUE
37727 ENDIF
37728
37729C...MULTIPLE INTERACTIONS - PDF RESHAPING.
37730C...Set side.
37731 JS=MINT(30)
37732C...Only reshape PDFs for the non-first interactions;
37733C...But need valence/sea separation already from first interaction.
37734 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
37735 KFVSEL=KFIVAL(JS,1)
37736C...If valence quark kicked out of pi0 or gamma then that decides
37737C...whether we should consider state as d dbar, u ubar, s sbar, etc.
37738 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
37739 XPVL=0D0
37740 DO 310 KFL=1,6
37741 XPVL=XPVL+XPVAL(KFL)
37742 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
37743 XPVAL(KFL)=0D0
37744 310 CONTINUE
37745 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
37746 XPVAL(IABS(KFVSEL))=XPVL
37747 DO 320 KFL=1,6
37748 XPQ(-KFL)=XPQ(KFL)
37749 XPVAL(-KFL)=XPVAL(KFL)
37750 320 CONTINUE
37751
37752C...If valence quark kicked out of K0S or K0S then that decides whether
37753C...we should consider state as d sbar or s dbar.
37754 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
37755 KFS=1
37756 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
37757 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37758 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37759 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37760 XPVAL(-KFS)=0D0
37761 KFS=-3*KFS
37762 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37763 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37764 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37765 XPVAL(-KFS)=0D0
37766 ENDIF
37767
37768C...XPQ distributions are nominal for a (signed) beam particle
37769C...of KF type, with 1-Sum(x_prev) rescaled to 1.
37770 CMPFAC=1D0
37771 NRESC=0
37772 345 NRESC=NRESC+1
37773 PVCTOT(JS,-1)=0D0
37774 PVCTOT(JS, 0)=0D0
37775 PVCTOT(JS, 1)=0D0
37776 DO 350 IFL=-6,6
37777 IF(IFL.EQ.0) GOTO 350
37778
37779C...Count up number of original IFL valence quarks.
37780 IVORG=0
37781 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
37782 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
37783 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
37784C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
37785C...bookkeep as if d dbar (for total momentum sum in valence sector).
37786 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
37787C...Count down number of remaining IFL valence quarks. Skip current
37788C...interaction initiator.
37789 IVREM=IVORG
37790 DO 330 I1=1,NMI(JS)
37791 IF (I1.EQ.MINT(36)) GOTO 330
37792 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
37793 & IVREM=IVREM-1
37794 330 CONTINUE
37795
37796C...Separate out original VALENCE and SEA content.
37797 VAL=XPVAL(IFL)
37798 SEA=MAX(0D0,XPQ(IFL)-VAL)
37799 XPSVC(IFL,0)=VAL
37800 XPSVC(IFL,-1)=SEA
37801
37802C...Rescale valence content if changed.
37803 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
37804 & (VAL*IVREM)/IVORG
37805
37806C...Momentum integrals of original and removed valence quarks.
37807 IF(IVORG.NE.0) THEN
37808C...For p/n/pbar/nbar beams can split into d_val and u_val.
37809C...Isospin conjugation for neutrons
37810 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
37811 IAFLP=IABS(IFL)
37812 IF (KFA.EQ.2112) IAFLP=3-IAFLP
37813 VPAVG=PAVG(IAFLP,Q2)
37814C...For other baryons average d_val and u_val, like for PDFs.
37815 ELSEIF(KFA.GT.1000) THEN
37816 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
37817C...For mesons and photon average d_val and u_val and scale by 3/2.
37818C...Very crude, especially for photon.
37819 ELSE
37820 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
37821 ENDIF
37822 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
37823 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
37824 ENDIF
37825
37826C...Now add companions (at X with partner having been at Z=XASSOC).
37827C...NOTE: due to the assumed simple x scaling, the partner was at what
37828C...corresponds to a higher Z than XASSOC, if there were intermediate
37829C...scatterings. Nothing done about that for the moment.
37830 DO 340 IVC=1,NVC(JS,IFL)
37831C...Skip companions that have been kicked out
37832 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
37833 XPSVC(IFL,IVC)=0D0
37834 GOTO 340
37835 ELSE
37836C...Momentum fraction of the partner quark.
37837C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
37838 XS=XASSOC(JS,IFL,IVC)
37839 XREM=VINT(142+JS)
37840 YS=XS/(XREM+XS)
37841C...Momentum fraction of the companion quark.
37842C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
37843 Y=X*(1D0-YS)
37844 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
37845C...Add to momentum sum, with rescaling compensation factor.
37846 XCFAC=(XREM+XS)/XREM*CMPFAC
37847 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
37848 ENDIF
37849 340 CONTINUE
37850 350 CONTINUE
37851
37852C...Wait until all flavours treated, then rescale seas and gluon.
37853 XPSVC(0,-1)=XPQ(0)
37854 XPSVC(0,0)=0D0
37855 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
37856 IF (RSFAC.LE.0D0) THEN
37857C...First calculate factor needed to exactly restore pz cons.
37858 IF (NRESC.EQ.1) CMPFAC =
37859 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
37860C...Add a bit of headroom
37861 CMPFAC=0.99*CMPFAC
37862C...Try a few times if more headroom is needed, then print error message.
37863 IF (NRESC.LE.10) GOTO 345
37864 CALL PYERRM(15,
37865 & '(PYPDFU:) Negative reshaping factor persists!')
37866 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
37867 RSFAC=0D0
37868 ENDIF
37869 DO 370 IFL=-6,6
37870 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
37871C...Also store resulting distributions in XPQ
37872 XPQ(IFL)=0D0
37873 DO 360 ISVC=-1,NVC(JS,IFL)
37874 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
37875 360 CONTINUE
37876 370 CONTINUE
37877C...Save companion reweighting factor for PYPTIS.
37878 VINT(140)=CMPFAC
37879 ENDIF
37880
37881
37882C...Allow gluon also in position 21.
37883 XPQ(21)=XPQ(0)
37884
37885C...Check positivity and reset above maximum allowed flavour.
37886 DO 380 KFL=-25,25
37887 XPQ(KFL)=MAX(0D0,XPQ(KFL))
37888 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
37889 380 CONTINUE
37890
37891C...Formats for error printouts.
37892 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37893 5100 FORMAT(' Error: illegal particle code for parton distribution;',
37894 &' KF =',I5)
37895 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
37896 &3I5)
37897 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
37898 & ' Removed valence momentum fraction : ',F6.3/
37899 & ' Added companion momentum fraction : ',F6.3/
37900 & ' Resulting rescale factor : ',F6.3)
37901
37902C...Reset side pointer and return
37903 9999 MINT(30)=0
37904
37905 RETURN
37906 END
37907
37908C*********************************************************************
37909
37910C...PYPDFL
37911C...Gives proton parton distribution at small x and/or Q^2 according to
37912C...correct limiting behaviour.
37913
37914 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37915
37916C...Double precision and integer declarations.
37917 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37918 IMPLICIT INTEGER(I-N)
37919 INTEGER PYK,PYCHGE,PYCOMP
37920C...Commonblocks.
37921 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37922 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37923 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37924 COMMON/PYINT1/MINT(400),VINT(400)
37925 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37926C...Local arrays.
37927 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37928 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37929
37930C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37931 MINT(92)=0
37932 KFA=IABS(KF)
37933 IACC=0
37934 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37935 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37936 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37937 IF(IACC.EQ.0) THEN
37938 CALL PYPDFU(KF,X,Q2,XPQ)
37939 RETURN
37940 ENDIF
37941
37942C...Reset. Check x.
37943 DO 100 KFL=-25,25
37944 XPQ(KFL)=0D0
37945 100 CONTINUE
37946 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37947 WRITE(MSTU(11),5000) X
37948 RETURN
37949 ENDIF
37950
37951C...Define valence content.
37952 KFC=KF
37953 NV1=2
37954 NV2=1
37955 IF(KF.EQ.2212) THEN
37956 KFV1=2
37957 KFV2=1
37958 ELSEIF(KF.EQ.-2212) THEN
37959 KFV1=-2
37960 KFV2=-1
37961 ELSEIF(KF.EQ.2112) THEN
37962 KFV1=1
37963 KFV2=2
37964 ELSEIF(KF.EQ.-2112) THEN
37965 KFV1=-1
37966 KFV2=-2
37967 ELSEIF(KF.EQ.211) THEN
37968 NV1=1
37969 KFV1=2
37970 KFV2=-1
37971 ELSEIF(KF.EQ.-211) THEN
37972 NV1=1
37973 KFV1=-2
37974 KFV2=1
37975 ELSEIF(MINT(105).LE.223) THEN
37976 KFV1=1
37977 WTV1=0.2D0
37978 KFV2=2
37979 WTV2=0.8D0
37980 ELSEIF(MINT(105).EQ.333) THEN
37981 KFV1=3
37982 WTV1=1.0D0
37983 KFV2=1
37984 WTV2=0.0D0
37985 ELSEIF(MINT(105).EQ.443) THEN
37986 KFV1=4
37987 WTV1=1.0D0
37988 KFV2=1
37989 WTV2=0.0D0
37990 ENDIF
37991
37992C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
37993 MINT30=MINT(30)
37994 CALL PYPDFU(KFC,X,Q2,XPA)
37995 Q2MN=MAX(3D0,VINT(231))
37996 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
37997 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
37998
37999C...Large Q2 and large x: naive call is enough.
38000 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38001 DO 110 KFL=-25,25
38002 XPQ(KFL)=XPA(KFL)
38003 110 CONTINUE
38004 MINT(92)=1
38005
38006C...Small Q2 and large x: dampen boundary value.
38007 ELSEIF(X.GT.XMN) THEN
38008
38009C...Evaluate at boundary and define dampening factors.
38010 MINT(30)=MINT30
38011 CALL PYPDFU(KFC,X,Q2MN,XPA)
38012 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38013 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38014
38015C...Separate valence and sea parts of parton distribution.
38016 IF(KFA.NE.22) THEN
38017 XFV1=XPA(KFV1)-XPA(-KFV1)
38018 XPA(KFV1)=XPA(-KFV1)
38019 XFV2=XPA(KFV2)-XPA(-KFV2)
38020 XPA(KFV2)=XPA(-KFV2)
38021 ELSE
38022 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38023 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38024 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38025 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38026 ENDIF
38027
38028C...Dampen valence and sea separately. Put back together.
38029 DO 120 KFL=-25,25
38030 XPQ(KFL)=FS*XPA(KFL)
38031 120 CONTINUE
38032 IF(KFA.NE.22) THEN
38033 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38034 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38035 ELSE
38036 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38037 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38038 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38039 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38040 ENDIF
38041 MINT(92)=2
38042
38043C...Large Q2 and small x: interpolate behaviour.
38044 ELSEIF(Q2.GT.Q2MN) THEN
38045
38046C...Evaluate at extremes and define coefficients for interpolation.
38047 MINT(30)=MINT30
38048 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38049 VI232A=VINT(232)
38050 MINT(30)=MINT30
38051 CALL PYPDFU(KFC,X,Q2B,XPB)
38052 VI232B=VINT(232)
38053 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38054 FVA=(X/XMN)**0.45D0*FLA
38055 FSA=(X/XMN)**(-0.08D0)*FLA
38056 FB=1D0-FLA
38057
38058C...Separate valence and sea parts of parton distribution.
38059 IF(KFA.NE.22) THEN
38060 XFVA1=XPA(KFV1)-XPA(-KFV1)
38061 XPA(KFV1)=XPA(-KFV1)
38062 XFVA2=XPA(KFV2)-XPA(-KFV2)
38063 XPA(KFV2)=XPA(-KFV2)
38064 XFVB1=XPB(KFV1)-XPB(-KFV1)
38065 XPB(KFV1)=XPB(-KFV1)
38066 XFVB2=XPB(KFV2)-XPB(-KFV2)
38067 XPB(KFV2)=XPB(-KFV2)
38068 ELSE
38069 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38070 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38071 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38072 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38073 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38074 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38075 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38076 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
38077 ENDIF
38078
38079C...Interpolate for valence and sea. Put back together.
38080 DO 130 KFL=-25,25
38081 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
38082 130 CONTINUE
38083 IF(KFA.NE.22) THEN
38084 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
38085 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
38086 ELSE
38087 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38088 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38089 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38090 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38091 ENDIF
38092 MINT(92)=3
38093
38094C...Small Q2 and small x: dampen boundary value and add term.
38095 ELSE
38096
38097C...Evaluate at boundary and define dampening factors.
38098 MINT(30)=MINT30
38099 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38100 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
38101 FA=1D0-FB
38102 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
38103 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
38104 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
38105 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
38106 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
38107 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
38108
38109C...Separate valence and sea parts of parton distribution.
38110 IF(KFA.NE.22) THEN
38111 XFV1=XPA(KFV1)-XPA(-KFV1)
38112 XPA(KFV1)=XPA(-KFV1)
38113 XFV2=XPA(KFV2)-XPA(-KFV2)
38114 XPA(KFV2)=XPA(-KFV2)
38115 ELSE
38116 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38117 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38118 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38119 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38120 ENDIF
38121
38122C...Dampen valence and sea separately. Add constant terms.
38123C...Put back together.
38124 DO 140 KFL=-25,25
38125 XPQ(KFL)=FSA*XPA(KFL)
38126 140 CONTINUE
38127 IF(KFA.NE.22) THEN
38128 DO 150 KFL=-3,3
38129 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
38130 150 CONTINUE
38131 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
38132 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
38133 ELSE
38134 DO 160 KFL=-3,3
38135 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
38136 160 CONTINUE
38137 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38138 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38139 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38140 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38141 ENDIF
38142 XPQ(21)=XPQ(0)
38143 MINT(92)=4
38144 ENDIF
38145
38146C...Format for error printout.
38147 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38148
38149 RETURN
38150 END
38151
38152C*********************************************************************
38153
38154C...PYPDEL
38155C...Gives electron (or muon, or tau) parton distribution.
38156
38157 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
38158
38159C...Double precision and integer declarations.
38160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38161 IMPLICIT INTEGER(I-N)
38162 INTEGER PYK,PYCHGE,PYCOMP
38163C...Commonblocks.
38164 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38165 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38166 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38167 COMMON/PYINT1/MINT(400),VINT(400)
38168 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38169C...Local arrays.
38170 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
38171
38172C...Interface to PDFLIB.
11e297eb 38173 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
38174 SAVE /LW50513/
a59803b8 38175 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38176 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38177 CHARACTER*20 PARM(20)
38178 DATA VALUE/20*0D0/,PARM/20*' '/
38179
38180C...Some common constants.
38181 DO 100 KFL=-25,25
38182 XPEL(KFL)=0D0
38183 100 CONTINUE
38184 AEM=PARU(101)
38185 PME=PMAS(11,1)
38186 IF(KFA.EQ.13) PME=PMAS(13,1)
38187 IF(KFA.EQ.15) PME=PMAS(15,1)
38188 XL=LOG(MAX(1D-10,X))
38189 X1L=LOG(MAX(1D-10,1D0-X))
38190 HLE=LOG(MAX(3D0,Q2/PME**2))
38191 HBE2=(AEM/PARU(1))*(HLE-1D0)
38192
38193C...Electron inside electron, see R. Kleiss et al., in Z physics at
38194C...LEP 1, CERN 89-08, p. 34
38195 IF(MSTP(59).LE.1) THEN
38196 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
38197 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
38198 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
38199 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
38200 & 4D0*XL/(1D0-X)-5D0-X)
38201 ELSE
38202 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
38203 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
38204 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
38205 ENDIF
38206C...Zero distribution for very large x and rescale it for intermediate.
38207 IF(X.GT.1D0-1D-10) THEN
38208 HEE=0D0
38209 ELSEIF(X.GT.1D0-1D-7) THEN
38210 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
38211 ENDIF
38212 XPEL(KFA)=X*HEE
38213
38214C...Photon and (transverse) W- inside electron.
38215 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
38216 IF(MSTP(13).LE.1) THEN
38217 HLG=HLE
38218 ELSE
38219 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
38220 ENDIF
38221 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
38222 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
38223 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
38224
38225C...Electron or positron inside photon inside electron.
38226 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
38227 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
38228 & 2D0*X*(1D0+X)*XL)
38229 XPEL(11)=XPEL(11)+XFSEA
38230 XPEL(-11)=XFSEA
38231
38232C...Initialize PDFLIB photon parton distributions.
38233 IF(MSTP(56).EQ.2) THEN
38234 PARM(1)='NPTYPE'
38235 VALUE(1)=3
38236 PARM(2)='NGROUP'
38237 VALUE(2)=MSTP(55)/1000
38238 PARM(3)='NSET'
38239 VALUE(3)=MOD(MSTP(55),1000)
38240 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38241 CALL PDFSET(PARM,VALUE)
38242 MINT(93)=3000000+MSTP(55)
38243 ENDIF
38244 ENDIF
38245
38246C...Quarks and gluons inside photon inside electron:
38247C...numerical convolution required.
38248 DO 110 KFL=0,6
38249 SXP(KFL)=0D0
38250 110 CONTINUE
38251 SUMXPP=0D0
38252 ITER=-1
38253 120 ITER=ITER+1
38254 SUMXP=SUMXPP
38255 NSTP=2**(ITER-1)
38256 IF(ITER.EQ.0) NSTP=2
38257 DO 130 KFL=0,6
38258 SXP(KFL)=0.5D0*SXP(KFL)
38259 130 CONTINUE
38260 WTSTP=0.5D0/NSTP
38261 IF(ITER.EQ.0) WTSTP=0.5D0
38262C...Pick grid of x_{gamma} values logarithmically even.
38263 DO 150 ISTP=1,NSTP
38264 IF(ITER.EQ.0) THEN
38265 XLE=XL*(ISTP-1)
38266 ELSE
38267 XLE=XL*(ISTP-0.5D0)/NSTP
38268 ENDIF
38269 XE=MIN(1D0-1D-10,EXP(XLE))
38270 XG=MIN(1D0-1D-10,X/XE)
38271C...Evaluate photon inside electron parton distribution for convolution.
38272 XPGP=1D0+(1D0-XE)**2
38273 IF(MSTP(13).LE.1) THEN
38274 XPGP=XPGP*HLE
38275 ELSE
38276 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
38277 ENDIF
38278C...Evaluate photon parton distributions for convolution.
38279 IF(MSTP(56).EQ.1) THEN
38280 IF(MSTP(55).EQ.1) THEN
38281 CALL PYPDGA(XG,Q2,XPGA)
38282 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38283 Q2MX=Q2
38284 P2MX=0.36D0
38285 IF(MSTP(55).GE.7) P2MX=4.0D0
38286 IF(MSTP(57).EQ.0) Q2MX=P2MX
38287 P2=0D0
38288 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38289 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38290 VINT(231)=P2MX
38291 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38292 Q2MX=Q2
38293 P2MX=0.36D0
38294 IF(MSTP(55).GE.11) P2MX=4.0D0
38295 IF(MSTP(57).EQ.0) Q2MX=P2MX
38296 P2=0D0
38297 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38298 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38299 VINT(231)=P2MX
38300 ENDIF
38301 DO 140 KFL=0,5
38302 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
38303 140 CONTINUE
38304 ELSEIF(MSTP(56).EQ.2) THEN
38305C...Call PDFLIB parton distributions.
38306 XX=XG
38307 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38308 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38309 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38310 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
38311 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
38312 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
38313 SXP(3)=SXP(3)+WTSTP*XPGP*STR
38314 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
38315 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
38316 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
38317 ENDIF
38318 150 CONTINUE
38319 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
38320 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
38321 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
38322
38323C...Put convolution into output arrays.
38324 FCONV=AEMP*(-XL)
38325 XPEL(0)=FCONV*SXP(0)
38326 DO 160 KFL=1,6
38327 XPEL(KFL)=FCONV*SXP(KFL)
38328 XPEL(-KFL)=XPEL(KFL)
38329 160 CONTINUE
38330 ENDIF
38331
38332 RETURN
38333 END
38334
38335C*********************************************************************
38336
38337C...PYPDGA
38338C...Gives photon parton distribution.
38339
38340 SUBROUTINE PYPDGA(X,Q2,XPGA)
38341
38342C...Double precision and integer declarations.
38343 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38344 IMPLICIT INTEGER(I-N)
38345 INTEGER PYK,PYCHGE,PYCOMP
38346C...Commonblocks.
38347 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38348 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38349 COMMON/PYINT1/MINT(400),VINT(400)
38350 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38351C...Local arrays.
38352 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
38353 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
38354 &DGCS(4,3),DGDS(4,3),DGES(4,3)
38355
38356C...The following data lines are coefficients needed in the
38357C...Drees and Grassie photon parton distribution parametrization.
38358 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
38359 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
38360 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
38361 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
38362 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
38363 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
38364 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
38365 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
38366 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
38367 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
38368 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
38369 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
38370 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
38371 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
38372 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
38373 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
38374 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
38375 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
38376 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
38377 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
38378 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
38379 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
38380 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
38381 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
38382 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
38383 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
38384
38385C...Photon parton distribution from Drees and Grassie.
38386C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
38387 DO 100 KFL=-6,6
38388 XPGA(KFL)=0D0
38389 100 CONTINUE
38390 VINT(231)=1D0
38391 IF(MSTP(57).LE.0) THEN
38392 T=LOG(1D0/0.16D0)
38393 ELSE
38394 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
38395 ENDIF
38396 X1=1D0-X
38397 NF=3
38398 IF(Q2.GT.25D0) NF=4
38399 IF(Q2.GT.300D0) NF=5
38400 NFE=NF-2
38401 AEM=PARU(101)
38402
38403C...Evaluate gluon content.
38404 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
38405 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
38406 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
38407 XPGL=DGA*X**DGB*X1**DGC
38408
38409C...Evaluate up- and down-type quark content.
38410 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
38411 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
38412 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
38413 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
38414 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
38415 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38416 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
38417 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
38418 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
38419 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
38420 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
38421 DGF=9D0
38422 IF(NF.EQ.4) DGF=10D0
38423 IF(NF.EQ.5) DGF=55D0/6D0
38424 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38425 IF(NF.LE.3) THEN
38426 XPQU=(XPQS+9D0*XPQN)/6D0
38427 XPQD=(XPQS-4.5D0*XPQN)/6D0
38428 ELSEIF(NF.EQ.4) THEN
38429 XPQU=(XPQS+6D0*XPQN)/8D0
38430 XPQD=(XPQS-6D0*XPQN)/8D0
38431 ELSE
38432 XPQU=(XPQS+7.5D0*XPQN)/10D0
38433 XPQD=(XPQS-5D0*XPQN)/10D0
38434 ENDIF
38435
38436C...Put into output arrays.
38437 XPGA(0)=AEM*XPGL
38438 XPGA(1)=AEM*XPQD
38439 XPGA(2)=AEM*XPQU
38440 XPGA(3)=AEM*XPQD
38441 IF(NF.GE.4) XPGA(4)=AEM*XPQU
38442 IF(NF.GE.5) XPGA(5)=AEM*XPQD
38443 DO 110 KFL=1,6
38444 XPGA(-KFL)=XPGA(KFL)
38445 110 CONTINUE
38446
38447 RETURN
38448 END
38449
38450C*********************************************************************
38451
38452C...PYGGAM
38453C...Constructs the F2 and parton distributions of the photon
38454C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
38455C...For F2, c and b are included by the Bethe-Heitler formula;
38456C...in the 'MSbar' scheme additionally a Cgamma term is added.
38457C...Contains the SaS sets 1D, 1M, 2D and 2M.
38458C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38459
38460 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
38461
38462C...Double precision and integer declarations.
38463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38464 IMPLICIT INTEGER(I-N)
38465 INTEGER PYK,PYCHGE,PYCOMP
38466C...Commonblocks.
38467 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38468 &XPDIR(-6:6)
38469 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38470 SAVE /PYINT8/,/PYINT9/
38471C...Local arrays.
38472 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
38473C...Charm and bottom masses (low to compensate for J/psi etc.).
38474 DATA PMC/1.3D0/, PMB/4.6D0/
38475C...alpha_em and alpha_em/(2*pi).
38476 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
38477C...Lambda value for 4 flavours.
38478 DATA ALAM/0.20D0/
38479C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
38480 DATA FRACU/0.8D0/
38481C...VMD couplings f_V**2/(4*pi).
38482 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
38483C...Masses for rho (=omega) and phi.
38484 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
38485C...Number of points in integration for IP2=1.
38486 DATA NSTEP/100/
38487
38488C...Reset output.
38489 F2GM=0D0
38490 DO 100 KFL=-6,6
38491 XPDFGM(KFL)=0D0
38492 XPVMD(KFL)=0D0
38493 XPANL(KFL)=0D0
38494 XPANH(KFL)=0D0
38495 XPBEH(KFL)=0D0
38496 XPDIR(KFL)=0D0
38497 VXPVMD(KFL)=0D0
38498 VXPANL(KFL)=0D0
38499 VXPANH(KFL)=0D0
38500 VXPDGM(KFL)=0D0
38501 100 CONTINUE
38502
38503C...Set Q0 cut-off parameter as function of set used.
38504 IF(ISET.LE.2) THEN
38505 Q0=0.6D0
38506 ELSE
38507 Q0=2D0
38508 ENDIF
38509 Q02=Q0**2
38510
38511C...Scale choice for off-shell photon; common factors.
38512 Q2A=Q2
38513 FACNOR=1D0
38514 IF(IP2.EQ.1) THEN
38515 P2MX=P2+Q02
38516 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38517 FACNOR=LOG(Q2/Q02)/NSTEP
38518 ELSEIF(IP2.EQ.2) THEN
38519 P2MX=MAX(P2,Q02)
38520 ELSEIF(IP2.EQ.3) THEN
38521 P2MX=P2+Q02
38522 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38523 ELSEIF(IP2.EQ.4) THEN
38524 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38525 & ((Q2+P2)*(Q02+P2)))
38526 ELSEIF(IP2.EQ.5) THEN
38527 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38528 & ((Q2+P2)*(Q02+P2)))
38529 P2MX=Q0*SQRT(P2MXA)
38530 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
38531 ELSEIF(IP2.EQ.6) THEN
38532 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38533 & ((Q2+P2)*(Q02+P2)))
38534 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38535 ELSE
38536 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38537 & ((Q2+P2)*(Q02+P2)))
38538 P2MX=Q0*SQRT(P2MXA)
38539 P2MXB=P2MX
38540 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38541 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
38542 IF(ABS(Q2-Q02).GT.1D-6) THEN
38543 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
38544 ELSEIF(P2.LT.Q02) THEN
38545 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
38546 ELSE
38547 FACNOR=1D0
38548 ENDIF
38549 ENDIF
38550
38551C...Call VMD parametrization for d quark and use to give rho, omega,
38552C...phi. Note dipole dampening for off-shell photon.
38553 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38554 XFVAL=VXPGA(1)
38555 XPGA(1)=XPGA(2)
38556 XPGA(-1)=XPGA(-2)
38557 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
38558 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
38559 DO 110 KFL=-5,5
38560 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
38561 110 CONTINUE
38562 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
38563 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
38564 XPVMD(3)=XPVMD(3)+FACS*XFVAL
38565 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
38566 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
38567 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
38568 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
38569 VXPVMD(2)=FRACU*FACUD*XFVAL
38570 VXPVMD(3)=FACS*XFVAL
38571 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
38572 VXPVMD(-2)=FRACU*FACUD*XFVAL
38573 VXPVMD(-3)=FACS*XFVAL
38574
38575 IF(IP2.NE.1) THEN
38576C...Anomalous parametrizations for different strategies
38577C...for off-shell photons; except full integration.
38578
38579C...Call anomalous parametrization for d + u + s.
38580 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38581 DO 120 KFL=-5,5
38582 XPANL(KFL)=FACNOR*XPGA(KFL)
38583 VXPANL(KFL)=FACNOR*VXPGA(KFL)
38584 120 CONTINUE
38585
38586C...Call anomalous parametrization for c and b.
38587 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38588 DO 130 KFL=-5,5
38589 XPANH(KFL)=FACNOR*XPGA(KFL)
38590 VXPANH(KFL)=FACNOR*VXPGA(KFL)
38591 130 CONTINUE
38592 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38593 DO 140 KFL=-5,5
38594 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
38595 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
38596 140 CONTINUE
38597
38598 ELSE
38599C...Special option: loop over flavours and integrate over k2.
38600 DO 170 KF=1,5
38601 DO 160 ISTEP=1,NSTEP
38602 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
38603 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
38604 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
38605 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
38606 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
38607 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
38608 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
38609 DO 150 KFL=-5,5
38610 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
38611 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
38612 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
38613 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
38614 150 CONTINUE
38615 160 CONTINUE
38616 170 CONTINUE
38617 ENDIF
38618
38619C...Call Bethe-Heitler term expression for charm and bottom.
38620 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
38621 XPBEH(4)=XPBH
38622 XPBEH(-4)=XPBH
38623 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
38624 XPBEH(5)=XPBH
38625 XPBEH(-5)=XPBH
38626
38627C...For MSbar subtraction call C^gamma term expression for d, u, s.
38628 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
38629 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
38630 DO 180 KFL=-5,5
38631 XPDIR(KFL)=XPGA(KFL)
38632 180 CONTINUE
38633 ENDIF
38634
38635C...Store result in output array.
38636 DO 190 KFL=-5,5
38637 CHSQ=1D0/9D0
38638 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
38639 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38640 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
38641 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
38642 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
38643 190 CONTINUE
38644
38645 RETURN
38646 END
38647
38648C*********************************************************************
38649
38650C...PYGVMD
38651C...Evaluates the VMD parton distributions of a photon,
38652C...evolved homogeneously from an initial scale P2 to Q2.
38653C...Does not include dipole suppression factor.
38654C...ISET is parton distribution set, see above;
38655C...additionally ISET=0 is used for the evolution of an anomalous photon
38656C...which branched at a scale P2 and then evolved homogeneously to Q2.
38657C...ALAM is the 4-flavour Lambda, which is automatically converted
38658C...to 3- and 5-flavour equivalents as needed.
38659C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38660
38661 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38662
38663C...Double precision and integer declarations.
38664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38665 IMPLICIT INTEGER(I-N)
38666 INTEGER PYK,PYCHGE,PYCOMP
38667C...Local arrays and data.
38668 DIMENSION XPGA(-6:6), VXPGA(-6:6)
38669 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38670
38671C...Reset output.
38672 DO 100 KFL=-6,6
38673 XPGA(KFL)=0D0
38674 VXPGA(KFL)=0D0
38675 100 CONTINUE
38676 KFA=IABS(KF)
38677
38678C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38679 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
38680 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
38681 P2EFF=MAX(P2,1.2D0*ALAM3**2)
38682 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38683 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38684 Q2EFF=MAX(Q2,P2EFF)
38685
38686C...Find number of flavours at lower and upper scale.
38687 NFP=4
38688 IF(P2EFF.LT.PMC**2) NFP=3
38689 IF(P2EFF.GT.PMB**2) NFP=5
38690 NFQ=4
38691 IF(Q2EFF.LT.PMC**2) NFQ=3
38692 IF(Q2EFF.GT.PMB**2) NFQ=5
38693
38694C...Find s as sum of 3-, 4- and 5-flavour parts.
38695 S=0D0
38696 IF(NFP.EQ.3) THEN
38697 Q2DIV=PMC**2
38698 IF(NFQ.EQ.3) Q2DIV=Q2EFF
38699 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
38700 ENDIF
38701 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
38702 P2DIV=P2EFF
38703 IF(NFP.EQ.3) P2DIV=PMC**2
38704 Q2DIV=Q2EFF
38705 IF(NFQ.EQ.5) Q2DIV=PMB**2
38706 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
38707 ENDIF
38708 IF(NFQ.EQ.5) THEN
38709 P2DIV=PMB**2
38710 IF(NFP.EQ.5) P2DIV=P2EFF
38711 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
38712 ENDIF
38713
38714C...Calculate frequent combinations of x and s.
38715 X1=1D0-X
38716 XL=-LOG(X)
38717 S2=S**2
38718 S3=S**3
38719 S4=S**4
38720
38721C...Evaluate homogeneous anomalous parton distributions below or
38722C...above threshold.
38723 IF(ISET.EQ.0) THEN
38724 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38725 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38726 XVAL = X * 1.5D0 * (X**2+X1**2)
38727 XGLU = 0D0
38728 XSEA = 0D0
38729 ELSE
38730 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
38731 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
38732 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
38733 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
38734 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
38735 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
38736 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
38737 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
38738 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
38739 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
38740 & (2D0*X-1D0)*X*XL**2)
38741 ENDIF
38742
38743C...Evaluate set 1D parton distributions below or above threshold.
38744 ELSEIF(ISET.EQ.1) THEN
38745 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38746 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38747 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
38748 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
38749 XSEA = 0.100D0 * X1**3.76D0
38750 ELSE
38751 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
38752 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
38753 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
38754 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
38755 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
38756 & X**0.40D0 * X1**(1.76D0+3D0*S)
38757 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
38758 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
38759 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
38760 XSEA0 = 0.100D0 * X1**3.76D0
38761 ENDIF
38762
38763C...Evaluate set 1M parton distributions below or above threshold.
38764 ELSEIF(ISET.EQ.2) THEN
38765 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38766 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38767 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
38768 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
38769 XSEA = 0D0
38770 ELSE
38771 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
38772 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
38773 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
38774 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
38775 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
38776 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
38777 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
38778 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
38779 & XL**(2.8D0*S)
38780 XSEA0 = 0D0
38781 ENDIF
38782
38783C...Evaluate set 2D parton distributions below or above threshold.
38784 ELSEIF(ISET.EQ.3) THEN
38785 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38786 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38787 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
38788 XGLU = 1.925D0 * X1**2
38789 XSEA = 0.242D0 * X1**4
38790 ELSE
38791 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
38792 & X**(0.46D0+0.25D0*S) *
38793 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
38794 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
38795 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
38796 & EXP(-18.67D0*S) *
38797 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
38798 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
38799 & XL**(9.3D0*S/(1D0+1.7D0*S))
38800 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
38801 & (1D0-0.607D0*S+21.95D0*S2) *
38802 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
38803 XSEA0 = 0.242D0 * X1**4
38804 ENDIF
38805
38806C...Evaluate set 2M parton distributions below or above threshold.
38807 ELSEIF(ISET.EQ.4) THEN
38808 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38809 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38810 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
38811 XGLU = 1.808D0 * X1**2
38812 XSEA = 0.209D0 * X1**4
38813 ELSE
38814 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
38815 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
38816 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
38817 & XL**(5.15D0*S/(1D0+2D0*S)) +
38818 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
38819 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
38820 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
38821 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
38822 & XL**(10.9D0*S/(1D0+2.5D0*S))
38823 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
38824 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
38825 & X1**(4D0+S) * XL**(0.45D0*S)
38826 XSEA0 = 0.209D0 * X1**4
38827 ENDIF
38828 ENDIF
38829
38830C...Threshold factors for c and b sea.
38831 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38832 XCHM=0D0
38833 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38834 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38835 IF(ISET.EQ.0) THEN
38836 XCHM=XSEA*(1D0-(SCH/SLL)**2)
38837 ELSE
38838 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
38839 ENDIF
38840 ENDIF
38841 XBOT=0D0
38842 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38843 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38844 IF(ISET.EQ.0) THEN
38845 XBOT=XSEA*(1D0-(SBT/SLL)**2)
38846 ELSE
38847 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
38848 ENDIF
38849 ENDIF
38850
38851C...Fill parton distributions.
38852 XPGA(0)=XGLU
38853 XPGA(1)=XSEA
38854 XPGA(2)=XSEA
38855 XPGA(3)=XSEA
38856 XPGA(4)=XCHM
38857 XPGA(5)=XBOT
38858 XPGA(KFA)=XPGA(KFA)+XVAL
38859 DO 110 KFL=1,5
38860 XPGA(-KFL)=XPGA(KFL)
38861 110 CONTINUE
38862 VXPGA(KFA)=XVAL
38863 VXPGA(-KFA)=XVAL
38864
38865 RETURN
38866 END
38867
38868C*********************************************************************
38869
38870C...PYGANO
38871C...Evaluates the parton distributions of the anomalous photon,
38872C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
38873C...KF=0 gives the sum over (up to) 5 flavours,
38874C...KF<0 limits to flavours up to abs(KF),
38875C...KF>0 is for flavour KF only.
38876C...ALAM is the 4-flavour Lambda, which is automatically converted
38877C...to 3- and 5-flavour equivalents as needed.
38878C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38879
38880 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38881
38882C...Double precision and integer declarations.
38883 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38884 IMPLICIT INTEGER(I-N)
38885 INTEGER PYK,PYCHGE,PYCOMP
38886C...Local arrays and data.
38887 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
38888 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38889
38890C...Reset output.
38891 DO 100 KFL=-6,6
38892 XPGA(KFL)=0D0
38893 VXPGA(KFL)=0D0
38894 100 CONTINUE
38895 IF(Q2.LE.P2) RETURN
38896 KFA=IABS(KF)
38897
38898C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38899 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
38900 ALAMSQ(4)=ALAM**2
38901 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
38902 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
38903 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38904 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38905 Q2EFF=MAX(Q2,P2EFF)
38906 XL=-LOG(X)
38907
38908C...Find number of flavours at lower and upper scale.
38909 NFP=4
38910 IF(P2EFF.LT.PMC**2) NFP=3
38911 IF(P2EFF.GT.PMB**2) NFP=5
38912 NFQ=4
38913 IF(Q2EFF.LT.PMC**2) NFQ=3
38914 IF(Q2EFF.GT.PMB**2) NFQ=5
38915
38916C...Define range of flavour loop.
38917 IF(KF.EQ.0) THEN
38918 KFLMN=1
38919 KFLMX=5
38920 ELSEIF(KF.LT.0) THEN
38921 KFLMN=1
38922 KFLMX=KFA
38923 ELSE
38924 KFLMN=KFA
38925 KFLMX=KFA
38926 ENDIF
38927
38928C...Loop over flavours the photon can branch into.
38929 DO 110 KFL=KFLMN,KFLMX
38930
38931C...Light flavours: calculate t range and (approximate) s range.
38932 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38933 TDIFF=LOG(Q2EFF/P2EFF)
38934 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38935 & LOG(P2EFF/ALAMSQ(NFQ)))
38936 IF(NFQ.GT.NFP) THEN
38937 Q2DIV=PMB**2
38938 IF(NFQ.EQ.4) Q2DIV=PMC**2
38939 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38940 & LOG(P2EFF/ALAMSQ(NFQ)))
38941 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38942 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38943 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38944 ENDIF
38945 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38946 Q2DIV=PMC**2
38947 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38948 & LOG(P2EFF/ALAMSQ(4)))
38949 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38950 & LOG(P2EFF/ALAMSQ(3)))
38951 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38952 ENDIF
38953
38954C...u and s quark do not need a separate treatment when d has been done.
38955 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38956
38957C...Charm: as above, but only include range above c threshold.
38958 ELSEIF(KFL.EQ.4) THEN
38959 IF(Q2.LE.PMC**2) GOTO 110
38960 P2EFF=MAX(P2EFF,PMC**2)
38961 Q2EFF=MAX(Q2EFF,P2EFF)
38962 TDIFF=LOG(Q2EFF/P2EFF)
38963 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38964 & LOG(P2EFF/ALAMSQ(NFQ)))
38965 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38966 Q2DIV=PMB**2
38967 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38968 & LOG(P2EFF/ALAMSQ(NFQ)))
38969 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38970 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38971 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38972 ENDIF
38973
38974C...Bottom: as above, but only include range above b threshold.
38975 ELSEIF(KFL.EQ.5) THEN
38976 IF(Q2.LE.PMB**2) GOTO 110
38977 P2EFF=MAX(P2EFF,PMB**2)
38978 Q2EFF=MAX(Q2,P2EFF)
38979 TDIFF=LOG(Q2EFF/P2EFF)
38980 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38981 & LOG(P2EFF/ALAMSQ(NFQ)))
38982 ENDIF
38983
38984C...Evaluate flavour-dependent prefactor (charge^2 etc.).
38985 CHSQ=1D0/9D0
38986 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
38987 FAC=AEM2PI*2D0*CHSQ*TDIFF
38988
38989C...Evaluate parton distributions (normalized to unit momentum sum).
38990 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
38991 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
38992 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
38993 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
38994 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
38995 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
38996 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
38997 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
38998 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
38999 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39000 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39001 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39002
39003C...Threshold factors for c and b sea.
39004 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39005 XCHM=0D0
39006 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39007 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39008 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39009 ENDIF
39010 XBOT=0D0
39011 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39012 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39013 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39014 ENDIF
39015 ENDIF
39016
39017C...Add contribution of each valence flavour.
39018 XPGA(0)=XPGA(0)+FAC*XGLU
39019 XPGA(1)=XPGA(1)+FAC*XSEA
39020 XPGA(2)=XPGA(2)+FAC*XSEA
39021 XPGA(3)=XPGA(3)+FAC*XSEA
39022 XPGA(4)=XPGA(4)+FAC*XCHM
39023 XPGA(5)=XPGA(5)+FAC*XBOT
39024 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39025 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39026 110 CONTINUE
39027 DO 120 KFL=1,5
39028 XPGA(-KFL)=XPGA(KFL)
39029 VXPGA(-KFL)=VXPGA(KFL)
39030 120 CONTINUE
39031
39032 RETURN
39033 END
39034
39035
39036C*********************************************************************
39037
39038C...PYGBEH
39039C...Evaluates the Bethe-Heitler cross section for heavy flavour
39040C...production.
39041C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39042
39043 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39044
39045C...Double precision and integer declarations.
39046 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39047 IMPLICIT INTEGER(I-N)
39048 INTEGER PYK,PYCHGE,PYCOMP
39049
39050C...Local data.
39051 DATA AEM2PI/0.0011614D0/
39052
39053C...Reset output.
39054 XPBH=0D0
39055 SIGBH=0D0
39056
39057C...Check kinematics limits.
39058 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39059 W2=Q2*(1D0-X)/X-P2
39060 BETA2=1D0-4D0*PM2/W2
39061 IF(BETA2.LT.1D-10) RETURN
39062 BETA=SQRT(BETA2)
39063 RMQ=4D0*PM2/Q2
39064
39065C...Simple case: P2 = 0.
39066 IF(P2.LT.1D-4) THEN
39067 IF(BETA.LT.0.99D0) THEN
39068 XBL=LOG((1D0+BETA)/(1D0-BETA))
39069 ELSE
39070 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39071 ENDIF
39072 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39073 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39074
39075C...Complicated case: P2 > 0, based on approximation of
39076C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39077 ELSE
39078 RPQ=1D0-4D0*X**2*P2/Q2
39079 IF(RPQ.GT.1D-10) THEN
39080 RPBE=SQRT(RPQ*BETA2)
39081 IF(RPBE.LT.0.99D0) THEN
39082 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
39083 XBI=2D0*RPBE/(1D0-RPBE**2)
39084 ELSE
39085 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
39086 XBL=LOG((1D0+RPBE)**2/RPBESN)
39087 XBI=2D0*RPBE/RPBESN
39088 ENDIF
39089 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
39090 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
39091 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
39092 ENDIF
39093 ENDIF
39094
39095C...Multiply by charge-squared etc. to get parton distribution.
39096 CHSQ=1D0/9D0
39097 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
39098 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
39099
39100 RETURN
39101 END
39102
39103C*********************************************************************
39104
39105C...PYGDIR
39106C...Evaluates the direct contribution, i.e. the C^gamma term,
39107C...as needed in MSbar parametrizations.
39108C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39109
39110 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
39111
39112C...Double precision and integer declarations.
39113 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39114 IMPLICIT INTEGER(I-N)
39115 INTEGER PYK,PYCHGE,PYCOMP
39116C...Local array and data.
39117 DIMENSION XPGA(-6:6)
39118 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
39119
39120C...Reset output.
39121 DO 100 KFL=-6,6
39122 XPGA(KFL)=0D0
39123 100 CONTINUE
39124
39125C...Evaluate common x-dependent expression.
39126 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
39127 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
39128
39129C...d, u, s part by simple charge factor.
39130 XPGA(1)=(1D0/9D0)*CGAM
39131 XPGA(2)=(4D0/9D0)*CGAM
39132 XPGA(3)=(1D0/9D0)*CGAM
39133
39134C...Also fill for antiquarks.
39135 DO 110 KF=1,5
39136 XPGA(-KF)=XPGA(KF)
39137 110 CONTINUE
39138
39139 RETURN
39140 END
39141
39142C*********************************************************************
39143
39144C...PYPDPI
39145C...Gives pi+ parton distribution according to two different
39146C...parametrizations.
39147
39148 SUBROUTINE PYPDPI(X,Q2,XPPI)
39149
39150C...Double precision and integer declarations.
39151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39152 IMPLICIT INTEGER(I-N)
39153 INTEGER PYK,PYCHGE,PYCOMP
39154C...Commonblocks.
39155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39156 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39157 COMMON/PYINT1/MINT(400),VINT(400)
39158 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39159C...Local arrays.
39160 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
39161
39162C...The following data lines are coefficients needed in the
39163C...Owens pion parton distribution parametrizations, see below.
39164C...Expansion coefficients for up and down valence quark distributions.
39165 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
39166 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39167 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39168 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39169 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
39170 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39171 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39172 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39173C...Expansion coefficients for gluon distribution.
39174 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
39175 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
39176 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
39177 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
39178 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
39179 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
39180 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
39181 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
39182C...Expansion coefficients for (up+down+strange) quark sea distribution.
39183 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
39184 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39185 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
39186 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
39187 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
39188 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39189 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
39190 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
39191C...Expansion coefficients for charm quark sea distribution.
39192 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
39193 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
39194 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
39195 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
39196 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
39197 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
39198 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
39199 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
39200
39201C...Euler's beta function, requires ordinary Gamma function
39202 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
39203
39204C...Reset output array.
39205 DO 100 KFL=-6,6
39206 XPPI(KFL)=0D0
39207 100 CONTINUE
39208
39209 IF(MSTP(53).LE.2) THEN
39210C...Pion parton distributions from Owens.
39211C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
39212
39213C...Determine set, Lambda and s expansion variable.
39214 NSET=MSTP(53)
39215 IF(NSET.EQ.1) ALAM=0.2D0
39216 IF(NSET.EQ.2) ALAM=0.4D0
39217 VINT(231)=4D0
39218 IF(MSTP(57).LE.0) THEN
39219 SD=0D0
39220 ELSE
39221 Q2IN=MIN(2D3,MAX(4D0,Q2))
39222 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
39223 ENDIF
39224
39225C...Calculate parton distributions.
39226 DO 120 KFL=1,4
39227 DO 110 IS=1,5
39228 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
39229 & COW(3,IS,KFL,NSET)*SD**2
39230 110 CONTINUE
39231 IF(KFL.EQ.1) THEN
39232 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
39233 ELSE
39234 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
39235 & TS(5)*X**2)
39236 ENDIF
39237 120 CONTINUE
39238
39239C...Put into output array.
39240 XPPI(0)=XQ(2)
39241 XPPI(1)=XQ(3)/6D0
39242 XPPI(2)=XQ(1)+XQ(3)/6D0
39243 XPPI(3)=XQ(3)/6D0
39244 XPPI(4)=XQ(4)
39245 XPPI(-1)=XQ(1)+XQ(3)/6D0
39246 XPPI(-2)=XQ(3)/6D0
39247 XPPI(-3)=XQ(3)/6D0
39248 XPPI(-4)=XQ(4)
39249
39250C...Leading order pion parton distributions from Glueck, Reya and Vogt.
39251C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
39252C...10^-5 < x < 1.
39253 ELSE
39254
39255C...Determine s expansion variable and some x expressions.
39256 VINT(231)=0.25D0
39257 IF(MSTP(57).LE.0) THEN
39258 SD=0D0
39259 ELSE
39260 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
39261 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
39262 ENDIF
39263 SD2=SD**2
39264 XL=-LOG(X)
39265 XS=SQRT(X)
39266
39267C...Evaluate valence, gluon and sea distributions.
39268 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
39269 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
39270 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
39271 & SD-0.175D0*SD2)+
39272 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
39273 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
39274 & XL)))*
39275 & (1D0-X)**(0.390D0+1.053D0*SD)
39276 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
39277 & X)**3.359D0*
39278 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
39279 & XL))/
39280 & XL**(2.538D0-0.763D0*SD)
39281 IF(SD.LE.0.888D0) THEN
39282 XFCHM=0D0
39283 ELSE
39284 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
39285 & 0.771D0*SD)*
39286 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
39287 & XL))
39288 ENDIF
39289 IF(SD.LE.1.351D0) THEN
39290 XFBOT=0D0
39291 ELSE
39292 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
39293 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
39294 & XL))
39295 ENDIF
39296
39297C...Put into output array.
39298 XPPI(0)=XFGLU
39299 XPPI(1)=XFSEA
39300 XPPI(2)=XFSEA
39301 XPPI(3)=XFSEA
39302 XPPI(4)=XFCHM
39303 XPPI(5)=XFBOT
39304 DO 130 KFL=1,5
39305 XPPI(-KFL)=XPPI(KFL)
39306 130 CONTINUE
39307 XPPI(2)=XPPI(2)+XFVAL
39308 XPPI(-1)=XPPI(-1)+XFVAL
39309 ENDIF
39310
39311 RETURN
39312 END
39313
39314C*********************************************************************
39315
39316C...PYPDPR
39317C...Gives proton parton distributions according to a few different
39318C...parametrizations.
39319
39320 SUBROUTINE PYPDPR(X,Q2,XPPR)
39321
39322C...Double precision and integer declarations.
39323 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39324 IMPLICIT INTEGER(I-N)
39325 INTEGER PYK,PYCHGE,PYCOMP
39326C...Commonblocks.
39327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39329 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39330 COMMON/PYINT1/MINT(400),VINT(400)
39331 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39332C...Arrays and data.
39333 DIMENSION XPPR(-6:6),Q2MIN(16)
39334 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
39335 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
39336
39337C...Reset output array.
39338 DO 100 KFL=-6,6
39339 XPPR(KFL)=0D0
39340 100 CONTINUE
39341
39342C...Common preliminaries.
39343 NSET=MAX(1,MIN(16,MSTP(51)))
39344 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
39345 VINT(231)=Q2MIN(NSET)
39346 IF(MSTP(57).EQ.0) THEN
39347 Q2L=Q2MIN(NSET)
39348 ELSE
39349 Q2L=MAX(Q2MIN(NSET),Q2)
39350 ENDIF
39351
39352 IF(NSET.GE.1.AND.NSET.LE.3) THEN
39353C...Interface to the CTEQ 3 parton distributions.
39354 QRT=SQRT(MAX(1D0,Q2L))
39355
39356C...Loop over flavours.
39357 DO 110 I=-6,6
39358 IF(I.LE.0) THEN
39359 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
39360 ELSEIF(I.LE.2) THEN
39361 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
39362 ELSE
39363 XPPR(I)=XPPR(-I)
39364 ENDIF
39365 110 CONTINUE
39366
39367 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
39368C...Interface to the GRV 94 distributions.
39369 IF(NSET.EQ.4) THEN
39370 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39371 ELSEIF(NSET.EQ.5) THEN
39372 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39373 ELSE
39374 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39375 ENDIF
39376
39377C...Put into output array.
39378 XPPR(0)=GL
39379 XPPR(-1)=0.5D0*(UDB+DEL)
39380 XPPR(-2)=0.5D0*(UDB-DEL)
39381 XPPR(-3)=SB
39382 XPPR(-4)=CHM
39383 XPPR(-5)=BOT
39384 XPPR(1)=DV+XPPR(-1)
39385 XPPR(2)=UV+XPPR(-2)
39386 XPPR(3)=SB
39387 XPPR(4)=CHM
39388 XPPR(5)=BOT
39389
39390 ELSEIF(NSET.EQ.7) THEN
39391C...Interface to the CTEQ 5L parton distributions.
39392C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
39393C...freezing x*f(x,Q2) at borders.
39394 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39395 XIN=MAX(1D-6,MIN(1D0,X))
39396
39397C...Loop over flavours (with u <-> d notation mismatch).
39398 SUMUDB=PYCT5L(-1,XIN,QRT)
39399 RATUDB=PYCT5L(-2,XIN,QRT)
39400 DO 120 I=-5,2
39401 IF(I.EQ.1) THEN
39402 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
39403 ELSEIF(I.EQ.2) THEN
39404 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
39405 ELSEIF(I.EQ.-1) THEN
39406 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39407 ELSEIF(I.EQ.-2) THEN
39408 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39409 ELSE
39410 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
39411 IF(I.LT.0) XPPR(-I)=XPPR(I)
39412 ENDIF
39413 120 CONTINUE
39414
39415 ELSEIF(NSET.EQ.8) THEN
39416C...Interface to the CTEQ 5M1 parton distributions.
39417 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39418 XIN=MAX(1D-6,MIN(1D0,X))
39419
39420C...Loop over flavours (with u <-> d notation mismatch).
39421 SUMUDB=PYCT5M(-1,XIN,QRT)
39422 RATUDB=PYCT5M(-2,XIN,QRT)
39423 DO 130 I=-5,2
39424 IF(I.EQ.1) THEN
39425 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
39426 ELSEIF(I.EQ.2) THEN
39427 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
39428 ELSEIF(I.EQ.-1) THEN
39429 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39430 ELSEIF(I.EQ.-2) THEN
39431 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39432 ELSE
39433 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
39434 IF(I.LT.0) XPPR(-I)=XPPR(I)
39435 ENDIF
39436 130 CONTINUE
39437
39438 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
39439C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
39440C...obsolete but offers backwards compatibility.
39441 CALL PYPDPO(X,Q2L,XPPR)
39442
39443C...Symmetric choice for debugging only
39444 ELSEIF(NSET.EQ.16) THEN
39445 XPPR(0)=.5D0/X
39446 XPPR(1)=.05D0/X
39447 XPPR(2)=.05D0/X
39448 XPPR(3)=.05D0/X
39449 XPPR(4)=.05D0/X
39450 XPPR(5)=.05D0/X
39451 XPPR(-1)=.05D0/X
39452 XPPR(-2)=.05D0/X
39453 XPPR(-3)=.05D0/X
39454 XPPR(-4)=.05D0/X
39455 XPPR(-5)=.05D0/X
39456
39457 ENDIF
39458
39459 RETURN
39460 END
39461
39462C*********************************************************************
39463
39464C...PYCTEQ
39465C...Gives the CTEQ 3 parton distribution function sets in
39466C...parametrized form, of October 24, 1994.
39467C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
39468C...J. Qiu, W.K. Tung and H. Weerts.
39469
39470 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
39471
39472C...Double precision declaration.
39473 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39474 IMPLICIT INTEGER(I-N)
39475
39476C...Data on Lambda values of fits, minimum Q and quark masses.
39477 DIMENSION ALM(3), QMS(4:6)
39478 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
39479 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
39480
39481C....Check flavour thresholds. Set up QI for SB.
39482 IP = IABS(IPRT)
39483 IF(IP .GE. 4) THEN
39484 IF(Q .LE. QMS(IP)) THEN
39485 PYCTEQ = 0D0
39486 RETURN
39487 ENDIF
39488 QI = QMS(IP)
39489 ELSE
39490 QI = QMN
39491 ENDIF
39492
39493C...Use "standard lambda" of parametrization program for expansion.
39494 ALAM = ALM (ISET)
39495 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
39496 SB = LOG (SBL)
39497 SB2 = SB*SB
39498 SB3 = SB2*SB
39499
39500C...Expansion for CTEQ3L.
39501 IF(ISET .EQ. 1) THEN
39502 IF(IPRT .EQ. 2) THEN
39503 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
39504 & 0.3171D+00*SB3)
39505 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
39506 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
39507 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
39508 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
39509 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
39510 ELSEIF(IPRT .EQ. 1) THEN
39511 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
39512 & 0.7728D+00*SB3)
39513 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
39514 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
39515 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
39516 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
39517 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
39518 ELSEIF(IPRT .EQ. 0) THEN
39519 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
39520 & 0.5343D+00*SB3)
39521 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
39522 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
39523 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
39524 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
39525 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
39526 ELSEIF(IPRT .EQ. -1) THEN
39527 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
39528 & 0.2031D+01*SB3)
39529 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
39530 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
39531 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
39532 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
39533 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
39534 ELSEIF(IPRT .EQ. -2) THEN
39535 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
39536 & 0.9872D-01*SB3)
39537 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
39538 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
39539 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
39540 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
39541 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
39542 ELSEIF(IPRT .EQ. -3) THEN
39543 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
39544 & 0.8390D+00*SB3)
39545 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
39546 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
39547 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
39548 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
39549 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
39550 ELSEIF(IPRT .EQ. -4) THEN
39551 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
39552 & 0.1651D-01*SB2)
39553 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
39554 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
39555 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
39556 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
39557 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
39558 ELSEIF(IPRT .EQ. -5) THEN
39559 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
39560 & 0.3702D+01*SB2)
39561 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
39562 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
39563 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
39564 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
39565 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
39566 ELSEIF(IPRT .EQ. -6) THEN
39567 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
39568 & 0.6943D+00*SB2)
39569 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
39570 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
39571 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
39572 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
39573 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
39574 ENDIF
39575
39576C...Expansion for CTEQ3M.
39577 ELSEIF(ISET .EQ. 2) THEN
39578 IF(IPRT .EQ. 2) THEN
39579 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
39580 & 0.2935D+00*SB3)
39581 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
39582 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
39583 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
39584 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
39585 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
39586 ELSEIF(IPRT .EQ. 1) THEN
39587 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
39588 & 0.4305D-01*SB3)
39589 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
39590 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
39591 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
39592 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
39593 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
39594 ELSEIF(IPRT .EQ. 0) THEN
39595 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
39596 & 0.1037D-01*SB3)
39597 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
39598 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
39599 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
39600 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
39601 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
39602 ELSEIF(IPRT .EQ. -1) THEN
39603 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
39604 & 0.1602D+01*SB3)
39605 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
39606 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
39607 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
39608 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
39609 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
39610 ELSEIF(IPRT .EQ. -2) THEN
39611 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
39612 & 0.2496D+00*SB3)
39613 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
39614 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
39615 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
39616 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
39617 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
39618 ELSEIF(IPRT .EQ. -3) THEN
39619 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
39620 & 0.1936D+01*SB3)
39621 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
39622 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
39623 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
39624 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
39625 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
39626 ELSEIF(IPRT .EQ. -4) THEN
39627 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
39628 & 0.5348D+00*SB2)
39629 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
39630 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
39631 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
39632 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
39633 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
39634 ELSEIF(IPRT .EQ. -5) THEN
39635 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
39636 & 0.1569D+01*SB2)
39637 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
39638 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
39639 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
39640 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
39641 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
39642 ELSEIF(IPRT .EQ. -6) THEN
39643 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
39644 & 0.8838D+01*SB2)
39645 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
39646 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
39647 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
39648 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
39649 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
39650 ENDIF
39651
39652C...Expansion for CTEQ3D.
39653 ELSEIF(ISET .EQ. 3) THEN
39654 IF(IPRT .EQ. 2) THEN
39655 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
39656 & 0.2902D+00*SB3)
39657 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
39658 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
39659 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
39660 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
39661 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
39662 ELSEIF(IPRT .EQ. 1) THEN
39663 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
39664 & 0.7257D+00*SB3)
39665 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
39666 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
39667 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
39668 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
39669 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
39670 ELSEIF(IPRT .EQ. 0) THEN
39671 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
39672 & 0.2734D-04*SB3)
39673 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
39674 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
39675 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
39676 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
39677 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
39678 ELSEIF(IPRT .EQ. -1) THEN
39679 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
39680 & 0.1671D+01*SB3)
39681 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
39682 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
39683 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
39684 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
39685 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
39686 ELSEIF(IPRT .EQ. -2) THEN
39687 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
39688 & 0.2223D+00*SB3)
39689 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
39690 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
39691 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
39692 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
39693 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
39694 ELSEIF(IPRT .EQ. -3) THEN
39695 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
39696 & 0.1937D+01*SB3)
39697 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
39698 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
39699 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
39700 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
39701 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
39702 ELSEIF(IPRT .EQ. -4) THEN
39703 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
39704 & 0.5137D+00*SB2)
39705 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
39706 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
39707 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
39708 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
39709 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
39710 ELSEIF(IPRT .EQ. -5) THEN
39711 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
39712 & 0.2143D+01*SB2)
39713 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
39714 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
39715 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
39716 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
39717 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
39718 ELSEIF(IPRT .EQ. -6) THEN
39719 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
39720 & 0.9998D+01*SB2)
39721 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
39722 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
39723 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
39724 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
39725 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
39726 ENDIF
39727 ENDIF
39728
39729C...Calculation of x * f(x, Q).
39730 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
39731 & *(LOG(1D0+1D0/X))**A5 )
39732
39733 RETURN
39734 END
39735
39736C*********************************************************************
39737
39738C...PYGRVL
39739C...Gives the GRV 94 L (leading order) parton distribution function set
39740C...in parametrized form.
39741C...Authors: M. Glueck, E. Reya and A. Vogt.
39742
39743 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39744
39745C...Double precision declaration.
39746 IMPLICIT DOUBLE PRECISION (A - Z)
39747
39748C...Common expressions.
39749 MU2 = 0.23D0
39750 LAM2 = 0.2322D0 * 0.2322D0
39751 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39752 DS = SQRT (S)
39753 S2 = S * S
39754 S3 = S2 * S
39755
39756C...uv :
39757 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
39758 AKU = 0.590D0 - 0.024D0 * S
39759 BKU = 0.131D0 + 0.063D0 * S
39760 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
39761 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
39762 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
39763 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
39764 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39765
39766C...dv :
39767 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
39768 AKD = 0.376D0
39769 BKD = 0.486D0 + 0.062D0 * S
39770 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
39771 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
39772 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
39773 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
39774 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39775
39776C...del :
39777 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
39778 AKE = 0.409D0 - 0.005D0 * S
39779 BKE = 0.799D0 + 0.071D0 * S
39780 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
39781 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
39782 CE = 0.0D0
39783 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
39784 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39785
39786C...udb :
39787 ALX = 1.451D0
39788 BEX = 0.271D0
39789 AKX = 0.410D0 - 0.232D0 * S
39790 BKX = 0.534D0 - 0.457D0 * S
39791 AGX = 0.890D0 - 0.140D0 * S
39792 BGX = -0.981D0
39793 CX = 0.320D0 + 0.683D0 * S
39794 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
39795 EX = 4.119D0 + 1.713D0 * S
39796 ESX = 0.682D0 + 2.978D0 * S
39797 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39798 & DX, EX, ESX)
39799
39800C...sb :
39801 STS = 0D0
39802 ALS = 0.914D0
39803 BES = 0.577D0
39804 AKS = 1.798D0 - 0.596D0 * S
39805 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
39806 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
39807 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
39808 EST = 3.981D0 + 1.638D0 * S
39809 ESS = 6.402D0
39810 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39811
39812C...cb :
39813 STC = 0.888D0
39814 ALC = 1.01D0
39815 BEC = 0.37D0
39816 AKC = 0D0
39817 AC = 0D0
39818 BC = 4.24D0 - 0.804D0 * S
39819 DCT = 3.46D0 - 1.076D0 * S
39820 ECT = 4.61D0 + 1.49D0 * S
39821 ESC = 2.555D0 + 1.961D0 * S
39822 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39823
39824C...bb :
39825 STB = 1.351D0
39826 ALB = 1.00D0
39827 BEB = 0.51D0
39828 AKB = 0D0
39829 AB = 0D0
39830 BB = 1.848D0
39831 DBT = 2.929D0 + 1.396D0 * S
39832 EBT = 4.71D0 + 1.514D0 * S
39833 ESB = 4.02D0 + 1.239D0 * S
39834 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39835
39836C...gl :
39837 ALG = 0.524D0
39838 BEG = 1.088D0
39839 AKG = 1.742D0 - 0.930D0 * S
39840 BKG = - 0.399D0 * S2
39841 AG = 7.486D0 - 2.185D0 * S
39842 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
39843 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
39844 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
39845 EG = 0.807D0 + 2.005D0 * S
39846 ESG = 3.841D0 + 0.316D0 * S
39847 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
39848 & DG, EG, ESG)
39849
39850 RETURN
39851 END
39852
39853C*********************************************************************
39854
39855C...PYGRVM
39856C...Gives the GRV 94 M (MSbar) parton distribution function set
39857C...in parametrized form.
39858C...Authors: M. Glueck, E. Reya and A. Vogt.
39859
39860 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39861
39862C...Double precision declaration.
39863 IMPLICIT DOUBLE PRECISION (A - Z)
39864
39865C...Common expressions.
39866 MU2 = 0.34D0
39867 LAM2 = 0.248D0 * 0.248D0
39868 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39869 DS = SQRT (S)
39870 S2 = S * S
39871 S3 = S2 * S
39872
39873C...uv :
39874 NU = 1.304D0 + 0.863D0 * S
39875 AKU = 0.558D0 - 0.020D0 * S
39876 BKU = 0.183D0 * S
39877 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
39878 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
39879 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
39880 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
39881 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39882
39883C...dv :
39884 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
39885 AKD = 0.270D0 - 0.019D0 * S
39886 BKD = 0.260D0
39887 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
39888 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
39889 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
39890 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
39891 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39892
39893C...del :
39894 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
39895 AKE = 0.409D0 - 0.007D0 * S
39896 BKE = 0.782D0 + 0.082D0 * S
39897 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
39898 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
39899 CE = 0.0D0
39900 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
39901 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39902
39903C...udb :
39904 ALX = 0.877D0
39905 BEX = 0.561D0
39906 AKX = 0.275D0
39907 BKX = 0.0D0
39908 AGX = 0.997D0
39909 BGX = 3.210D0 - 1.866D0 * S
39910 CX = 7.300D0
39911 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39912 EX = 3.077D0 + 1.446D0 * S
39913 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39914 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39915 & DX, EX, ESX)
39916
39917C...sb :
39918 STS = 0D0
39919 ALS = 0.756D0
39920 BES = 0.216D0
39921 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39922 AS = -4.329D0 + 1.131D0 * S
39923 BS = 9.568D0 - 1.744D0 * S
39924 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39925 EST = 3.031D0 + 1.639D0 * S
39926 ESS = 5.837D0 + 0.815D0 * S
39927 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39928
39929C...cb :
39930 STC = 0.820D0
39931 ALC = 0.98D0
39932 BEC = 0D0
39933 AKC = -0.625D0 - 0.523D0 * S
39934 AC = 0D0
39935 BC = 1.896D0 + 1.616D0 * S
39936 DCT = 4.12D0 + 0.683D0 * S
39937 ECT = 4.36D0 + 1.328D0 * S
39938 ESC = 0.677D0 + 0.679D0 * S
39939 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39940
39941C...bb :
39942 STB = 1.297D0
39943 ALB = 0.99D0
39944 BEB = 0D0
39945 AKB = - 0.193D0 * S
39946 AB = 0D0
39947 BB = 0D0
39948 DBT = 3.447D0 + 0.927D0 * S
39949 EBT = 4.68D0 + 1.259D0 * S
39950 ESB = 1.892D0 + 2.199D0 * S
39951 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39952
39953C...gl :
39954 ALG = 1.014D0
39955 BEG = 1.738D0
39956 AKG = 1.724D0 + 0.157D0 * S
39957 BKG = 0.800D0 + 1.016D0 * S
39958 AG = 7.517D0 - 2.547D0 * S
39959 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39960 CG = 4.039D0 + 1.491D0 * S
39961 DG = 3.404D0 + 0.830D0 * S
39962 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39963 ESG = 3.256D0 - 0.436D0 * S
39964 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39965
39966 RETURN
39967 END
39968
39969C*********************************************************************
39970
39971C...PYGRVD
39972C...Gives the GRV 94 D (DIS) parton distribution function set
39973C...in parametrized form.
39974C...Authors: M. Glueck, E. Reya and A. Vogt.
39975
39976 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39977
39978C...Double precision declaration.
39979 IMPLICIT DOUBLE PRECISION (A - Z)
39980
39981C...Common expressions.
39982 MU2 = 0.34D0
39983 LAM2 = 0.248D0 * 0.248D0
39984 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39985 DS = SQRT (S)
39986 S2 = S * S
39987 S3 = S2 * S
39988
39989C...uv :
39990 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
39991 AKU = 0.563D0 - 0.025D0 * S
39992 BKU = 0.054D0 + 0.154D0 * S
39993 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
39994 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
39995 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
39996 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
39997 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39998
39999C...dv :
40000 ND = 0.156D0 - 0.017D0 * S
40001 AKD = 0.299D0 - 0.022D0 * S
40002 BKD = 0.259D0 - 0.015D0 * S
40003 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40004 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40005 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40006 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40007 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40008
40009C...del :
40010 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40011 AKE = 0.419D0 - 0.013D0 * S
40012 BKE = 1.064D0 - 0.038D0 * S
40013 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40014 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40015 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40016 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40017 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40018
40019C...udb :
40020 ALX = 1.215D0
40021 BEX = 0.466D0
40022 AKX = 0.326D0 + 0.150D0 * S
40023 BKX = 0.956D0 + 0.405D0 * S
40024 AGX = 0.272D0
40025 BGX = 3.794D0 - 2.359D0 * DS
40026 CX = 2.014D0
40027 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40028 EX = 3.049D0 + 1.597D0 * S
40029 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40030 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40031 & DX, EX, ESX)
40032
40033C...sb :
40034 STS = 0D0
40035 ALS = 0.175D0
40036 BES = 0.344D0
40037 AKS = 1.415D0 - 0.641D0 * DS
40038 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40039 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40040 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40041 EST = 4.546D0 + 0.372D0 * S2
40042 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40043 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40044
40045C...cb :
40046 STC = 0.820D0
40047 ALC = 0.98D0
40048 BEC = 0D0
40049 AKC = -0.625D0 - 0.523D0 * S
40050 AC = 0D0
40051 BC = 1.896D0 + 1.616D0 * S
40052 DCT = 4.12D0 + 0.683D0 * S
40053 ECT = 4.36D0 + 1.328D0 * S
40054 ESC = 0.677D0 + 0.679D0 * S
40055 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40056
40057C...bb :
40058 STB = 1.297D0
40059 ALB = 0.99D0
40060 BEB = 0D0
40061 AKB = - 0.193D0 * S
40062 AB = 0D0
40063 BB = 0D0
40064 DBT = 3.447D0 + 0.927D0 * S
40065 EBT = 4.68D0 + 1.259D0 * S
40066 ESB = 1.892D0 + 2.199D0 * S
40067 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40068
40069C...gl :
40070 ALG = 1.258D0
40071 BEG = 1.846D0
40072 AKG = 2.423D0
40073 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40074 AG = 25.09D0 - 7.935D0 * S
40075 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
40076 CG = 590.3D0 - 173.8D0 * S
40077 DG = 5.196D0 + 1.857D0 * S
40078 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
40079 ESG = 3.232D0 - 0.542D0 * S
40080 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40081
40082 RETURN
40083 END
40084
40085C*********************************************************************
40086
40087C...PYGRVV
40088C...Auxiliary for the GRV 94 parton distribution functions
40089C...for u and d valence and d-u sea.
40090C...Authors: M. Glueck, E. Reya and A. Vogt.
40091
40092 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
40093
40094C...Double precision declaration.
40095 IMPLICIT DOUBLE PRECISION (A - Z)
40096
40097C...Evaluation.
40098 DX = SQRT (X)
40099 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
40100 & (1D0- X)**D
40101
40102 RETURN
40103 END
40104
40105C*********************************************************************
40106
40107C...PYGRVW
40108C...Auxiliary for the GRV 94 parton distribution functions
40109C...for d+u sea and gluon.
40110C...Authors: M. Glueck, E. Reya and A. Vogt.
40111
40112 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40113
40114C...Double precision declaration.
40115 IMPLICIT DOUBLE PRECISION (A - Z)
40116
40117C...Evaluation.
40118 LX = LOG (1D0/X)
40119 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
40120 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
40121
40122 RETURN
40123 END
40124
40125C*********************************************************************
40126
40127C...PYGRVS
40128C...Auxiliary for the GRV 94 parton distribution functions
40129C...for s, c and b sea.
40130C...Authors: M. Glueck, E. Reya and A. Vogt.
40131
40132 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40133
40134C...Double precision declaration.
40135 IMPLICIT DOUBLE PRECISION (A - Z)
40136
40137C...Evaluation.
40138 IF(S.LE.STH) THEN
40139 PYGRVS = 0D0
40140 ELSE
40141 DX = SQRT (X)
40142 LX = LOG (1D0/X)
40143 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
40144 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
40145 ENDIF
40146
40147 RETURN
40148 END
40149
40150C*********************************************************************
40151
40152C...PYCT5L
40153C...Auxiliary function for parametrization of CTEQ5L.
40154C...Author: J. Pumplin 9/99.
40155
40156C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40157C...in Parametrized Form
40158C... September 15, 1999
40159C
40160C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40161C... CTEQ5 PPARTON DISTRIBUTIONS"
40162C...hep-ph/9903282
40163
40164C...The CTEQ5M1 set given here is an updated version of the original
40165C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40166C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40167C...almost all applications.
40168C...The improvement is in the QCD evolution which is now more
40169C...accurate, and which agrees completely with the benchmark work
40170C...of the HERA 96/97 Workshop.
40171C...The differences between the parametrized and the corresponding
40172C...table versions (on which it is based) are of similar order as
40173C...between the two version.
40174
40175C...!! Because accurate parametrizations over a wide range of (x,Q)
40176C...is hard to obtain, only the most widely used sets CTEQ5M and
40177C...CTEQ5L are available in parametrized form for now.
40178
40179C...These parametrizations were obtained by Jon Pumplin.
40180
40181C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
40182C -------------------------------------------------------------------
40183C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
40184C 3 CTEQ5L Leading Order 0.127 192 146
40185C -------------------------------------------------------------------
40186C...Note the Qcd-lambda values given for CTEQ5L is for the leading
40187C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
40188C...calibration.
40189
40190C...The two Iset value are adopted to agree with the standard table
40191C...versions.
40192
40193C...Range of validity:
40194C...The range of (x, Q) covered by this parametrization of the QCD
40195C...evolved parton distributions is 1E-6 < x < 1 ;
40196C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
40197C...data only in a subset of that region; and the assumed DGLAP
40198C...evolution is unlikely to be valid for all of it either.
40199
40200C...The range of (x, Q) used in the CTEQ5 round of global analysis is
40201C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
40202C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
40203C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
40204
40205 FUNCTION PYCT5L(IFL,X,Q)
40206
40207C...Double precision declaration.
40208 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40209 IMPLICIT INTEGER(I-N)
40210
40211 PARAMETER (NEX=8, NLF=2)
40212 DIMENSION AM(0:NEX,0:NLF,-5:2)
40213 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40214 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40215 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40216 DIMENSION AF(0:NEX)
40217
40218 DATA MEXVEC( 2) / 8 /
40219 DATA MLFVEC( 2) / 2 /
40220 DATA UT1VEC( 2) / 0.4971265E+01 /
40221 DATA UT2VEC( 2) / -0.1105128E+01 /
40222 DATA ALFVEC( 2) / 0.2987216E+00 /
40223 DATA QMAVEC( 2) / 0.0000000E+00 /
40224 DATA (AM( 0,K, 2),K=0, 2)
40225 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
40226 DATA (AM( 1,K, 2),K=0, 2)
40227 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
40228 DATA (AM( 2,K, 2),K=0, 2)
40229 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
40230 DATA (AM( 3,K, 2),K=0, 2)
40231 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
40232 DATA (AM( 4,K, 2),K=0, 2)
40233 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
40234 DATA (AM( 5,K, 2),K=0, 2)
40235 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
40236 DATA (AM( 6,K, 2),K=0, 2)
40237 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
40238 DATA (AM( 7,K, 2),K=0, 2)
40239 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
40240 DATA (AM( 8,K, 2),K=0, 2)
40241 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
40242
40243 DATA MEXVEC( 1) / 8 /
40244 DATA MLFVEC( 1) / 2 /
40245 DATA UT1VEC( 1) / 0.2612618E+01 /
40246 DATA UT2VEC( 1) / -0.1258304E+06 /
40247 DATA ALFVEC( 1) / 0.3407552E+00 /
40248 DATA QMAVEC( 1) / 0.0000000E+00 /
40249 DATA (AM( 0,K, 1),K=0, 2)
40250 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
40251 DATA (AM( 1,K, 1),K=0, 2)
40252 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
40253 DATA (AM( 2,K, 1),K=0, 2)
40254 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
40255 DATA (AM( 3,K, 1),K=0, 2)
40256 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
40257 DATA (AM( 4,K, 1),K=0, 2)
40258 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
40259 DATA (AM( 5,K, 1),K=0, 2)
40260 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
40261 DATA (AM( 6,K, 1),K=0, 2)
40262 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
40263 DATA (AM( 7,K, 1),K=0, 2)
40264 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
40265 DATA (AM( 8,K, 1),K=0, 2)
40266 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
40267
40268 DATA MEXVEC( 0) / 8 /
40269 DATA MLFVEC( 0) / 2 /
40270 DATA UT1VEC( 0) / -0.4656819E+00 /
40271 DATA UT2VEC( 0) / -0.2742390E+03 /
40272 DATA ALFVEC( 0) / 0.4491863E+00 /
40273 DATA QMAVEC( 0) / 0.0000000E+00 /
40274 DATA (AM( 0,K, 0),K=0, 2)
40275 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
40276 DATA (AM( 1,K, 0),K=0, 2)
40277 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
40278 DATA (AM( 2,K, 0),K=0, 2)
40279 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
40280 DATA (AM( 3,K, 0),K=0, 2)
40281 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
40282 DATA (AM( 4,K, 0),K=0, 2)
40283 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
40284 DATA (AM( 5,K, 0),K=0, 2)
40285 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
40286 DATA (AM( 6,K, 0),K=0, 2)
40287 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
40288 DATA (AM( 7,K, 0),K=0, 2)
40289 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
40290 DATA (AM( 8,K, 0),K=0, 2)
40291 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
40292
40293 DATA MEXVEC(-1) / 8 /
40294 DATA MLFVEC(-1) / 2 /
40295 DATA UT1VEC(-1) / 0.3862583E+01 /
40296 DATA UT2VEC(-1) / -0.1265969E+01 /
40297 DATA ALFVEC(-1) / 0.2457668E+00 /
40298 DATA QMAVEC(-1) / 0.0000000E+00 /
40299 DATA (AM( 0,K,-1),K=0, 2)
40300 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
40301 DATA (AM( 1,K,-1),K=0, 2)
40302 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
40303 DATA (AM( 2,K,-1),K=0, 2)
40304 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
40305 DATA (AM( 3,K,-1),K=0, 2)
40306 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
40307 DATA (AM( 4,K,-1),K=0, 2)
40308 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
40309 DATA (AM( 5,K,-1),K=0, 2)
40310 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
40311 DATA (AM( 6,K,-1),K=0, 2)
40312 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
40313 DATA (AM( 7,K,-1),K=0, 2)
40314 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
40315 DATA (AM( 8,K,-1),K=0, 2)
40316 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
40317
40318 DATA MEXVEC(-2) / 7 /
40319 DATA MLFVEC(-2) / 2 /
40320 DATA UT1VEC(-2) / 0.1895615E+00 /
40321 DATA UT2VEC(-2) / -0.3069097E+01 /
40322 DATA ALFVEC(-2) / 0.5293999E+00 /
40323 DATA QMAVEC(-2) / 0.0000000E+00 /
40324 DATA (AM( 0,K,-2),K=0, 2)
40325 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
40326 DATA (AM( 1,K,-2),K=0, 2)
40327 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
40328 DATA (AM( 2,K,-2),K=0, 2)
40329 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
40330 DATA (AM( 3,K,-2),K=0, 2)
40331 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
40332 DATA (AM( 4,K,-2),K=0, 2)
40333 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
40334 DATA (AM( 5,K,-2),K=0, 2)
40335 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
40336 DATA (AM( 6,K,-2),K=0, 2)
40337 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
40338 DATA (AM( 7,K,-2),K=0, 2)
40339 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
40340
40341 DATA MEXVEC(-3) / 7 /
40342 DATA MLFVEC(-3) / 2 /
40343 DATA UT1VEC(-3) / 0.3753257E+01 /
40344 DATA UT2VEC(-3) / -0.1113085E+01 /
40345 DATA ALFVEC(-3) / 0.3713141E+00 /
40346 DATA QMAVEC(-3) / 0.0000000E+00 /
40347 DATA (AM( 0,K,-3),K=0, 2)
40348 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
40349 DATA (AM( 1,K,-3),K=0, 2)
40350 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
40351 DATA (AM( 2,K,-3),K=0, 2)
40352 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
40353 DATA (AM( 3,K,-3),K=0, 2)
40354 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
40355 DATA (AM( 4,K,-3),K=0, 2)
40356 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
40357 DATA (AM( 5,K,-3),K=0, 2)
40358 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
40359 DATA (AM( 6,K,-3),K=0, 2)
40360 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
40361 DATA (AM( 7,K,-3),K=0, 2)
40362 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
40363
40364 DATA MEXVEC(-4) / 7 /
40365 DATA MLFVEC(-4) / 2 /
40366 DATA UT1VEC(-4) / 0.4400772E+01 /
40367 DATA UT2VEC(-4) / -0.1356116E+01 /
40368 DATA ALFVEC(-4) / 0.3712017E-01 /
40369 DATA QMAVEC(-4) / 0.1300000E+01 /
40370 DATA (AM( 0,K,-4),K=0, 2)
40371 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
40372 DATA (AM( 1,K,-4),K=0, 2)
40373 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
40374 DATA (AM( 2,K,-4),K=0, 2)
40375 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
40376 DATA (AM( 3,K,-4),K=0, 2)
40377 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
40378 DATA (AM( 4,K,-4),K=0, 2)
40379 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
40380 DATA (AM( 5,K,-4),K=0, 2)
40381 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
40382 DATA (AM( 6,K,-4),K=0, 2)
40383 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
40384 DATA (AM( 7,K,-4),K=0, 2)
40385 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
40386
40387 DATA MEXVEC(-5) / 6 /
40388 DATA MLFVEC(-5) / 2 /
40389 DATA UT1VEC(-5) / 0.5562568E+01 /
40390 DATA UT2VEC(-5) / -0.1801317E+01 /
40391 DATA ALFVEC(-5) / 0.4952010E-02 /
40392 DATA QMAVEC(-5) / 0.4500000E+01 /
40393 DATA (AM( 0,K,-5),K=0, 2)
40394 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
40395 DATA (AM( 1,K,-5),K=0, 2)
40396 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
40397 DATA (AM( 2,K,-5),K=0, 2)
40398 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
40399 DATA (AM( 3,K,-5),K=0, 2)
40400 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
40401 DATA (AM( 4,K,-5),K=0, 2)
40402 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
40403 DATA (AM( 5,K,-5),K=0, 2)
40404 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
40405 DATA (AM( 6,K,-5),K=0, 2)
40406 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
40407
40408 IF(Q .LE. QMAVEC(IFL)) THEN
40409 PYCT5L = 0.D0
40410 RETURN
40411 ENDIF
40412
40413 IF(X .GE. 1.D0) THEN
40414 PYCT5L = 0.D0
40415 RETURN
40416 ENDIF
40417
40418 TMP = LOG(Q/ALFVEC(IFL))
40419 IF(TMP .LE. 0.D0) THEN
40420 PYCT5L = 0.D0
40421 RETURN
40422 ENDIF
40423
40424 SB = LOG(TMP)
40425 SB1 = SB - 1.2D0
40426 SB2 = SB1*SB1
40427
40428 DO 110 I = 0, NEX
40429 AF(I) = 0.D0
40430 SBX = 1.D0
40431 DO 100 K = 0, MLFVEC(IFL)
40432 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40433 SBX = SB1*SBX
40434 100 CONTINUE
40435 110 CONTINUE
40436
40437 Y = -LOG(X)
40438 U = LOG(X/0.00001D0)
40439
40440 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40441 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40442 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40443 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40444 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40445
40446 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40447
40448C...Include threshold factor.
40449 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
40450
40451 RETURN
40452 END
40453
40454C*********************************************************************
40455
40456C...PYCT5M
40457C...Auxiliary function for parametrization of CTEQ5M1.
40458C...Author: J. Pumplin 9/99.
40459
40460 FUNCTION PYCT5M(IFL,X,Q)
40461
40462C...Double precision declaration.
40463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40464 IMPLICIT INTEGER(I-N)
40465
40466 PARAMETER (NEX=8, NLF=2)
40467 DIMENSION AM(0:NEX,0:NLF,-5:2)
40468 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40469 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40470 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40471 DIMENSION AF(0:NEX)
40472
40473 DATA MEXVEC( 2) / 8 /
40474 DATA MLFVEC( 2) / 2 /
40475 DATA UT1VEC( 2) / 0.5141718E+01 /
40476 DATA UT2VEC( 2) / -0.1346944E+01 /
40477 DATA ALFVEC( 2) / 0.5260555E+00 /
40478 DATA QMAVEC( 2) / 0.0000000E+00 /
40479 DATA (AM( 0,K, 2),K=0, 2)
40480 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
40481 DATA (AM( 1,K, 2),K=0, 2)
40482 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
40483 DATA (AM( 2,K, 2),K=0, 2)
40484 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
40485 DATA (AM( 3,K, 2),K=0, 2)
40486 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
40487 DATA (AM( 4,K, 2),K=0, 2)
40488 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
40489 DATA (AM( 5,K, 2),K=0, 2)
40490 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
40491 DATA (AM( 6,K, 2),K=0, 2)
40492 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
40493 DATA (AM( 7,K, 2),K=0, 2)
40494 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
40495 DATA (AM( 8,K, 2),K=0, 2)
40496 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
40497
40498 DATA MEXVEC( 1) / 8 /
40499 DATA MLFVEC( 1) / 2 /
40500 DATA UT1VEC( 1) / 0.4138426E+01 /
40501 DATA UT2VEC( 1) / -0.3221374E+01 /
40502 DATA ALFVEC( 1) / 0.4960962E+00 /
40503 DATA QMAVEC( 1) / 0.0000000E+00 /
40504 DATA (AM( 0,K, 1),K=0, 2)
40505 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
40506 DATA (AM( 1,K, 1),K=0, 2)
40507 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
40508 DATA (AM( 2,K, 1),K=0, 2)
40509 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
40510 DATA (AM( 3,K, 1),K=0, 2)
40511 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
40512 DATA (AM( 4,K, 1),K=0, 2)
40513 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
40514 DATA (AM( 5,K, 1),K=0, 2)
40515 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
40516 DATA (AM( 6,K, 1),K=0, 2)
40517 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
40518 DATA (AM( 7,K, 1),K=0, 2)
40519 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
40520 DATA (AM( 8,K, 1),K=0, 2)
40521 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
40522
40523 DATA MEXVEC( 0) / 8 /
40524 DATA MLFVEC( 0) / 2 /
40525 DATA UT1VEC( 0) / -0.1026789E+01 /
40526 DATA UT2VEC( 0) / -0.9051707E+01 /
40527 DATA ALFVEC( 0) / 0.9462977E+00 /
40528 DATA QMAVEC( 0) / 0.0000000E+00 /
40529 DATA (AM( 0,K, 0),K=0, 2)
40530 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
40531 DATA (AM( 1,K, 0),K=0, 2)
40532 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
40533 DATA (AM( 2,K, 0),K=0, 2)
40534 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
40535 DATA (AM( 3,K, 0),K=0, 2)
40536 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
40537 DATA (AM( 4,K, 0),K=0, 2)
40538 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
40539 DATA (AM( 5,K, 0),K=0, 2)
40540 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
40541 DATA (AM( 6,K, 0),K=0, 2)
40542 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
40543 DATA (AM( 7,K, 0),K=0, 2)
40544 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
40545 DATA (AM( 8,K, 0),K=0, 2)
40546 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
40547
40548 DATA MEXVEC(-1) / 8 /
40549 DATA MLFVEC(-1) / 2 /
40550 DATA UT1VEC(-1) / 0.5243571E+01 /
40551 DATA UT2VEC(-1) / -0.2870513E+01 /
40552 DATA ALFVEC(-1) / 0.6701448E+00 /
40553 DATA QMAVEC(-1) / 0.0000000E+00 /
40554 DATA (AM( 0,K,-1),K=0, 2)
40555 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
40556 DATA (AM( 1,K,-1),K=0, 2)
40557 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
40558 DATA (AM( 2,K,-1),K=0, 2)
40559 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
40560 DATA (AM( 3,K,-1),K=0, 2)
40561 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
40562 DATA (AM( 4,K,-1),K=0, 2)
40563 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
40564 DATA (AM( 5,K,-1),K=0, 2)
40565 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
40566 DATA (AM( 6,K,-1),K=0, 2)
40567 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
40568 DATA (AM( 7,K,-1),K=0, 2)
40569 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
40570 DATA (AM( 8,K,-1),K=0, 2)
40571 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
40572
40573 DATA MEXVEC(-2) / 7 /
40574 DATA MLFVEC(-2) / 2 /
40575 DATA UT1VEC(-2) / 0.4782210E+01 /
40576 DATA UT2VEC(-2) / -0.1976856E+02 /
40577 DATA ALFVEC(-2) / 0.7558374E+00 /
40578 DATA QMAVEC(-2) / 0.0000000E+00 /
40579 DATA (AM( 0,K,-2),K=0, 2)
40580 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
40581 DATA (AM( 1,K,-2),K=0, 2)
40582 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
40583 DATA (AM( 2,K,-2),K=0, 2)
40584 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
40585 DATA (AM( 3,K,-2),K=0, 2)
40586 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
40587 DATA (AM( 4,K,-2),K=0, 2)
40588 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
40589 DATA (AM( 5,K,-2),K=0, 2)
40590 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
40591 DATA (AM( 6,K,-2),K=0, 2)
40592 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
40593 DATA (AM( 7,K,-2),K=0, 2)
40594 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
40595
40596 DATA MEXVEC(-3) / 7 /
40597 DATA MLFVEC(-3) / 2 /
40598 DATA UT1VEC(-3) / 0.4518239E+01 /
40599 DATA UT2VEC(-3) / -0.2690590E+01 /
40600 DATA ALFVEC(-3) / 0.6124079E+00 /
40601 DATA QMAVEC(-3) / 0.0000000E+00 /
40602 DATA (AM( 0,K,-3),K=0, 2)
40603 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
40604 DATA (AM( 1,K,-3),K=0, 2)
40605 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
40606 DATA (AM( 2,K,-3),K=0, 2)
40607 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
40608 DATA (AM( 3,K,-3),K=0, 2)
40609 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
40610 DATA (AM( 4,K,-3),K=0, 2)
40611 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
40612 DATA (AM( 5,K,-3),K=0, 2)
40613 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
40614 DATA (AM( 6,K,-3),K=0, 2)
40615 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
40616 DATA (AM( 7,K,-3),K=0, 2)
40617 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
40618
40619 DATA MEXVEC(-4) / 7 /
40620 DATA MLFVEC(-4) / 2 /
40621 DATA UT1VEC(-4) / 0.2783230E+01 /
40622 DATA UT2VEC(-4) / -0.1746328E+01 /
40623 DATA ALFVEC(-4) / 0.1115653E+01 /
40624 DATA QMAVEC(-4) / 0.1300000E+01 /
40625 DATA (AM( 0,K,-4),K=0, 2)
40626 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
40627 DATA (AM( 1,K,-4),K=0, 2)
40628 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
40629 DATA (AM( 2,K,-4),K=0, 2)
40630 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
40631 DATA (AM( 3,K,-4),K=0, 2)
40632 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
40633 DATA (AM( 4,K,-4),K=0, 2)
40634 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
40635 DATA (AM( 5,K,-4),K=0, 2)
40636 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
40637 DATA (AM( 6,K,-4),K=0, 2)
40638 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
40639 DATA (AM( 7,K,-4),K=0, 2)
40640 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
40641
40642 DATA MEXVEC(-5) / 6 /
40643 DATA MLFVEC(-5) / 2 /
40644 DATA UT1VEC(-5) / 0.1619654E+02 /
40645 DATA UT2VEC(-5) / -0.3367346E+01 /
40646 DATA ALFVEC(-5) / 0.5109891E-02 /
40647 DATA QMAVEC(-5) / 0.4500000E+01 /
40648 DATA (AM( 0,K,-5),K=0, 2)
40649 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
40650 DATA (AM( 1,K,-5),K=0, 2)
40651 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
40652 DATA (AM( 2,K,-5),K=0, 2)
40653 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
40654 DATA (AM( 3,K,-5),K=0, 2)
40655 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
40656 DATA (AM( 4,K,-5),K=0, 2)
40657 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
40658 DATA (AM( 5,K,-5),K=0, 2)
40659 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
40660 DATA (AM( 6,K,-5),K=0, 2)
40661 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
40662
40663 IF(Q .LE. QMAVEC(IFL)) THEN
40664 PYCT5M = 0.D0
40665 RETURN
40666 ENDIF
40667
40668 IF(X .GE. 1.D0) THEN
40669 PYCT5M = 0.D0
40670 RETURN
40671 ENDIF
40672
40673 TMP = LOG(Q/ALFVEC(IFL))
40674 IF(TMP .LE. 0.D0) THEN
40675 PYCT5M = 0.D0
40676 RETURN
40677 ENDIF
40678
40679 SB = LOG(TMP)
40680 SB1 = SB - 1.2D0
40681 SB2 = SB1*SB1
40682
40683 DO 110 I = 0, NEX
40684 AF(I) = 0.D0
40685 SBX = 1.D0
40686 DO 100 K = 0, MLFVEC(IFL)
40687 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40688 SBX = SB1*SBX
40689 100 CONTINUE
40690 110 CONTINUE
40691
40692 Y = -LOG(X)
40693 U = LOG(X/0.00001D0)
40694
40695 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40696 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40697 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40698 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40699 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40700
40701 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40702
40703C...Include threshold factor.
40704 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
40705
40706 RETURN
40707 END
40708
40709C*********************************************************************
40710
40711C...PYPDPO
40712C...Auxiliary to PYPDPR. Gives proton parton distributions according to
40713C...a few older parametrizations, now obsolete but convenient for
40714C...backwards checks.
40715
40716 SUBROUTINE PYPDPO(X,Q2,XPPR)
40717
40718C...Double precision and integer declarations.
40719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40720 IMPLICIT INTEGER(I-N)
40721 INTEGER PYK,PYCHGE,PYCOMP
40722C...Commonblocks.
40723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40725 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40726 COMMON/PYINT1/MINT(400),VINT(400)
40727 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40728 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
40729 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
40730
40731
40732C...The following data lines are coefficients needed in the
40733C...Eichten, Hinchliffe, Lane, Quigg proton structure function
40734C...parametrizations, see below.
40735C...Powers of 1-x in different cases.
40736 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
40737C...Expansion coefficients for up valence quark distribution.
40738 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
40739 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
40740 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
40741 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
40742 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
40743 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
40744 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
40745 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
40746 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
40747 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
40748 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
40749 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
40750 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
40751 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
40752 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
40753 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
40754 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
40755 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
40756 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
40757 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
40758 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
40759 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
40760 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
40761 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
40762 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
40763 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
40764C...Expansion coefficients for down valence quark distribution.
40765 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
40766 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
40767 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
40768 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
40769 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
40770 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
40771 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
40772 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
40773 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
40774 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
40775 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
40776 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
40777 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
40778 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
40779 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
40780 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
40781 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
40782 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
40783 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
40784 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
40785 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
40786 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
40787 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
40788 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
40789 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
40790 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
40791C...Expansion coefficients for up and down sea quark distributions.
40792 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
40793 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
40794 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
40795 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
40796 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
40797 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
40798 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
40799 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
40800 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
40801 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
40802 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
40803 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
40804 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
40805 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
40806 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
40807 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
40808 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
40809 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
40810 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
40811 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
40812 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
40813 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
40814 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
40815 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
40816 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
40817 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
40818C...Expansion coefficients for gluon distribution.
40819 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
40820 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
40821 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
40822 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
40823 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
40824 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
40825 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
40826 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
40827 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
40828 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
40829 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
40830 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
40831 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
40832 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
40833 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
40834 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
40835 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
40836 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
40837 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
40838 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
40839 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
40840 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
40841 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
40842 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
40843 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
40844 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
40845C...Expansion coefficients for strange sea quark distribution.
40846 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
40847 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
40848 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
40849 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
40850 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
40851 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
40852 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
40853 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
40854 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
40855 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
40856 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
40857 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
40858 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
40859 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
40860 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
40861 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
40862 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
40863 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
40864 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
40865 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
40866 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
40867 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
40868 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
40869 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
40870 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
40871 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
40872C...Expansion coefficients for charm sea quark distribution.
40873 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
40874 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
40875 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
40876 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
40877 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
40878 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
40879 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
40880 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
40881 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
40882 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
40883 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
40884 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
40885 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
40886 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
40887 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
40888 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
40889 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
40890 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
40891 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
40892 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
40893 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
40894 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
40895 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
40896 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
40897 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
40898 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
40899C...Expansion coefficients for bottom sea quark distribution.
40900 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
40901 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
40902 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
40903 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
40904 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
40905 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
40906 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
40907 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
40908 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
40909 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
40910 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40911 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40912 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40913 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40914 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40915 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40916 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40917 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40918 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40919 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40920 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40921 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40922 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40923 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40924 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40925 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40926C...Expansion coefficients for top sea quark distribution.
40927 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40928 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40929 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40930 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40931 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40932 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40933 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40934 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40935 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40936 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40937 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40938 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40939 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40940 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40941 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40942 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40943 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40944 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40945 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40946 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40947 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40948 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40949 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40950 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40951 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40952 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40953
40954C...The following data lines are coefficients needed in the
40955C...Duke, Owens proton structure function parametrizations, see below.
40956C...Expansion coefficients for (up+down) valence quark distribution.
40957 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40958 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40959 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40960 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40961 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40962 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40963 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40964 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40965C...Expansion coefficients for down valence quark distribution.
40966 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40967 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40968 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40969 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40970 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40971 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40972 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40973 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40974C...Expansion coefficients for (up+down+strange) sea quark distribution.
40975 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40976 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40977 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40978 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
40979 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
40980 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40981 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
40982 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
40983C...Expansion coefficients for charm sea quark distribution.
40984 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
40985 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40986 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
40987 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
40988 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
40989 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40990 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
40991 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
40992C...Expansion coefficients for gluon distribution.
40993 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
40994 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40995 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
40996 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
40997 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
40998 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40999 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41000 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41001
41002C...Euler's beta function, requires ordinary Gamma function
41003 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41004
41005C...Leading order proton parton distributions from Glueck, Reya and
41006C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41007C...10^-5 < x < 1.
41008 IF(MSTP(51).EQ.11) THEN
41009
41010C...Determine s expansion variable and some x expressions.
41011 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41012 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41013 SD2=SD**2
41014 XL=-LOG(X)
41015 XS=SQRT(X)
41016
41017C...Evaluate valence, gluon and sea distributions.
41018 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41019 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41020 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41021 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41022 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41023 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41024 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41025 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41026 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41027 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41028 & SQRT(4.066D0*SD**1.218D0*XL)))*
41029 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41030 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41031 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41032 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41033 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41034 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41035 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41036 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41037 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41038 IF(SD.LE.0.888D0) THEN
41039 XFCHM=0D0
41040 ELSE
41041 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41042 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41043 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41044 ENDIF
41045 IF(SD.LE.1.351D0) THEN
41046 XFBOT=0D0
41047 ELSE
41048 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41049 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41050 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41051 ENDIF
41052
41053C...Put into output array.
41054 XPPR(0)=XFGLU
41055 XPPR(1)=XFVDD+XFSEA
41056 XPPR(2)=XFVUD-XFVDD+XFSEA
41057 XPPR(3)=XFSTR
41058 XPPR(4)=XFCHM
41059 XPPR(5)=XFBOT
41060 XPPR(-1)=XFSEA
41061 XPPR(-2)=XFSEA
41062 XPPR(-3)=XFSTR
41063 XPPR(-4)=XFCHM
41064 XPPR(-5)=XFBOT
41065
41066C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41067C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41068 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41069
41070C...Determine set, Lambda and x and t expansion variables.
41071 NSET=MSTP(51)-11
41072 IF(NSET.EQ.1) ALAM=0.2D0
41073 IF(NSET.EQ.2) ALAM=0.29D0
41074 TMIN=LOG(5D0/ALAM**2)
41075 TMAX=LOG(1D8/ALAM**2)
41076 T=LOG(MAX(1D0,Q2/ALAM**2))
41077 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41078 NX=1
41079 IF(X.LE.0.1D0) NX=2
41080 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
41081 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
41082
41083C...Chebyshev polynomials for x and t expansion.
41084 TX(1)=1D0
41085 TX(2)=VX
41086 TX(3)=2D0*VX**2-1D0
41087 TX(4)=4D0*VX**3-3D0*VX
41088 TX(5)=8D0*VX**4-8D0*VX**2+1D0
41089 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
41090 TT(1)=1D0
41091 TT(2)=VT
41092 TT(3)=2D0*VT**2-1D0
41093 TT(4)=4D0*VT**3-3D0*VT
41094 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41095 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41096
41097C...Calculate structure functions.
41098 DO 120 KFL=1,6
41099 XQSUM=0D0
41100 DO 110 IT=1,6
41101 DO 100 IX=1,6
41102 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
41103 100 CONTINUE
41104 110 CONTINUE
41105 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
41106 120 CONTINUE
41107
41108C...Put into output array.
41109 XPPR(0)=XQ(4)
41110 XPPR(1)=XQ(2)+XQ(3)
41111 XPPR(2)=XQ(1)+XQ(3)
41112 XPPR(3)=XQ(5)
41113 XPPR(4)=XQ(6)
41114 XPPR(-1)=XQ(3)
41115 XPPR(-2)=XQ(3)
41116 XPPR(-3)=XQ(5)
41117 XPPR(-4)=XQ(6)
41118
41119C...Special expansion for bottom (threshold effects).
41120 IF(MSTP(58).GE.5) THEN
41121 IF(NSET.EQ.1) TMIN=8.1905D0
41122 IF(NSET.EQ.2) TMIN=7.4474D0
41123 IF(T.GT.TMIN) THEN
41124 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41125 TT(1)=1D0
41126 TT(2)=VT
41127 TT(3)=2D0*VT**2-1D0
41128 TT(4)=4D0*VT**3-3D0*VT
41129 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41130 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41131 XQSUM=0D0
41132 DO 140 IT=1,6
41133 DO 130 IX=1,6
41134 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
41135 130 CONTINUE
41136 140 CONTINUE
41137 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
41138 XPPR(-5)=XPPR(5)
41139 ENDIF
41140 ENDIF
41141
41142C...Special expansion for top (threshold effects).
41143 IF(MSTP(58).GE.6) THEN
41144 IF(NSET.EQ.1) TMIN=11.5528D0
41145 IF(NSET.EQ.2) TMIN=10.8097D0
41146 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
41147 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
41148 IF(T.GT.TMIN) THEN
41149 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41150 TT(1)=1D0
41151 TT(2)=VT
41152 TT(3)=2D0*VT**2-1D0
41153 TT(4)=4D0*VT**3-3D0*VT
41154 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41155 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41156 XQSUM=0D0
41157 DO 160 IT=1,6
41158 DO 150 IX=1,6
41159 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
41160 150 CONTINUE
41161 160 CONTINUE
41162 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
41163 XPPR(-6)=XPPR(6)
41164 ENDIF
41165 ENDIF
41166
41167C...Proton parton distributions from Duke, Owens.
41168C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
41169 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
41170
41171C...Determine set, Lambda and s expansion parameter.
41172 NSET=MSTP(51)-13
41173 IF(NSET.EQ.1) ALAM=0.2D0
41174 IF(NSET.EQ.2) ALAM=0.4D0
41175 Q2IN=MIN(1D6,MAX(4D0,Q2))
41176 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
41177
41178C...Calculate structure functions.
41179 DO 180 KFL=1,5
41180 DO 170 IS=1,6
41181 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
41182 & CDO(3,IS,KFL,NSET)*SD**2
41183 170 CONTINUE
41184 IF(KFL.LE.2) THEN
41185 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
41186 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
41187 ELSE
41188 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
41189 & TS(5)*X**2+TS(6)*X**3)
41190 ENDIF
41191 180 CONTINUE
41192
41193C...Put into output arrays.
41194 XPPR(0)=XQ(5)
41195 XPPR(1)=XQ(2)+XQ(3)/6D0
41196 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
41197 XPPR(3)=XQ(3)/6D0
41198 XPPR(4)=XQ(4)
41199 XPPR(-1)=XQ(3)/6D0
41200 XPPR(-2)=XQ(3)/6D0
41201 XPPR(-3)=XQ(3)/6D0
41202 XPPR(-4)=XQ(4)
41203
41204 ENDIF
41205
41206 RETURN
41207 END
41208
41209C*********************************************************************
41210
41211C...PYHFTH
41212C...Gives threshold attractive/repulsive factor for heavy flavour
41213C...production.
41214
41215 FUNCTION PYHFTH(SH,SQM,FRATT)
41216
41217C...Double precision and integer declarations.
41218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41219 IMPLICIT INTEGER(I-N)
41220 INTEGER PYK,PYCHGE,PYCOMP
41221C...Commonblocks.
41222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41223 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41224 COMMON/PYINT1/MINT(400),VINT(400)
41225 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
41226
41227C...Value for alpha_strong.
41228 IF(MSTP(35).LE.1) THEN
41229 ALSSG=PARP(35)
41230 ELSE
41231 MST115=MSTU(115)
41232 MSTU(115)=MSTP(36)
41233 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
41234 & PARP(36)**2)))
41235 ALSSG=PYALPS(Q2BN)
41236 MSTU(115)=MST115
41237 ENDIF
41238
41239C...Evaluate attractive and repulsive factors.
41240 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41241 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
41242 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41243 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
41244 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
41245 VINT(138)=PYHFTH
41246
41247 RETURN
41248 END
41249
41250C*********************************************************************
41251
41252C...PYSPLI
41253C...Splits a hadron remnant into two (partons or hadron + parton)
41254C...in case it is more complicated than just a quark or a diquark.
41255
41256 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
41257
41258C...Double precision and integer declarations.
41259 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41260 IMPLICIT INTEGER(I-N)
41261 INTEGER PYK,PYCHGE,PYCOMP
41262C...Commonblocks. PYDAT1 temporary
41263 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41264 COMMON/PYINT1/MINT(400),VINT(400)
41265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41266 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
41267C...Local array.
41268 DIMENSION KFL(3)
41269
41270C...Preliminaries. Parton composition.
41271 KFA=IABS(KF)
41272 KFS=ISIGN(1,KF)
41273 KFL(1)=MOD(KFA/1000,10)
41274 KFL(2)=MOD(KFA/100,10)
41275 KFL(3)=MOD(KFA/10,10)
41276 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
41277 KFL(2)=INT(1.5D0+PYR(0))
41278 IF(MINT(105).EQ.333) KFL(2)=3
41279 IF(MINT(105).EQ.443) KFL(2)=4
41280 KFL(3)=KFL(2)
41281 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
41282 KFL(2)=2
41283 KFL(3)=2
41284 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
41285 KFL(2)=1
41286 KFL(3)=1
41287 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
41288 KFL(2)=MOD(KFA/10,10)
41289 KFL(3)=MOD(KFA/100,10)
41290 ENDIF
41291 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
41292 KFLR=KFLIN*KFS
41293 ELSE
41294 KFLR=KFLIN
41295 ENDIF
41296 KFLCH=0
41297
41298C...Subdivide lepton.
41299 IF(KFA.GE.11.AND.KFA.LE.18) THEN
41300 IF(KFLR.EQ.KFA) THEN
41301 KFLSP=KFS*22
41302 ELSEIF(KFLR.EQ.22) THEN
41303 KFLSP=KFA
41304 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
41305 KFLSP=KFA+1
41306 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
41307 KFLSP=KFA-1
41308 ELSEIF(KFLR.EQ.21) THEN
41309 KFLSP=KFA
41310 KFLCH=KFS*21
41311 ELSE
41312 KFLSP=KFA
41313 KFLCH=-KFLR
41314 ENDIF
41315
41316C...Subdivide photon.
41317 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
41318 IF(KFLR.NE.21) THEN
41319 KFLSP=-KFLR
41320 ELSE
41321 RAGR=0.75D0*PYR(0)
41322 KFLSP=1
41323 IF(RAGR.GT.0.125D0) KFLSP=2
41324 IF(RAGR.GT.0.625D0) KFLSP=3
41325 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
41326 KFLCH=-KFLSP
41327 ENDIF
41328
41329C...Subdivide Reggeon or Pomeron.
41330 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
41331 IF(KFLIN.EQ.21) THEN
41332 KFLSP=KFS*21
41333 ELSE
41334 KFLSP=-KFLIN
41335 ENDIF
41336
41337C...Subdivide meson.
41338 ELSEIF(KFL(1).EQ.0) THEN
41339 KFL(2)=KFL(2)*(-1)**KFL(2)
41340 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
41341 IF(KFLR.EQ.KFL(2)) THEN
41342 KFLSP=KFL(3)
41343 ELSEIF(KFLR.EQ.KFL(3)) THEN
41344 KFLSP=KFL(2)
41345 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
41346 KFLSP=KFL(2)
41347 KFLCH=KFL(3)
41348 ELSEIF(KFLR.EQ.21) THEN
41349 KFLSP=KFL(3)
41350 KFLCH=KFL(2)
41351 ELSEIF(KFLR*KFL(2).GT.0) THEN
41352 NTRY=0
41353 100 NTRY=NTRY+1
41354 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
41355 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41356 GOTO 100
41357 ELSEIF(KFLCH.EQ.0) THEN
41358 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41359 MINT(51)=1
41360 RETURN
41361 ENDIF
41362 KFLSP=KFL(3)
41363 ELSE
41364 NTRY=0
41365 110 NTRY=NTRY+1
41366 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
41367 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41368 GOTO 110
41369 ELSEIF(KFLCH.EQ.0) THEN
41370 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41371 MINT(51)=1
41372 RETURN
41373 ENDIF
41374 KFLSP=KFL(2)
41375 ENDIF
41376
41377C...Special case for extracting photon from baryon without splitting
41378C...the latter. (Currently only used by external programs.)
41379 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
41380 KFLSP=KFA
41381 KFLCH=0
41382
41383C...Subdivide baryon.
41384 ELSE
41385 NAGR=0
41386 DO 120 J=1,3
41387 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
41388 120 CONTINUE
41389 IF(NAGR.GE.1) THEN
41390 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
41391 IAGR=0
41392 DO 130 J=1,3
41393 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
41394 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
41395 130 CONTINUE
41396 ELSE
41397 IAGR=1.00001D0+2.99998D0*PYR(0)
41398 ENDIF
41399 ID1=1
41400 IF(IAGR.EQ.1) ID1=2
41401 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
41402 ID2=6-IAGR-ID1
41403 KSP=3
41404 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
41405 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
41406 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
41407 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
41408 ELSEIF(MOD(KFA,10).EQ.2) THEN
41409 IF(IAGR.EQ.1) KSP=1
41410 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
41411 ENDIF
41412 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
41413 IF(KFLR.EQ.21) THEN
41414 KFLCH=KFL(IAGR)
41415 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
41416 NTRY=0
41417 140 NTRY=NTRY+1
41418 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
41419 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41420 GOTO 140
41421 ELSEIF(KFLCH.EQ.0) THEN
41422 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41423 MINT(51)=1
41424 RETURN
41425 ENDIF
41426 ELSEIF(NAGR.EQ.0) THEN
41427 NTRY=0
41428 150 NTRY=NTRY+1
41429 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
41430 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41431 GOTO 150
41432 ELSEIF(KFLCH.EQ.0) THEN
41433 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41434 MINT(51)=1
41435 RETURN
41436 ENDIF
41437 KFLSP=KFL(IAGR)
41438 ENDIF
41439 ENDIF
41440
41441C...Add on correct sign for result.
41442 KFLCH=KFLCH*KFS
41443 KFLSP=KFLSP*KFS
41444
41445 RETURN
41446 END
41447
41448C*********************************************************************
41449
41450C...PYGAMM
41451C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
41452C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
41453C...(Dover, 1965) 6.1.36.
41454
41455 FUNCTION PYGAMM(X)
41456
41457C...Double precision and integer declarations.
41458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41459 IMPLICIT INTEGER(I-N)
41460 INTEGER PYK,PYCHGE,PYCOMP
41461C...Local array and data.
41462 DIMENSION B(8)
41463 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
41464 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
41465
41466 NX=INT(X)
41467 DX=X-NX
41468
41469 PYGAMM=1D0
41470 DXP=1D0
41471 DO 100 I=1,8
41472 DXP=DXP*DX
41473 PYGAMM=PYGAMM+B(I)*DXP
41474 100 CONTINUE
41475 IF(X.LT.1D0) THEN
41476 PYGAMM=PYGAMM/X
41477 ELSE
41478 DO 110 IX=1,NX-1
41479 PYGAMM=(X-IX)*PYGAMM
41480 110 CONTINUE
41481 ENDIF
41482
41483 RETURN
41484 END
41485
41486C***********************************************************************
41487
41488C...PYWAUX
41489C...Calculates real and imaginary parts of the auxiliary functions W1
41490C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
41491C...der Bij, Nucl. Phys. B297 (1988) 221.
41492
41493 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
41494
41495C...Double precision and integer declarations.
41496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41497 IMPLICIT INTEGER(I-N)
41498 INTEGER PYK,PYCHGE,PYCOMP
41499C...Commonblocks.
41500 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41501 SAVE /PYDAT1/
41502
41503 ASINH(X)=LOG(X+SQRT(X**2+1D0))
41504 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
41505
41506 IF(EPS.LT.0D0) THEN
41507 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
41508 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
41509 WIM=0D0
41510 ELSEIF(EPS.LT.1D0) THEN
41511 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
41512 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
41513 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
41514 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
41515 ELSE
41516 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
41517 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
41518 WIM=0D0
41519 ENDIF
41520
41521 RETURN
41522 END
41523
41524C***********************************************************************
41525
41526C...PYI3AU
41527C...Calculates real and imaginary parts of the auxiliary function I3;
41528C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
41529C...Nucl. Phys. B297 (1988) 221.
41530
41531 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
41532
41533C...Double precision and integer declarations.
41534 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41535 IMPLICIT INTEGER(I-N)
41536 INTEGER PYK,PYCHGE,PYCOMP
41537C...Commonblocks.
41538 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41539 SAVE /PYDAT1/
41540
41541 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
41542 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
41543
41544 IF(EPS.LT.0D0) THEN
41545 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41546 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41547 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41548 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
41549 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
41550 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
41551 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
41552 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
41553 & EPS))
41554 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41555 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41556 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41557 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
41558 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
41559 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
41560 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
41561 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
41562 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41563 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41564 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41565 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
41566 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
41567 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
41568 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
41569 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
41570 ELSE
41571 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41572 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
41573 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
41574 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
41575 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
41576 ENDIF
41577 F3IM=0D0
41578 ELSEIF(EPS.LT.1D0) THEN
41579 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41580 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41581 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41582 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
41583 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
41584 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41585 & (0.25D0*(RAT+1D0)*EPS))
41586 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41587 & (0.25D0*(RAT+1D0)*EPS))
41588 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41589 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41590 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41591 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
41592 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
41593 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
41594 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41595 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41596 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41597 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41598 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41599 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
41600 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
41601 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
41602 & (1D0+0.25D0*RAT*EPS-GA))
41603 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
41604 & (1D0+0.25D0*RAT*EPS-GA))
41605 ELSE
41606 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41607 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
41608 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
41609 & LOG((GA+BE-1D0)/(BE-GA))
41610 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
41611 ENDIF
41612 ELSE
41613 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
41614 RCTHE=RSQ*(1D0-2D0*BE/EPS)
41615 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
41616 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
41617 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
41618 R=SQRT(RSQ)
41619 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
41620 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
41621 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
41622 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
41623 & (PHI-THE)*(PHI+THE-PARU(1))
41624 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
41625 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
41626 ENDIF
41627
41628 Y3RE=2D0/(2D0*BE-1D0)*F3RE
41629 Y3IM=2D0/(2D0*BE-1D0)*F3IM
41630
41631 RETURN
41632 END
41633
41634C***********************************************************************
41635
41636C...PYSPEN
41637C...Calculates real and imaginary part of Spence function; see
41638C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
41639
41640 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
41641
41642C...Double precision and integer declarations.
41643 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41644 IMPLICIT INTEGER(I-N)
41645 INTEGER PYK,PYCHGE,PYCOMP
41646C...Commonblocks.
41647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41648 SAVE /PYDAT1/
41649C...Local array and data.
41650 DIMENSION B(0:14)
41651 DATA B/
41652 &1.000000D+00, -5.000000D-01, 1.666667D-01,
41653 &0.000000D+00, -3.333333D-02, 0.000000D+00,
41654 &2.380952D-02, 0.000000D+00, -3.333333D-02,
41655 &0.000000D+00, 7.575757D-02, 0.000000D+00,
41656 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
41657
41658 XRE=XREIN
41659 XIM=XIMIN
41660 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
41661 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
41662 IF(IREIM.EQ.2) PYSPEN=0D0
41663 RETURN
41664 ENDIF
41665
41666 XMOD=SQRT(XRE**2+XIM**2)
41667 IF(XMOD.LT.1D-6) THEN
41668 IF(IREIM.EQ.1) PYSPEN=0D0
41669 IF(IREIM.EQ.2) PYSPEN=0D0
41670 RETURN
41671 ENDIF
41672
41673 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41674 SP0RE=0D0
41675 SP0IM=0D0
41676 SGN=1D0
41677 IF(XMOD.GT.1D0) THEN
41678 ALGXRE=LOG(XMOD)
41679 ALGXIM=XARG-SIGN(PARU(1),XARG)
41680 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
41681 SP0IM=-ALGXRE*ALGXIM
41682 SGN=-1D0
41683 XMOD=1D0/XMOD
41684 XARG=-XARG
41685 XRE=XMOD*COS(XARG)
41686 XIM=XMOD*SIN(XARG)
41687 ENDIF
41688 IF(XRE.GT.0.5D0) THEN
41689 ALGXRE=LOG(XMOD)
41690 ALGXIM=XARG
41691 XRE=1D0-XRE
41692 XIM=-XIM
41693 XMOD=SQRT(XRE**2+XIM**2)
41694 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41695 ALGYRE=LOG(XMOD)
41696 ALGYIM=XARG
41697 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
41698 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
41699 SGN=-SGN
41700 ENDIF
41701
41702 XRE=1D0-XRE
41703 XIM=-XIM
41704 XMOD=SQRT(XRE**2+XIM**2)
41705 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41706 ZRE=-LOG(XMOD)
41707 ZIM=-XARG
41708
41709 SPRE=0D0
41710 SPIM=0D0
41711 SAVERE=1D0
41712 SAVEIM=0D0
41713 DO 100 I=0,14
41714 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
41715 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
41716 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
41717 SAVERE=TERMRE
41718 SAVEIM=TERMIM
41719 SPRE=SPRE+B(I)*TERMRE
41720 SPIM=SPIM+B(I)*TERMIM
41721 100 CONTINUE
41722
41723 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
41724 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
41725
41726 RETURN
41727 END
41728
41729C***********************************************************************
41730
41731C...PYQQBH
41732C...Calculates the matrix element for the processes
41733C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
41734C...REDUCE output and part of the rest courtesy Z. Kunszt, see
41735C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
41736
41737 SUBROUTINE PYQQBH(WTQQBH)
41738
41739C...Double precision and integer declarations.
41740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41741 IMPLICIT INTEGER(I-N)
41742 INTEGER PYK,PYCHGE,PYCOMP
41743C...Commonblocks.
41744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41747 COMMON/PYINT1/MINT(400),VINT(400)
41748 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41749 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
41750C...Local arrays and function.
41751 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
41752 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
41753 &PP(I,3)*PP(J,3)
41754
41755C...Mass parameters.
41756 WTQQBH=0D0
41757 ISUB=MINT(1)
41758 SHPR=SQRT(VINT(26))*VINT(1)
41759 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
41760 PH=SQRT(VINT(21))*VINT(1)
41761 SPQ=PQ**2
41762 SPH=PH**2
41763
41764C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
41765 DO 100 I=1,2
41766 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41767 PP(I,1)=PT*COS(VINT(198+5*I))
41768 PP(I,2)=PT*SIN(VINT(198+5*I))
41769 100 CONTINUE
41770 PP(3,1)=-PP(1,1)-PP(2,1)
41771 PP(3,2)=-PP(1,2)-PP(2,2)
41772 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
41773 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
41774 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
41775 PMT3=SQRT(PMS3)
41776 PP(3,3)=PMT3*SINH(VINT(211))
41777 PP(3,4)=PMT3*COSH(VINT(211))
41778 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
41779 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41780 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
41781 PP(2,3)=-PP(1,3)-PP(3,3)
41782 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
41783 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
41784
41785C...Set up incoming kinematics and derived momentum combinations.
41786 DO 110 I=4,5
41787 PP(I,1)=0D0
41788 PP(I,2)=0D0
41789 PP(I,3)=-0.5D0*SHPR*(-1)**I
41790 PP(I,4)=-0.5D0*SHPR
41791 110 CONTINUE
41792 DO 120 J=1,4
41793 PP(6,J)=PP(1,J)+PP(2,J)
41794 PP(7,J)=PP(1,J)+PP(3,J)
41795 PP(8,J)=PP(1,J)+PP(4,J)
41796 PP(9,J)=PP(1,J)+PP(5,J)
41797 PP(10,J)=-PP(2,J)-PP(3,J)
41798 PP(11,J)=-PP(2,J)-PP(4,J)
41799 PP(12,J)=-PP(2,J)-PP(5,J)
41800 PP(13,J)=-PP(4,J)-PP(5,J)
41801 120 CONTINUE
41802
41803C...Derived kinematics invariants.
41804 X1=DOT(1,2)
41805 X2=DOT(1,3)
41806 X3=DOT(1,4)
41807 X4=DOT(1,5)
41808 X5=DOT(2,3)
41809 X6=DOT(2,4)
41810 X7=DOT(2,5)
41811 X8=DOT(3,4)
41812 X9=DOT(3,5)
41813 X10=DOT(4,5)
41814
41815C...Propagators.
41816 SS1=DOT(7,7)-SPQ
41817 SS2=DOT(8,8)-SPQ
41818 SS3=DOT(9,9)-SPQ
41819 SS4=DOT(10,10)-SPQ
41820 SS5=DOT(11,11)-SPQ
41821 SS6=DOT(12,12)-SPQ
41822 SS7=DOT(13,13)
41823 DX(1)=SS1*SS6
41824 DX(2)=SS2*SS6
41825 DX(3)=SS2*SS4
41826 DX(4)=SS1*SS5
41827 DX(5)=SS3*SS5
41828 DX(6)=SS3*SS4
41829 DX(7)=SS7*SS1
41830 DX(8)=SS7*SS4
41831
41832C...Define colour coefficients for g + g -> Q + Qbar + H.
41833 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
41834 DO 140 I=1,3
41835 DO 130 J=1,3
41836 CLR(I,J)=16D0/3D0
41837 CLR(I+3,J+3)=16D0/3D0
41838 CLR(I,J+3)=-2D0/3D0
41839 CLR(I+3,J)=-2D0/3D0
41840 130 CONTINUE
41841 140 CONTINUE
41842 DO 160 L=1,2
41843 DO 150 I=1,3
41844 CLR(I,6+L)=-6D0
41845 CLR(I+3,6+L)=6D0
41846 CLR(6+L,I)=-6D0
41847 CLR(6+L,I+3)=6D0
41848 150 CONTINUE
41849 160 CONTINUE
41850 DO 180 K1=1,2
41851 DO 170 K2=1,2
41852 CLR(6+K1,6+K2)=12D0
41853 170 CONTINUE
41854 180 CONTINUE
41855
41856C...Evaluate matrix elements for g + g -> Q + Qbar + H.
41857 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
41858 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
41859 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
41860 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
41861 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
41862 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
41863 & X10)
41864 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
41865 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
41866 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41867 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
41868 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
41869 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
41870 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
41871 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
41872 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
41873 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
41874 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
41875 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
41876 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41877 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
41878 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
41879 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
41880 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
41881 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
41882 & X4*X6*X5)
41883 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
41884 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
41885 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
41886 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
41887 & +X4*X9*X5+X4*X5**2)
41888 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
41889 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
41890 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
41891 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
41892 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
41893 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
41894 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
41895 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
41896 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
41897 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
41898 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
41899 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
41900 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
41901 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
41902 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
41903 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
41904 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
41905 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
41906 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
41907 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
41908 & X6)
41909 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
41910 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41911 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
41912 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
41913 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
41914 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
41915 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
41916 & X5+X4*X6*X5)
41917 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41918 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41919 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41920 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41921 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41922 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41923 & X6**2)
41924 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41925 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41926 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41927 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41928 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41929 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41930 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41931 & X4*X6*X5)
41932 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41933 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41934 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41935 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41936 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41937 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41938 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41939 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41940 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41941 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41942 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41943 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41944 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41945 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41946 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41947 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41948 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41949 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41950 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41951 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41952 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41953 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41954 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41955 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41956 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41957 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41958 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41959 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41960 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41961 & +X3*X8*X5+X3*X5**2)
41962 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41963 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41964 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41965 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41966 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41967 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41968 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41969 & X5+X4*X6*X5)
41970 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41971 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41972 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41973 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41974 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41975 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41976 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41977 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41978 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
41979 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
41980 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
41981 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
41982 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
41983 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
41984 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
41985 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
41986 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
41987 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
41988 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
41989 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
41990 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
41991 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
41992 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
41993 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
41994 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
41995 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
41996 & X10)
41997 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
41998 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
41999 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42000 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42001 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42002 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42003 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42004 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42005 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42006 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42007 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42008 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42009 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42010 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42011 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42012 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42013 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42014 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42015 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42016 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42017 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42018 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42019 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42020 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42021 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42022 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42023 & X7)
42024 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42025 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42026 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42027 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42028 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42029 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42030 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42031 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42032 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42033 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42034 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42035 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42036 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42037 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42038 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42039 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42040 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42041 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42042 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42043 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42044 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42045 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42046 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42047 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42048 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42049 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42050 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42051 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42052 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42053 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42054 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42055 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42056 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42057 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42058 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42059 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42060 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42061 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42062 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42063 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42064 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42065 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42066 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42067 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42068 & *X6)
42069 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42070 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42071 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42072 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42073 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42074 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42075 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
42076 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
42077 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
42078 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
42079 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
42080 & X8)
42081 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42082 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
42083 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
42084 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42085 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
42086 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
42087 & X9*X5)
42088 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42089 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
42090 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
42091 & X8*X5)
42092 FM(9,10)=0.5D0*(FMXX+FM(9,10))
42093 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42094 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
42095 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
42096
42097C...Repackage matrix elements.
42098 DO 200 I=1,8
42099 DO 190 J=I,8
42100 RM(I,J)=FM(I,J)
42101 190 CONTINUE
42102 200 CONTINUE
42103 RM(7,7)=FM(7,7)-2D0*FM(9,9)
42104 RM(7,8)=FM(7,8)-2D0*FM(9,10)
42105 RM(8,8)=FM(8,8)-2D0*FM(10,10)
42106
42107C...Produce final result: matrix elements * colours * propagators.
42108 DO 220 I=1,8
42109 DO 210 J=I,8
42110 FAC=8D0
42111 IF(I.EQ.J)FAC=4D0
42112 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
42113 210 CONTINUE
42114 220 CONTINUE
42115 WTQQBH=-WTQQBH/256D0
42116
42117 ELSE
42118C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42119 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
42120 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
42121 & *X6+X8*X7)
42122 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
42123 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
42124 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
42125 & X5)
42126 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
42127 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
42128 & *X9+X4*X8)
42129
42130C...Produce final result: matrix elements * propagators.
42131 A11=A11/DX(7)**2
42132 A12=A12/(DX(7)*DX(8))
42133 A22=A22/DX(8)**2
42134 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
42135 ENDIF
42136
42137 RETURN
42138 END
42139
42140C*********************************************************************
42141
42142C...PYSTBH (and auxiliaries)
42143C.. Evaluates the matrix elements for t + b + H production.
42144
42145 SUBROUTINE PYSTBH(WTTBH)
42146
42147C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42148 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42149 IMPLICIT INTEGER(I-N)
42150 INTEGER PYK,PYCHGE,PYCOMP
42151
42152C...COMMONBLOCKS
42153 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42154 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42155 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42156 COMMON/PYINT1/MINT(400),VINT(400)
42157 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42158 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
42159 COMMON/PYINT4/MWID(500),WIDS(500,5)
42160 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
42161 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42162 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
42163 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
42164 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
42165 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
42166 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42167 DOUBLE PRECISION MW2
42168 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
42169 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
42170
42171C...LOCAL ARRAYS AND COMPLEX VARIABLES
42172 DIMENSION QQ(4,2),PP(4,3)
42173 DATA QQ/8*0D0/
42174
42175 WTTBH=0D0
42176
42177C...KINEMATIC PARAMETERS.
42178 SHPR=SQRT(VINT(26))*VINT(1)
42179 PH=SQRT(VINT(21))*VINT(1)
42180 SPH=PH**2
42181
42182C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
42183 DO 100 I=1,2
42184 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42185 PP(1,I)=PT*COS(VINT(198+5*I))
42186 PP(2,I)=PT*SIN(VINT(198+5*I))
42187 100 CONTINUE
42188 PP(1,3)=-PP(1,1)-PP(1,2)
42189 PP(2,3)=-PP(2,1)-PP(2,2)
42190 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
42191 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
42192 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
42193 PMT3=SQRT(PMS3)
42194 PP(3,3)=PMT3*SINH(VINT(211))
42195 PP(4,3)=PMT3*COSH(VINT(211))
42196 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
42197 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42198 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
42199 PP(3,2)=-PP(3,1)-PP(3,3)
42200 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
42201 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
42202
42203C...CM SYSTEM, INGOING QUARKS/GLUONS
42204 QQ(3,1) = SHPR/2.D0
42205 QQ(4,1) = QQ(3,1)
42206 QQ(3,2) = -QQ(3,1)
42207 QQ(4,2) = QQ(4,1)
42208
42209C...PARAMETERS FOR AMPLITUDE METHOD
42210 ALPHA = AEM
42211 ALPHAS = AS
42212 SW2 = PARU(102)
42213 MW2 = PMAS(24,1)**2
42214 TANB = PARU(141)
42215 VTB = VCKM(3,3)
42216 RMB=PYMRUN(5,VINT(52))
42217
42218 ISUB=MINT(1)
42219
42220 IF (ISUB.EQ.401) THEN
42221 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42222 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42223 ELSE IF (ISUB.EQ.402) THEN
42224 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42225 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42226 END IF
42227
42228 RETURN
42229 END
42230C------------------------------------------------------------------
42231 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
42232C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
42233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42234 IMPLICIT INTEGER(I-N)
42235 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
42236 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42237 SAVE /PYCTBH/
42238
42239C TOP WIDTH CALCULATION
42240C VTB = 0.99
42241 MW=DSQRT(MW2)
42242 XB=(MB/MT)**2
42243 XW=(MW/MT)**2
42244 XH =(MHP/MT)**2
42245 GAMTBH = 0D0
42246 IF (MT .LT. (MHP+MB)) THEN
42247C T ->B W ONLY
42248 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42249 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42250 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42251 GAMT = GAMTBW
42252 ELSE
42253C T ->BW +T ->B H^+
42254 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42255 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42256 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42257C
42258 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
42259 & -4.D0*(MHP*MB/MT**2)**2 )
42260 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
42261 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
42262 GAMT = GAMTBW+GAMTBH
42263 ENDIF
42264C THUS BR IS
42265 BR=GAMTBH/GAMT
42266 RETURN
42267 END
42268
42269C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
42270C GG->TBH^+, QQBAR->TBH^+
42271C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
42272C (FOR INSTANCE WITH PYTHIA)
42273C------------------------------------------------------------
42274C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
42275C PHYS REV. D 60 (1999) 115011
42276C (THESE FILES PREPARED BY J.-L. KNEUR)
42277C------------------------------------------------------------
42278C 1) GG->TBH^+
42279 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42280C
42281C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
42282C
42283C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
42284C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
42285C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
42286C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
42287C "PHYSICAL PARAMETERS" INPUT:
42288C MT,MB TOP AND BOTTOM MASSES;
42289C MHP CHARGED HIGGS MASS
42290C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
42291C
42292C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
42293C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
42294C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
42295C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
42296C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
42297C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
42298C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
42299C
42300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42301 IMPLICIT INTEGER(I-N)
42302 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42303 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42306 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42307
42308 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42309 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42310C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42311C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42312C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42313C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
42314C (TAN BETA) VALUES
42315C
42316C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42317C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42318
42319 PI = 4*DATAN(1.D0)
42320 MW = DSQRT(MW2)
42321C
42322C COLLECTING THE RELEVANT OVERALL FACTORS:
42323C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
42324 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
42325C COUPLING CONSTANT (OVERALL NORMALIZATION)
42326 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42327C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42328C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42329C ALPHAS IS ALPHA_STRONG;
42330C SW2 IS SIN(THETA_W)**2.
42331C
42332C VTB=.998D0
42333C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42334C
42335 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42336 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42337C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42338C
42339C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42340C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42341 DO 100 KK=1,4
42342 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42343 100 CONTINUE
42344C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42345 S = 2*PYTBHS(Q1,Q2)
42346 P1Q1=PYTBHS(Q1,P1)
42347 P1Q2=PYTBHS(P1,Q2)
42348 P2Q1=PYTBHS(P2,Q1)
42349 P2Q2=PYTBHS(P2,Q2)
42350 P1P2=PYTBHS(P1,P2)
42351C
42352C TOP WIDTH CALCULATION
42353 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42354C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42355C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42356 A1INV= S -2*P1Q1 -2*P1Q2
42357 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42358C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42359C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
42360C THE TOP WIDTH
42361 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42362 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42363C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42364C NOW COMES THE AMP**2:
42365C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
42366C THE EXPRESSIONS BELOW
42367 V18=0.D0
42368 A18=0.D0
42369 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
42370 &512*A1*A2*MB*MT/3-
42371 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42372 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
42373 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
42374 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42375 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
42376 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
42377 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
42378 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
42379 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42380 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42381 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
42382 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
42383 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42384 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42385 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
42386 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
42387 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
42388 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
42389 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42390 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
42391 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
42392 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42393 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42394 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42395 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
42396 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42397 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42398 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42399 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42400 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42401 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
42402 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42403 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42404 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
42405 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
42406 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42407 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
42408 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42409 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42410 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
42411 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
42412 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42413 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
42414 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42415 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42416 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42417 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42418 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
42419 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
42420 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42421 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
42422 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42423 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42424 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42425 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42426 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42427 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
42428 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
42429 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
42430 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42431 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42432 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42433 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42434 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42435 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
42436 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42437 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42438 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42439 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
42440 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42441 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
42442 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42443 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42444 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
42445 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42446 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42447 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42448 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
42449 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42450 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42451 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42452 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42453 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42454 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42455 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
42456 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42457 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42458 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
42459 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42460 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42461 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42462 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42463 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42464 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42465 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
42466 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42467 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42468 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42469 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
42470 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42471 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42472 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42473 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42474 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42475 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
42476 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42477 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
42478 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42479 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
42480 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
42481 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42482 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42483 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42484 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42485 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
42486 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42487 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42488 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42489 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42490 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42491 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
42492 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42493 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42494 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42495 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42496 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42497 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
42498 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
42499 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42500 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42501 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42502 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
42503 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42504 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42505 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42506 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42507 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42508 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
42509 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42510 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
42511 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42512 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42513 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
42514 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42515 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42516 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42517 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42518 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42519 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
42520 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42521 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42522 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42523 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42524 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42525 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42526 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42527 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
42528 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42529 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42530 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42531 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42532 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42533 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
42534 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42535 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42536 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42537 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42538 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42539 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42540 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
42541 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42542 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
42543 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42544 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42545 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42546 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42547 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42548 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42549 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42550 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42551 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
42552 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42553 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42554 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
42555 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42556 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42557 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42558 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42559 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42560 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
42561 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42562 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42563 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42564 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
42565 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42566 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42567 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
42568 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42569 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42570 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42571 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42572 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42573 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42574 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42575 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42576 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42577 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42578 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42579 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42580 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42581 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42582 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42583 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42584 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42585 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42586 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42587 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
42588 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42589 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42590 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42591 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42592 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42593 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42594 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42595 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42596 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
42597 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42598 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42599 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42600 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42601 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42602 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42603 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42604 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42605 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
42606 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42607 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42608 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42609 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42610 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42611 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
42612 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42613 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42614 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42615 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42616 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42617 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42618 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42619 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42620 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
42621 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42622 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42623 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42624 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42625 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42626 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42627 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42628 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42629 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42630 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42631 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42632 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42633 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42634 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42635 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42636 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42637 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
42638 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42639 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42640 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42641 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
42642 &384*A12*MB*MT*P1Q1**2/S**2+
42643 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42644 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
42645 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42646 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42647 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42648 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42649 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
42650 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42651 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42652 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42653 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42654 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42655 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42656 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42657 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42658 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
42659 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42660 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
42661 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
42662 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
42663 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
42664 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
42665 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42666 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
42667 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
42668 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
42669 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
42670 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
42671 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
42672 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42673 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
42674 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42675 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
42676 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
42677 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42678 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42679 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
42680 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
42681 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
42682 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
42683 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42684 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42685 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42686 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42687 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
42688 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42689 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
42690 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
42691 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
42692 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
42693 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
42694 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42695 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
42696 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42697 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42698 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42699 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42700 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42701 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42702 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42703 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42704 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42705 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42706 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
42707 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
42708 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
42709 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
42710 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
42711 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
42712 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42713 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42714 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42715 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
42716 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42717 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
42718 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42719 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42720 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42721 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42722 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42723 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42724 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
42725 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42726 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
42727 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42728 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
42729 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42730 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42731 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
42732 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
42733 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42734 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42735 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42736 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42737 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
42738 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42739 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
42740 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42741 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42742 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42743 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
42744 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42745 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
42746 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42747 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
42748 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
42749 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
42750 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42751 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
42752 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
42753 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42754 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42755 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42756 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42757 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42758 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42759 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42760 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42761 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42762 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
42763 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42764 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42765 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42766 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42767 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42768 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42769 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42770 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42771 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42772 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
42773 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42774 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
42775 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42776 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42777 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42778 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42779 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
42780 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
42781 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42782 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
42783 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
42784 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42785 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42786 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
42787 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42788 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42789 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
42790 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42791 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42792 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42793 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
42794 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
42795 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42796 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
42797 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
42798 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42799 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42800 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42801 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42802 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42803 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42804 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
42805 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
42806 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
42807 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42808 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42809 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42810 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42811 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42812 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
42813 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
42814 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42815 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42816 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42817 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
42818 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
42819
42820 V18BIS=
42821 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42822 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42823 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42824 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42825 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42826 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42827 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42828 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42829 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42830 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42831 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
42832 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42833 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42834 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
42835 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42836 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
42837 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
42838 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
42839 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42840 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42841 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42842 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42843 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42844 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42845 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
42846 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
42847 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42848 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42849 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
42850 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
42851 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42852 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
42853 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
42854 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
42855 &272*A1*A2*P1Q1*S/(3*P1Q2)+
42856 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
42857 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42858 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
42859 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42860 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42861 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42862 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42863 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42864 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
42865 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42866 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42867 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
42868 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42869 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
42870 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
42871 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42872 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42873 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
42874 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
42875 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
42876 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42877 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
42878 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42879 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
42880 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42881 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42882 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
42883 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42884 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42885 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
42886 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42887 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
42888 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
42889 &32*A12*P2Q1*S/(3*P1Q1)-
42890 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42891 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
42892 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
42893 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42894 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42895 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42896 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42897 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42898 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
42899 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42900 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42901 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
42902 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42903 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42904 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
42905 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
42906 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
42907 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42908 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
42909 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42910 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42911 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
42912 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42913 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
42914 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42915 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
42916 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42917 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42918 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42919 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42920 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42921 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42922 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42923 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42924 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42925 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42926 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42927 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42928 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42929 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42930 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42931 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42932 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42933 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42934 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42935 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42936 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42937 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42938 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42939 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42940 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42941 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42942 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42943 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42944 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42945 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42946 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42947 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42948 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42949 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42950 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42951 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42952 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42953 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42954 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42955 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42956 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42957 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42958 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42959 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42960 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42961 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42962 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42963 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42964C
42965
42966 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42967 &512*A1*A2*MB*MT/3+
42968 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42969 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42970 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42971 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42972 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42973 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42974 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42975 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42976 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42977 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42978 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
42979 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
42980 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42981 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42982 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
42983 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
42984 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
42985 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
42986 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42987 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
42988 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
42989 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42990 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42991 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42992 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
42993 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42994 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42995 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42996 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42997 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42998 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
42999 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43000 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43001 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43002 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43003 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43004 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43005 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43006 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43007 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43008 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43009 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43010 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43011 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43012 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43013 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43014 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43015 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43016 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43017 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43018 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43019 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43020 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43021 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43022 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43023 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43024 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43025 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43026 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43027 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43028 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43029 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43030 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43031 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43032 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43033 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43034 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43035 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43036 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43037 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43038 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43039 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43040 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43041 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43042 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43043 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43044 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43045 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43046 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43047 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43048 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43049 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43050 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43051 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43052 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43053 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43054 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43055 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43056 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43057 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43058 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43059 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43060 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43061 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43062 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43063 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43064 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43065 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43066 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43067 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43068 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43069 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43070 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43071 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43072 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43073 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43074 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43075 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43076 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
43077 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
43078 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43079 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43080 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43081 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43082 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
43083 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43084 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43085 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43086 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43087 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43088 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
43089 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43090 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43091 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43092 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43093 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43094 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
43095 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
43096 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43097 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43098 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43099 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
43100 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43101 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43102 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43103 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43104 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43105 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
43106 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43107 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
43108 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43109 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43110 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
43111 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43112 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43113 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43114 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43115 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43116 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43117 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43118 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43119 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43120 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43121 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
43122 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43123 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43124 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
43125 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43126 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43127 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
43128 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43129 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43130 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
43131 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43132 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43133 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
43134 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43135 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43136 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43137 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
43138 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43139 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
43140 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43141 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43142 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43143 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43144 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43145 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43146 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43147 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43148 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43149 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43150 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43151 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43152 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43153 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43154 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43155 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43156 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43157 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
43158 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43159 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43160 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43161 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
43162 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43163 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43164 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
43165 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43166 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43167 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43168 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43169 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43170 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43171 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43172 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43173 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43174 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43175 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43176 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43177 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43178 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
43179 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43180 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43181 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43182 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43183 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43184 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
43185 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43186 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43187 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43188 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43189 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43190 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43191 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43192 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43193 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
43194 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43195 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43196 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43197 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43198 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43199 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43200 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43201 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43202 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
43203 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43204 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43205 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43206 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43207 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43208 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
43209 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43210 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43211 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
43212 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43213 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43214 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43215 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43216 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43217 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
43218 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43219 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43220 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43221 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43222 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43223 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43224 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43225 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43226 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
43227 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43228 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43229 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43230 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43231 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43232 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43233 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43234 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
43235 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43236 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43237 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43238 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
43239 &384*A12*MB*MT*P1Q1**2/S**2+
43240 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43241 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
43242 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43243 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43244 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43245 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43246 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
43247 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43248 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43249 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43250 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43251 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43252 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43253 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43254 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
43255 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
43256 &384*A2**2*MB*MT*P2Q2**2/S**2+
43257 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43258 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
43259 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
43260 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
43261 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
43262 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
43263 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43264 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
43265 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
43266 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
43267 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
43268 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
43269 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
43270 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43271 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
43272 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43273 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
43274 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43275 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43276 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
43277 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
43278 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
43279 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
43280 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43281 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43282 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43283 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43284 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
43285 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43286 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
43287 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
43288 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
43289 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
43290 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
43291 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43292 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
43293 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43294 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
43295 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43296 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43297 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43298 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
43299 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43300 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43301 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43302 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43303 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
43304 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
43305 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
43306 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
43307 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
43308 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43309 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43310 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43311 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
43312 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43313 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
43314 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43315 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43316 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43317 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43318 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43319 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43320 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
43321 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43322 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
43323 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43324 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
43325 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43326 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43327 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
43328 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
43329 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43330 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43331 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43332 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43333 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
43334 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43335 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
43336 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43337 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
43338 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43339 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
43340 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43341 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
43342 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43343 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
43344 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
43345 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
43346 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43347 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
43348 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
43349 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43350 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43351 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43352 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43353 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
43354 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43355 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43356 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
43357 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
43358 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
43359 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43360 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43361 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43362 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43363 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43364 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43365 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43366 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43367 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43368 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
43369 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43370 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
43371 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43372 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43373 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
43374 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
43375 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43376 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
43377 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43378 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
43379 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
43380 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43381 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43382 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
43383 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43384 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43385 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
43386 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43387 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43388 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43389 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
43390 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
43391 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43392 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
43393 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43394 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43395 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43396 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43397 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43398 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43399 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
43400 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
43401 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
43402 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43403 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43404 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43405 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
43406 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43407 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
43408 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
43409 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43410 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43411 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43412 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43413 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43414 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43415 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43416 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43417 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43418 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43419 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43420 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
43421 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43422 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43423 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43424 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
43425 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43426 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43427 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
43428 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43429 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
43430 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
43431 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43432 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43433 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43434 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43435 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43436 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43437 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
43438 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
43439 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43440 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43441 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
43442 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
43443 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43444 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
43445 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
43446 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
43447 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
43448 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43449 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
43450
43451 A18BIS=
43452 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43453 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43454 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43455 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43456 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43457 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
43458 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43459 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43460 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
43461 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43462 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
43463 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
43464 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43465 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43466 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
43467 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
43468 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
43469 &12*S/(P1Q2*P2Q1)+
43470 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43471 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
43472 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43473 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
43474 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43475 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43476 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43477 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43478 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43479 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
43480 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43481 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
43482 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
43483 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43484 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
43485 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
43486 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
43487 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43488 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43489 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43490 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43491 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43492 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
43493 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43494 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43495 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
43496 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43497 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43498 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
43499 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
43500 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43501 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
43502 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43503 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43504 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
43505 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43506 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
43507 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43508 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
43509 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43510 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43511 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43512 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43513 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43514 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
43515 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
43516 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43517 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
43518 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
43519 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43520 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43521 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43522 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43523 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43524 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43525 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43526 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43527 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43528 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43529 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43530 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43531 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
43532 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
43533 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
43534 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43535 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
43536 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43537 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43538 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43539 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43540 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43541 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43542 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43543 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
43544 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43545 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43546 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43547 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
43548 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
43549 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43550 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43551 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
43552 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
43553 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43554 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43555 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43556C
43557 V18=V18+V18BIS
43558 A18=A18+A18BIS
43559 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
43560 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
43561 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43562 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43563 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43564 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
43565 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43566 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43567 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43568 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43569 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43570 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43571 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
43572 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
43573 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
43574 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
43575 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
43576 V910=V910+96*A1*A2*P1P2*P2Q1/S-
43577 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43578 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
43579 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
43580 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43581 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43582C
43583 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
43584 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
43585 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43586 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43587 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43588 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
43589 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43590 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43591 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
43592 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43593 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43594 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43595 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
43596 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
43597 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
43598 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
43599 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
43600 A910=A910+96*A1*A2*P1P2*P2Q1/S-
43601 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43602 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
43603 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
43604 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43605 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43606C
43607C FINAL RESULT;
43608C
43609 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
43610
43611 END
43612C---------------------------------------------------------
43613C 2) Q QBAR ->TBH^+
43614 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43615C
43616C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
43617C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
43618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43619 IMPLICIT INTEGER(I-N)
43620 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43621 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43623 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43624 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43625 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43626 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43627C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43628C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43629C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43630C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
43631C
43632C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43633C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43634C
43635 DIMENSION YY(2,2)
43636
43637 PI = 4*DATAN(1.D0)
43638 MW = DSQRT(MW2)
43639
43640C COLLECTING THE RELEVANT OVERALL FACTORS:
43641C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
43642 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
43643C COUPLING CONSTANT (OVERALL NORMALIZATION)
43644 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43645C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43646C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43647C ALPHAS IS ALPHA_STRONG;
43648C SW2 IS SIN(THETA_W)**2.
43649C
43650C VTB=.998D0
43651C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43652C
43653 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43654 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43655C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43656C
43657C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43658C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43659 DO 100 KK=1,4
43660 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43661 100 CONTINUE
43662C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43663 S = 2*PYTBHS(Q1,Q2)
43664 P1Q1=PYTBHS(Q1,P1)
43665 P1Q2=PYTBHS(P1,Q2)
43666 P2Q1=PYTBHS(P2,Q1)
43667 P2Q2=PYTBHS(P2,Q2)
43668 P1P2=PYTBHS(P1,P2)
43669C
43670C TOP WIDTH CALCULATION
43671 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43672C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43673C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43674 A1INV= S -2*P1Q1 -2*P1Q2
43675 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43676C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43677C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
43678 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43679 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43680C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43681C NOW COMES THE AMP**2:
43682C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
43683C THE EXPRESSIONS BELOW
43684 YY(1, 1) = -16*A**2*A2**2*MB*MT+
43685 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
43686 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
43687 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
43688 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43689 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43690 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
43691 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
43692 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
43693 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
43694 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
43695 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
43696 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
43697 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
43698 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43699 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43700 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
43701 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
43702 &32*A2**2*MB**2*P1P2*V**2/S+
43703 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
43704 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
43705 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
43706 YY(1, 1)=2*YY(1, 1)
43707
43708 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
43709 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
43710 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43711 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43712 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
43713 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
43714 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
43715 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43716 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
43717 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43718 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
43719 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43720 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
43721 &64*A**2*A1*A2*MB*MT*P1P2/S+
43722 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
43723 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
43724 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
43725 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
43726 &64*A**2*A1*A2*P1Q1*P2Q1/S-
43727 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
43728 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
43729 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
43730 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
43731 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
43732 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
43733 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
43734 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
43735 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
43736 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
43737 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
43738 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43739 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43740 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
43741 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
43742 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
43743 &32*A1*A2*P1P2*P1Q1*V**2/S+
43744 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
43745 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
43746 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
43747 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
43748
43749
43750 YY(2, 2) =-16*A**2*A12*MB*MT+
43751 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
43752 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
43753 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
43754 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
43755 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
43756 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
43757 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
43758 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
43759 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
43760 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
43761 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
43762 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
43763 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
43764 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
43765 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
43766 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
43767 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
43768 &32*A12*MT**2*P2Q2*V**2/S-
43769 &32*A12*P1Q2*P2Q2*V**2/S
43770 YY(2, 2)=2*YY(2, 2)
43771
43772 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
43773 AMP2= FACT*PS*VTB**2*RES
43774
43775 END
43776C=====================================================================
43777C ************* FUNCTION SCALAR PRODUCTS *************************
43778 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
43779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43780 IMPLICIT INTEGER(I-N)
43781 DIMENSION A(4),B(4)
43782 DUM=A(4)*B(4)
43783 DO 100 ID=1,3
43784 DUM=DUM-A(ID)*B(ID)
43785 100 CONTINUE
43786 PYTBHS=DUM
43787 RETURN
43788 END
43789
43790C*********************************************************************
43791
43792C...PYMSIN
43793C...Initializes supersymmetry: finds sparticle masses and
43794C...branching ratios and stores this information.
43795C...AUTHOR: STEPHEN MRENNA
43796C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
43797
43798 SUBROUTINE PYMSIN
43799
43800C...Double precision and integer declarations.
43801 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43802 IMPLICIT INTEGER(I-N)
43803 INTEGER PYK,PYCHGE,PYCOMP
43804C...Parameter statement to help give large particle numbers.
43805 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43806 &KEXCIT=4000000,KDIMEN=5000000)
43807C...Commonblocks.
43808 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43809 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43810 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43811 COMMON/PYDAT4/CHAF(500,2)
43812 CHARACTER CHAF*16
43813 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43814 COMMON/PYINT4/MWID(500),WIDS(500,5)
43815 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43816 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43817 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43818 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43819 COMMON/PYHTRI/HHH(7)
43820 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
43821 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
43822 &/PYMSSM/,/PYMSRV/,/PYSSMT/
43823
43824C...Local variables.
43825 DOUBLE PRECISION ALFA,BETA
43826 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
43827 INTEGER I,J,J1,I1,K1
43828 INTEGER KC,LKNT,IDLAM(400,3)
43829 DOUBLE PRECISION XLAM(0:400)
43830 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
43831 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
43832 DOUBLE PRECISION DELM,XMDIF
43833 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
43834 DOUBLE PRECISION ARG,SGNMU,R
43835 INTEGER IMSSM
43836 INTEGER IRPRTY
43837 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
43838 SAVE MWIDSU,MDCYSU
43839 DATA KFSUSY/
43840 &1000001,2000001,1000002,2000002,1000003,2000003,
43841 &1000004,2000004,1000005,2000005,1000006,2000006,
43842 &1000011,2000011,1000012,2000012,1000013,2000013,
43843 &1000014,2000014,1000015,2000015,1000016,2000016,
43844 &1000021,1000022,1000023,1000025,1000035,1000024,
43845 &1000037,1000039, 25, 35, 36, 37,
43846 & 6, 24, 45, 46,1000045, 9*0/
43847 DATA INIT/0/
43848
43849C...Automatically read QNUMBERS, MASS, and DECAY tables
43850 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
43851 NQNUM=0
43852 CALL PYSLHA(0,0,IFAIL)
43853 CALL PYSLHA(5,0,IFAIL)
43854 ENDIF
43855 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
43856
43857C...Do nothing further if SUSY not requested
43858 IMSSM=IMSS(1)
43859 IF(IMSSM.EQ.0) RETURN
43860
43861C...Save copy of MWID(KC) and MDCY(KC,1) values before
43862C...they are set to zero for the LSP.
43863 IF(INIT.EQ.0) THEN
43864 INIT=1
43865 DO 100 I=1,36
43866 KF=KFSUSY(I)
43867 KC=PYCOMP(KF)
43868 MWIDSU(I)=MWID(KC)
43869 MDCYSU(I)=MDCY(KC,1)
43870 100 CONTINUE
43871 ENDIF
43872
43873C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
43874 DO 110 I=1,36
43875 KF=KFSUSY(I)
43876 KC=PYCOMP(KF)
43877 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
43878 MWID(KC)=MWIDSU(I)
43879 MDCY(KC,1)=MDCYSU(I)
43880 ENDIF
43881 110 CONTINUE
43882
43883C...First part of routine: set masses and couplings.
43884
43885C...Reset mixing values in sfermion sector to pure left/right.
43886 DO 120 I=1,16
43887 SFMIX(I,1)=1D0
43888 SFMIX(I,4)=1D0
43889 SFMIX(I,2)=0D0
43890 SFMIX(I,3)=0D0
43891 120 CONTINUE
43892
43893C...Add NMSSM states if NMSSM switched on, and change old names.
43894 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
43895C... Switch on NMSSM
43896 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
43897
43898 KFN=25
43899 KCN=KFN
43900 CHAF(KCN,1)='h_10'
43901 CHAF(KCN,2)=' '
43902
43903 KFN=35
43904 KCN=KFN
43905 CHAF(KCN,1)='h_20'
43906 CHAF(KCN,2)=' '
43907
43908 KFN=45
43909 KCN=KFN
43910 CHAF(KCN,1)='h_30'
43911 CHAF(KCN,2)=' '
43912
43913 KFN=36
43914 KCN=KFN
43915 CHAF(KCN,1)='A_10'
43916 CHAF(KCN,2)=' '
43917
43918 KFN=46
43919 KCN=KFN
43920 CHAF(KCN,1)='A_20'
43921 CHAF(KCN,2)=' '
43922
43923 KFN=1000045
43924 KCN=PYCOMP(KFN)
43925 IF (KCN.EQ.0) THEN
43926 DO 123 KCT=100,MSTU(6)
43927 IF(KCHG(KCT,4).GT.100) KCN=KCT
43928 123 CONTINUE
43929 KCN=KCN+1
43930 KCHG(KCN,4)=KFN
43931 MSTU(20)=0
43932 ENDIF
43933C... Set stable for now
43934 PMAS(KCN,2)=1D-6
43935 MWID(KCN)=0
43936 MDCY(KCN,1)=0
43937 MDCY(KCN,2)=0
43938 MDCY(KCN,3)=0
43939 CHAF(KCN,1)='~chi_50'
43940 CHAF(KCN,2)=' '
43941 ENDIF
43942
43943C...Read spectrum from SLHA file.
43944 IF (IMSSM.EQ.11) THEN
43945 CALL PYSLHA(1,0,IFAIL)
43946 ENDIF
43947
43948C...Common couplings.
43949 TANB=RMSS(5)
43950 BETA=ATAN(TANB)
43951 COSB=COS(BETA)
43952 SINB=TANB*COSB
43953 COS2B=COS(2D0*BETA)
43954 ALFA=RMSS(18)
43955 XMW2=PMAS(24,1)**2
43956 XMZ2=PMAS(23,1)**2
43957 XW=PARU(102)
43958
43959C...Define sparticle masses for a general MSSM simulation.
43960 IF(IMSSM.EQ.1) THEN
43961 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43962 DO 130 I=1,5,2
43963 KC=PYCOMP(KSUSY1+I)
43964 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43965 KC=PYCOMP(KSUSY2+I)
43966 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43967 KC=PYCOMP(KSUSY1+I+1)
43968 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43969 KC=PYCOMP(KSUSY2+I+1)
43970 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43971 130 CONTINUE
43972 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43973 IF(XARG.LT.0D0) THEN
43974 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43975 & ' FROM THE SUM RULE. '
43976 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
43977 RETURN
43978 ELSE
43979 XARG=SQRT(XARG)
43980 ENDIF
43981 DO 140 I=11,15,2
43982 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
43983 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
43984 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
43985 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
43986 140 CONTINUE
43987 IF(IMSS(8).EQ.1) THEN
43988 RMSS(13)=RMSS(6)
43989 RMSS(14)=RMSS(7)
43990 ENDIF
43991
43992C...Alternatively derive masses from SUGRA relations.
43993 ELSEIF(IMSSM.EQ.2) THEN
43994 RMSS(36)=RMSS(16)
43995 CALL PYAPPS
43996C...Or use ISASUSY
43997 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
43998 RMSS(36)=RMSS(16)
43999 CALL PYSUGI
44000 ALFA=RMSS(18)
44001 GOTO 170
44002 ELSE
44003 GOTO 170
44004 ENDIF
44005
44006C...Add in extra D-term contributions.
44007 IF(IMSS(7).EQ.1) THEN
44008 R=0.43D0
44009 DX=RMSS(23)
44010 DY=RMSS(24)
44011 DS=RMSS(25)
44012 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44013 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44014 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44015 WRITE(MSTU(11),*) 'C DX = ',DX
44016 WRITE(MSTU(11),*) 'C DY = ',DY
44017 WRITE(MSTU(11),*) 'C DS = ',DS
44018 WRITE(MSTU(11),*) 'C '
44019 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44020 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44021 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44022 DQ2=DY/6D0-DX/3D0-DS/3D0
44023 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44024 DD2=DY/3D0+DX-2D0*DS/3D0
44025 DL2=-DY/2D0+DX-2D0*DS/3D0
44026 DE2=DY-DX/3D0-DS/3D0
44027 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44028 DHD2=-DY/2D0-2D0*DX/3D0+DS
44029 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44030 & /ABS(COS2B)
44031 DMA2 = 2D0*DMU2+DHU2+DHD2
44032 DO 150 I=1,5,2
44033 KC=PYCOMP(KSUSY1+I)
44034 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44035 KC=PYCOMP(KSUSY2+I)
44036 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44037 KC=PYCOMP(KSUSY1+I+1)
44038 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44039 KC=PYCOMP(KSUSY2+I+1)
44040 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44041 150 CONTINUE
44042 DO 160 I=11,15,2
44043 KC=PYCOMP(KSUSY1+I)
44044 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44045 KC=PYCOMP(KSUSY2+I)
44046 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44047 KC=PYCOMP(KSUSY1+I+1)
44048 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44049 160 CONTINUE
44050 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44051 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44052 CALL PYSTOP(104)
44053 ENDIF
44054 SGNMU=SIGN(1D0,RMSS(4))
44055 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44056 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44057 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44058 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44059 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44060 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44061 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44062 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44063 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44064 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44065 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44066 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44067 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44068 CALL PYSTOP(104)
44069 ENDIF
44070 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44071 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44072 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44073 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44074 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44075 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
44076 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
44077 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
44078 ENDIF
44079
44080C...Fix the third generation sfermions.
44081 CALL PYTHRG
44082
44083C...Fix the neutralino--chargino--gluino sector.
44084 CALL PYINOM
44085
44086C...Fix the Higgs sector.
44087 CALL PYHGGM(ALFA)
44088
44089C...Choose the Gunion-Haber convention.
44090 ALFA=-ALFA
44091 RMSS(18)=ALFA
44092
44093C...Print information on mass parameters.
44094 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
44095 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44096 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44097 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
44098 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
44099 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
44100 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
44101 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
44102 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
44103 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
44104 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44105 ENDIF
44106 IF(IMSS(20).EQ.1) THEN
44107 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44108 WRITE(MSTU(11),*) ' DEBUG MODE '
44109 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
44110 & UMIX(2,1),UMIX(2,2)
44111 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
44112 & UMIXI(2,1),UMIXI(2,2)
44113 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
44114 & VMIX(2,1),VMIX(2,2)
44115 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
44116 & VMIXI(2,1),VMIXI(2,2)
44117 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
44118 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
44119 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
44120 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
44121 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
44122 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
44123 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
44124 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
44125 WRITE(MSTU(11),*) ' ALFA = ',ALFA
44126 WRITE(MSTU(11),*) ' BETA = ',BETA
44127 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
44128 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
44129 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44130 ENDIF
44131
44132C...Set up the Higgs couplings - needed here since initialization
44133C...in PYINRE did not yet occur when PYWIDT is called below.
44134 170 AL=ALFA
44135 BE=BETA
44136 SINA=SIN(AL)
44137 COSA=COS(AL)
44138 COSB=COS(BE)
44139 SINB=TANB*COSB
44140 SBMA=SIN(BE-AL)
44141 SAPB=SIN(AL+BE)
44142 CAPB=COS(AL+BE)
44143 CBMA=COS(BE-AL)
44144 C2A=COS(2D0*AL)
44145 C2B=COSB**2-SINB**2
44146C...tanb (used for H+)
44147 PARU(141)=TANB
44148
44149C...Firstly: h
44150C...Coupling to d-type quarks
44151 PARU(161)=SINA/COSB
44152C...Coupling to u-type quarks
44153 PARU(162)=-COSA/SINB
44154C...Coupling to leptons
44155 PARU(163)=PARU(161)
44156C...Coupling to Z
44157 PARU(164)=SBMA
44158C...Coupling to W
44159 PARU(165)=PARU(164)
44160
44161C...Secondly: H
44162C...Coupling to d-type quarks
44163 PARU(171)=-COSA/COSB
44164C...Coupling to u-type quarks
44165 PARU(172)=-SINA/SINB
44166C...Coupling to leptons
44167 PARU(173)=PARU(171)
44168C...Coupling to Z
44169 PARU(174)=CBMA
44170C...Coupling to W
44171 PARU(175)=PARU(174)
44172C...Coupling to h
44173 IF(IMSS(4).GE.2) THEN
44174 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
44175 ELSE
44176 HHH(3)=HHH(3)+HHH(4)+HHH(5)
44177 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
44178 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
44179 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
44180 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
44181 ENDIF
44182C...Coupling to H+
44183C...Define later
44184 IF(IMSS(4).GE.2) THEN
44185 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
44186 ELSE
44187 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
44188 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
44189 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
44190 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
44191 ENDIF
44192C...Coupling to A
44193 IF(IMSS(4).GE.2) THEN
44194 PARU(177)=COS(2D0*BE)*COS(BE+AL)
44195 ELSE
44196 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
44197 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
44198 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
44199 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
44200 ENDIF
44201C...Coupling to H+
44202 IF(IMSS(4).GE.2) THEN
44203 PARU(178)=PARU(177)
44204 ELSE
44205 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
44206 ENDIF
44207C...Thirdly, A
44208C...Coupling to d-type quarks
44209 PARU(181)=TANB
44210C...Coupling to u-type quarks
44211 PARU(182)=1D0/PARU(181)
44212C...Coupling to leptons
44213 PARU(183)=PARU(181)
44214 PARU(184)=0D0
44215 PARU(185)=0D0
44216C...Coupling to Z h
44217 PARU(186)=COS(BE-AL)
44218C...Coupling to Z H
44219 PARU(187)=SIN(BE-AL)
44220 PARU(188)=0D0
44221 PARU(189)=0D0
44222 PARU(190)=0D0
44223
44224C...Finally: H+
44225C...Coupling to W h
44226 PARU(195)=COS(BE-AL)
44227
44228C...Tell that all Higgs couplings have been set.
44229 MSTP(4)=1
44230
44231C...Set R-Violating couplings.
44232C...Set lambda couplings to common value or "natural values".
44233 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
44234 VIR3=1D0/(126D0)**3
44235 DO 200 IRK=1,3
44236 DO 190 IRI=1,3
44237 DO 180 IRJ=1,3
44238 IF (IRI.NE.IRJ) THEN
44239 IF (IRI.LT.IRJ) THEN
44240 RVLAM(IRI,IRJ,IRK)=RMSS(51)
44241 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
44242 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
44243 & PMAS(9+2*IRK,1)*VIR3)
44244 ELSE
44245 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
44246 ENDIF
44247 ELSE
44248 RVLAM(IRI,IRJ,IRK)=0D0
44249 ENDIF
44250 180 CONTINUE
44251 190 CONTINUE
44252 200 CONTINUE
44253 ENDIF
44254C...Set lambda' couplings to common value or "natural values".
44255 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
44256 VIR3=1D0/(126D0)**3
44257 DO 230 IRI=1,3
44258 DO 220 IRJ=1,3
44259 DO 210 IRK=1,3
44260 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
44261 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
44262 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
44263 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
44264 210 CONTINUE
44265 220 CONTINUE
44266 230 CONTINUE
44267 ENDIF
44268C...Set lambda'' couplings to common value or "natural values".
44269 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
44270 VIR3=1D0/(126D0)**3
44271 DO 260 IRI=1,3
44272 DO 250 IRJ=1,3
44273 DO 240 IRK=1,3
44274 IF (IRJ.NE.IRK) THEN
44275 IF (IRJ.LT.IRK) THEN
44276 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
44277 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
44278 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
44279 & PMAS(2*IRK-1,1)*VIR3)
44280 ELSE
44281 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
44282 ENDIF
44283 ELSE
44284 RVLAMB(IRI,IRJ,IRK) = 0D0
44285 ENDIF
44286 240 CONTINUE
44287 250 CONTINUE
44288 260 CONTINUE
44289 ENDIF
44290
44291C...Antisymmetrize couplings set by user
44292 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
44293 DO 290 IRI=1,3
44294 DO 280 IRJ=1,3
44295 DO 270 IRK=1,3
44296 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
44297 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
44298 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
44299 ENDIF
44300 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
44301 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
44302 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
44303 ENDIF
44304 270 CONTINUE
44305 280 CONTINUE
44306 290 CONTINUE
44307 ENDIF
44308
44309C...Write spectrum to SLHA file
44310 IF (IMSS(23).NE.0) THEN
44311 IFAIL=0
44312 CALL PYSLHA(3,0,IFAIL)
44313 ENDIF
44314
44315C...Second part of routine: set decay modes and branching ratios.
44316
44317C...Allow chi10 -> gravitino + gamma or not.
44318 KC=PYCOMP(KSUSY1+39)
44319 IF( IMSS(11) .NE. 0 ) THEN
44320 PMAS(KC,1)=RMSS(21)/1D9
44321 PMAS(KC,2)=0D0
44322 IRPRTY=0
44323 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
44324 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
44325 IRPRTY=0
44326 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
44327 & ' ALLOWING SUSY LLE DECAYS'
44328 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
44329 & ' ALLOWING SUSY LQD DECAYS'
44330 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
44331 & ' ALLOWING SUSY UDD DECAYS'
44332 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
44333 & ' --- Warning: R-Violating couplings possibly',
44334 & ' incompatible with proton decay'
44335 ELSE
44336 PMAS(KC,1)=9999D0
44337 IRPRTY=1
44338 ENDIF
44339
44340C...Loop over sparticle and Higgs species.
44341 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
44342C...Find the LSP or NLSP for a gravitino LSP
44343 ILSP=0
44344 PMLSP=1D20
44345 DO 300 I=1,36
44346 KF=KFSUSY(I)
44347 IF(KF.EQ.1000039) GOTO 300
44348 KC=PYCOMP(KF)
44349 IF(PMAS(KC,1).LT.PMLSP) THEN
44350 ILSP=I
44351 PMLSP=PMAS(KC,1)
44352 ENDIF
44353 300 CONTINUE
44354 DO 370 I=1,50
44355 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
44356 KF=KFSUSY(I)
44357 IF (KF.EQ.0) GOTO 370
44358 KC=PYCOMP(KF)
44359 LKNT=0
44360
44361C...Check if there are any decays listed for this sparticle
44362C...in a file
44363 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
44364 IFAIL=0
44365 CALL PYSLHA(2,KF,IFAIL)
44366 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
44367 ELSEIF (I.GE.37) THEN
44368 GOTO 370
44369 ENDIF
44370
44371C...Sfermion decays.
44372 IF(I.LE.24) THEN
44373C...First check to see if sneutrino is lighter than chi10.
44374 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
44375 & PMAS(KC,1).LT.PMCHI1) THEN
44376 ELSE
44377 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
44378 ENDIF
44379
44380C...Gluino decays.
44381 ELSEIF(I.EQ.25) THEN
44382 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
44383 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
44384
44385C...Neutralino decays.
44386 ELSEIF(I.GE.26.AND.I.LE.29) THEN
44387 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
44388C...chi10 stable or chi10 -> gravitino + gamma.
44389 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
44390 PMAS(KC,2)=1D-6
44391 MDCY(KC,1)=0
44392 MWID(KC)=0
44393 ENDIF
44394
44395C...Chargino decays.
44396 ELSEIF(I.GE.30.AND.I.LE.31) THEN
44397 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
44398
44399C...Gravitino is stable.
44400 ELSEIF(I.EQ.32) THEN
44401 MDCY(KC,1)=0
44402 MWID(KC)=0
44403
44404C...Higgs decays.
44405 ELSEIF(I.GE.33.AND.I.LE.36) THEN
44406C...Calculate decays to non-SUSY particles.
44407 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
44408 LKNT=0
44409 DO 310 I1=0,100
44410 XLAM(I1)=0D0
44411 310 CONTINUE
44412 DO 330 I1=1,MDCY(KC,3)
44413 K1=MDCY(KC,2)+I1-1
44414 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
44415 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
44416 XLAM(I1)=WDTP(I1)
44417 XLAM(0)=XLAM(0)+XLAM(I1)
44418 DO 320 J1=1,3
44419 IDLAM(I1,J1)=KFDP(K1,J1)
44420 320 CONTINUE
44421 LKNT=LKNT+1
44422 330 CONTINUE
44423C...Add the decays to SUSY particles.
44424 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
44425 ENDIF
44426C...Zero the branching ratios for use in loop mode
44427C...thanks to K. Matchev (FNAL)
44428 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44429 BRAT(IDC)=0D0
44430 340 CONTINUE
44431
44432C...Set stable particles.
44433 IF(LKNT.EQ.0) THEN
44434 MDCY(KC,1)=0
44435 MWID(KC)=0
44436 PMAS(KC,2)=1D-6
44437 PMAS(KC,3)=1D-5
44438 PMAS(KC,4)=0D0
44439
44440C...Store branching ratios in the standard tables.
44441 ELSE
44442 IDC=MDCY(KC,2)+MDCY(KC,3)-1
44443 DELM=1D6
44444 DO 360 IL=1,LKNT
44445 IDCSV=IDC
44446 350 IDC=IDC+1
44447 BRAT(IDC)=0D0
44448 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
44449 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
44450 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
44451 BRAT(IDC)=XLAM(IL)/XLAM(0)
44452 XMDIF=PMAS(KC,1)
44453 IF(MDME(IDC,1).GE.1) THEN
44454 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
44455 & PMAS(PYCOMP(KFDP(IDC,2)),1)
44456 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
44457 & PMAS(PYCOMP(KFDP(IDC,3)),1)
44458 ENDIF
44459 IF(I.LE.32) THEN
44460 IF(XMDIF.GE.0D0) THEN
44461 DELM=MIN(DELM,XMDIF)
44462 ELSE
44463 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
44464 WRITE(MSTU(11),*) ' KF = ',KF
44465 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
44466 ENDIF
44467 ENDIF
44468 GOTO 360
44469 ELSEIF(IDC.EQ.IDCSV) THEN
44470 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
44471 & 'channel not recognized:'
44472 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
44473 GOTO 360
44474 ELSE
44475 GOTO 350
44476 ENDIF
44477 360 CONTINUE
44478
44479C...Store width, cutoff and lifetime.
44480 PMAS(KC,2)=XLAM(0)
44481 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
44482 PMAS(KC,3)=PMAS(KC,2)*10D0
44483 ELSE
44484 PMAS(KC,3)=0.95D0*DELM
44485 ENDIF
44486 IF(PMAS(KC,2).NE.0D0) THEN
44487 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
44488 ENDIF
44489C...Write decays to SLHA file
44490 IF (IMSS(24).NE.0) THEN
44491 IFAIL=0
44492 CALL PYSLHA(4,KF,IFAIL)
44493 ENDIF
44494
44495 ENDIF
44496 370 CONTINUE
44497
44498 RETURN
44499 END
44500C*********************************************************************
44501
44502C...PYSLHA
44503C...Read/write spectrum or decay data from SLHA standard file(s).
44504C...P. Skands
44505
44506C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
44507C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
44508C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
44509C... (KFORIG=0 : read all decay tables)
44510C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
44511C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
44512C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
44513C... (KFORIG=0 : read all MASS entries)
44514
44515C...Recent updates:
44516C...17 Sep 2007: introduced /PYQNUM/ for QNUMBERS storage
44517C... : Corrected QNUMBERS name-formation; root only until space
44518 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
44519
44520C...Double precision and integer declarations.
44521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44522 IMPLICIT INTEGER(I-N)
44523 INTEGER PYK,PYCHGE,PYCOMP
44524 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44525 &KEXCIT=4000000,KDIMEN=5000000)
44526C...Commonblocks.
44527 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44528 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44529 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44530 COMMON/PYDAT4/CHAF(500,2)
44531 CHARACTER CHAF*16
44532 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44533 CHARACTER*40 ISAVER,VISAJE
44534 COMMON/PYINT4/MWID(500),WIDS(500,5)
44535 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
44536C...SUSY blocks
44537 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44538 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44539 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44540 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44541 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
44542
44543C...Local arrays, character variables and data.
44544 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
44545 & AU(3,3),AD(3,3),AE(3,3)
44546 COMMON/PYLH3C/CPRO(2),CVER(2)
44547C...The common block of new states (QNUMBERS / PARTICLE)
44548 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44549C...- NQNUM : Number of QNUMBERS blocks that have been read in
44550C...- KQNUM(I,0) : KF of new state
44551C...- KQNUM(I,1) : 3 times electric charge
44552C...- KQNUM(I,2) : Number of spin states: (2S + 1)
44553C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
44554C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
44555C...- KQNUM(I,5:9) : space available for further quantum numbers
44556 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
44557 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
44558C...MMOD: flags to set for each block read in.
44559C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
44560C...MSPC: Flags to set for each block read in.
44561C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
44562C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
44563C...11: AD 12: AE 13: YU 14: YD 15: YE
44564C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
44565 CHARACTER CPRO*12,CVER*12,CHNLIN*6
44566 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
44567 CHARACTER CHINL*120,CHKF*9,CHTMP*16
44568 INTEGER VERBOS
44569 SAVE VERBOS
44570C...Date of last Change
44571 PARAMETER (DOC='05 Nov 2007')
44572C...Local arrays and initial values
44573 DIMENSION IDC(5),KFSUSY(50)
44574 SAVE KFSUSY
44575 DATA NQNUM /0/
44576 DATA NDECAY /0/
44577 DATA VERBOS /1/
44578 DATA NHELLO /0/
44579 DATA MLHEF /0/
44580 DATA MLHEFD /0/
44581 DATA KFSUSY/
44582 &1000001,1000002,1000003,1000004,1000005,1000006,
44583 &2000001,2000002,2000003,2000004,2000005,2000006,
44584 &1000011,1000012,1000013,1000014,1000015,1000016,
44585 &2000011,2000012,2000013,2000014,2000015,2000016,
44586 &1000021,1000022,1000023,1000025,1000035,1000024,
44587 &1000037,1000039, 25, 35, 36, 37,
44588 & 6, 24, 45, 46,1000045, 9*0/
44589 DATA KFDEC/100*0/
44590 RMFUN(IP)=PMAS(PYCOMP(IP),1)
44591
44592C...Shorthand for spectrum and decay table unit numbers
44593 IMSS21=IMSS(21)
44594 IMSS22=IMSS(22)
44595
44596C...Default for LHEF input: read header information
44597 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
44598 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
44599 IF (IMSS21.EQ.MSTP(161)) MLHEF=1
44600 IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
44601
44602C...Hello World
44603 IF (NHELLO.EQ.0) THEN
44604 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
44605 WRITE(MSTU(11),5000) DOC
44606 NHELLO=1
44607 ENDIF
44608 ENDIF
44609
44610C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
44611C...+MUPDA).
44612 LFN=IMSS21
44613 IF (MUPDA.EQ.2) LFN=IMSS22
44614 IF (MUPDA.EQ.3) LFN=IMSS(23)
44615 IF (MUPDA.EQ.4) LFN=IMSS(24)
44616C...Flag that we have not yet found whatever we were asked to find.
44617 IRETRN=1
44618
44619C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
44620 IF (LFN.EQ.0) THEN
44621 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
44622 GOTO 9999
44623 ENDIF
44624
44625C...If reading LHEF header, start by rewinding file
44626 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
44627
44628C...If told to read spectrum, first zero all previous information.
44629 IF (MUPDA.EQ.1) THEN
44630C...Zero all block read flags
44631 DO 100 M=1,100
44632 MMOD(M)=0
44633 MSPC(M)=0
44634 100 CONTINUE
44635C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
44636 DO 110 ISUSY=1,36
44637 KC=PYCOMP(KFSUSY(ISUSY))
44638 PMAS(KC,1)=0D0
44639 110 CONTINUE
44640C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
44641 DO 130 J=1,4
44642 SFMIX(5,J) =0D0
44643 SFMIX(6,J) =0D0
44644 SFMIX(15,J)=0D0
44645 DO 120 L=1,4
44646 ZMIX(L,J) =0D0
44647 ZMIXI(L,J)=0D0
44648 IF (J.LE.2.AND.L.LE.2) THEN
44649 UMIX(L,J) =0D0
44650 UMIXI(L,J)=0D0
44651 VMIX(L,J) =0D0
44652 VMIXI(L,J)=0D0
44653 ENDIF
44654 120 CONTINUE
44655C...Zero signed masses.
44656 SMZ(J)=0D0
44657 IF (J.LE.2) SMW(J)=0D0
44658 130 CONTINUE
44659
44660C...If reading decays, reset PYTHIA decay counters.
44661 ELSEIF (MUPDA.EQ.2) THEN
44662C...Check if DECAY for this KF already read
44663 IF (KFORIG.NE.0) THEN
44664 DO 140 IDEC=1,NDECAY
44665 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
44666 IRETRN=0
44667 RETURN
44668 ENDIF
44669 140 CONTINUE
44670 ENDIF
44671 KCC=100
44672 NDC=0
44673 BRSUM=0D0
44674 DO 150 KC=1,MSTU(6)
44675 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
44676 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
44677 150 CONTINUE
44678 ELSEIF (MUPDA.EQ.5) THEN
44679C...Zero block read flags
44680 DO 160 M=1,100
44681 MSPC(M)=0
44682 160 CONTINUE
44683 ENDIF
44684
44685C............READ
44686C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
44687 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
44688C...Initialize program and version strings
44689 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
44690 CPRO(MUPDA)=' '
44691 CVER(MUPDA)=' '
44692 ENDIF
44693
44694C...Initialize read loop
44695 MERR=0
44696 NLINE=0
44697 CHBLCK=' '
44698C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
44699 170 CHINL=' '
44700 READ(LFN,'(A120)',END=400) CHINL
44701C...Count which line number we're at.
44702 NLINE=NLINE+1
44703 WRITE(CHNLIN,'(I6)') NLINE
44704
44705C...Skip comment and empty lines without processing.
44706 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
44707
44708C...We assume all upper case below. Rewrite CHINL to all upper case.
44709 INL=0
44710 IGOOD=0
44711 180 INL=INL+1
44712 IF (CHINL(INL:INL).NE.'#') THEN
44713 DO 190 ICH=97,122
44714 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
44715 190 CONTINUE
44716C...Extra safety. Chek for sensible input on line
44717 IF (IGOOD.EQ.0) THEN
44718 DO 200 ICH=48,90
44719 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
44720 200 CONTINUE
44721 ENDIF
44722 IF (INL.LT.120) GOTO 180
44723 ENDIF
44724 IF (IGOOD.EQ.0) GOTO 170
44725
44726C...Exit when first <event> tag reached in LHEF file
44727 DO 210 I1=1,10
44728 IF (CHINL(I1:I1+5).EQ.'<EVENT') THEN
44729 REWIND(LFN)
44730 GOTO 400
44731 ENDIF
44732 210 CONTINUE
44733
44734C...Check for BLOCK begin statement (spectrum).
44735 IF (CHINL(1:5).EQ.'BLOCK') THEN
44736 MERR=0
44737 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
44738C...Check if another of this type of block was already read.
44739C...(logarithmic interpolation not yet implemented, so duplicates always
44740C...give errors)
44741 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
44742 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
44743 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
44744 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
44745 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
44746 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
44747 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
44748 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
44749 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
44750 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
44751 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
44752 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
44753 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
44754 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
44755 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
44756 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
44757 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
44758C...Check for new particles
44759 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44760 & THEN
44761 MSPC(19)=MSPC(19)+1
44762C...Read PDG code
44763 READ(CHBLCK(9:60),*) KFQ
44764
44765 DO 220 MQ=1,NQNUM
44766 IF (KQNUM(MQ,0).EQ.KFQ) THEN
44767 MERR=17
44768 GOTO 380
44769 ENDIF
44770 220 CONTINUE
44771 IF (NHELLO.EQ.0) THEN
44772 WRITE(MSTU(11),5000) DOC
44773 NHELLO=1
44774 ENDIF
44775 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44776 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
44777 & ' for KF =',KFQ
44778 NQNUM=NQNUM+1
44779 KQNUM(NQNUM,0)=KFQ
44780 MSPC(19)=MSPC(19)+1
44781 KCQ=PYCOMP(KFQ)
44782C...Only read in new codes (also OK to overwrite if KF > 3000000)
44783 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
44784 IF (KCQ.EQ.0) THEN
44785 DO 230 KCT=100,MSTU(6)
44786 IF(KCHG(KCT,4).GT.100) KCQ=KCT
44787 230 CONTINUE
44788 KCQ=KCQ+1
44789 ENDIF
44790 KCC=KCQ
44791 KCHG(KCQ,4)=KFQ
44792C...First write PDG code as name
44793 WRITE(CHTMP,*) KFQ
44794 WRITE(CHTMP,'(A)') CHTMP(2:10)
44795C...Then look for real name
44796 IBEG=9
44797 240 IBEG=IBEG+1
44798 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
44799 250 IBEG=IBEG+1
44800 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
44801 IEND=IBEG-1
44802 260 IEND=IEND+1
44803 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
44804 IF (IEND.LT.59) THEN
44805 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
44806 IF (CHDUM.NE.' ') CHTMP=CHDUM
44807 ENDIF
44808 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
44809 MSTU(20)=0
44810C...Set stable for now
44811 PMAS(KCQ,2)=1D-6
44812 MWID(KCQ)=0
44813 MDCY(KCQ,1)=0
44814 MDCY(KCQ,2)=0
44815 MDCY(KCQ,3)=0
44816 ELSE
44817 WRITE(MSTU(11),*)
44818 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
44819 & CHAF(KCQ,1), '. Entry ignored.'
44820 MERR=7
44821 ENDIF
44822 ENDIF
44823C...Finalize this line and read next.
44824 GOTO 380
44825C...Check for DECAY begin statement (decays).
44826 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
44827 MERR=0
44828 BRSUM=0D0
44829 CHBLCK='DECAY'
44830C...Read KF code and WIDTH
44831 MPSIGN=1
44832 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
44833 IF (KF.LE.0) THEN
44834 KF=-KF
44835 MPSIGN=-1
44836 ENDIF
44837C...If this is not the KF we're looking for...
44838 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
44839C...Set block skip flag and read next line.
44840 MERR=16
44841 GOTO 380
44842 ELSE
44843C...Check whether decay table for this particle already read in
44844 DO 280 IDECAY=1,NDECAY
44845 IF (KFDEC(IDECAY).EQ.KF) THEN
44846 MERR=16
44847 GOTO 380
44848 ENDIF
44849 280 CONTINUE
44850 ENDIF
44851
44852C...Determine PYTHIA KC code of particle
44853 KCREP=0
44854 IF(KF.LE.100) THEN
44855 KCREP=KF
44856 ELSE
44857 DO 290 KCR=101,KCC
44858 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
44859 290 CONTINUE
44860 ENDIF
44861 KC=KCREP
44862 IF (KCREP.NE.0) THEN
44863C...Particle is already known. Don't do anything yet.
44864 ELSE
44865C... Add new particle. Actually, this should not happen.
44866C... New particles should be added already when reading the spectrum
44867C... information, so go under previously stable category.
44868 KCC=KCC+1
44869 KC=KCC
44870 ENDIF
44871
44872 IF (WIDTH.LE.0D0) THEN
44873C...Stable (i.e. LSP)
44874 WRITE(MSTU(11),*)
44875 & '* (PYSLHA:) Reading in SLHA stable particle ',
44876 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
44877 IF (WIDTH.LT.0D0) THEN
44878 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
44879 & ' zero !')
44880 WIDTH=0D0
44881 ENDIF
44882 PMAS(KC,2)=1D-6
44883 MWID(KC)=0
44884 MDCY(KC,1)=0
44885C...Ignore any decay lines that may be present for this KF
44886 MERR=16
44887 MDCY(KC,2)=0
44888 MDCY(KC,3)=0
44889C...Return ok
44890 IRETRN=0
44891 ENDIF
44892C...Finalize and start reading in decay modes.
44893 GOTO 380
44894 ELSEIF (MOD(MERR,10).GE.6) THEN
44895C...If ignore block flag set, skip directly to next line.
44896 GOTO 170
44897 ENDIF
44898
44899C...READ SPECTRUM
44900 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
44901 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44902 & THEN
44903 READ(CHINL,*) INDX, IVAL
44904 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
44905 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
44906 IF (INDX.EQ.3) KCHG(KCQ,2)=0
44907 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
44908 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
44909 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
44910 IF (INDX.EQ.4) THEN
44911 KCHG(KCQ,3)=IVAL
44912 IF (IVAL.EQ.1) THEN
44913 CHTMP=CHAF(KCQ,1)
44914 IF (CHTMP.EQ.' ') THEN
44915 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
44916 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
44917 ELSE
44918 ILAST=17
44919 300 ILAST=ILAST-1
44920 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
44921 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
44922 CHTMP(ILAST:ILAST)='-'
44923 ELSE
44924 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
44925 ENDIF
44926 CHAF(KCQ,2)=CHTMP
44927 ENDIF
44928 ENDIF
44929 ENDIF
44930 ELSE
44931 MERR=8
44932 ENDIF
44933 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
44934C...MASS: Mass spectrum
44935 IF (CHBLCK(1:4).EQ.'MASS') THEN
44936 READ(CHINL,*) KF, VAL
44937 MERR=1
44938 KC=0
44939 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
44940C...Read in masses for anything
44941 MERR=0
44942 KC=PYCOMP(KF)
44943C...Don't read in masses for the light quarks
44944 IF (IABS(KF).LE.3) THEN
44945 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44946 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
44947 & KF
44948 MERR=1
44949 ENDIF
44950 IF (KC.NE.0) THEN
44951 MSPC(1)=MSPC(1)+1
44952 PMAS(KC,1) = ABS(VAL)
44953 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
44954 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44955 & ' * (PYSLHA:) Reading in MASS entry for KF =',
44956 & KF, ', pole mass =', VAL
44957 IRETRN=0
44958 ENDIF
44959C... Signed masses
44960 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
44961 IF (KF.EQ.1000022) SMZ(1)=VAL
44962 IF (KF.EQ.1000023) SMZ(2)=VAL
44963 IF (KF.EQ.1000025) SMZ(3)=VAL
44964 IF (KF.EQ.1000035) SMZ(4)=VAL
44965 IF (KF.EQ.1000024) SMW(1)=VAL
44966 IF (KF.EQ.1000037) SMW(2)=VAL
44967 ENDIF
44968 ELSEIF (MUPDA.EQ.5) THEN
44969 MERR=0
44970 ENDIF
44971C... MODSEL: Model selection and global switches
44972 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
44973 READ(CHINL,*) INDX, IVAL
44974 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44975 IF (IMSS(1).EQ.0) IMSS(1)=11
44976 MODSEL(INDX)=IVAL
44977 MMOD(1)=MMOD(1)+1
44978 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
44979C... Switch on NMSSM
44980 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
44981 IMSS(13)=MAX(1,IMSS(13))
44982C... Add NMSSM states if not already done
44983
44984 KFN=25
44985 KCN=KFN
44986 CHAF(KCN,1)='h_10'
44987 CHAF(KCN,2)=' '
44988
44989 KFN=35
44990 KCN=KFN
44991 CHAF(KCN,1)='h_20'
44992 CHAF(KCN,2)=' '
44993
44994 KFN=45
44995 KCN=KFN
44996 CHAF(KCN,1)='h_30'
44997 CHAF(KCN,2)=' '
44998
44999 KFN=36
45000 KCN=KFN
45001 CHAF(KCN,1)='A_10'
45002 CHAF(KCN,2)=' '
45003
45004 KFN=46
45005 KCN=KFN
45006 CHAF(KCN,1)='A_20'
45007 CHAF(KCN,2)=' '
45008
45009 KFN=1000045
45010 KCN=PYCOMP(KFN)
45011 IF (KCN.EQ.0) THEN
45012 DO 310 KCT=100,MSTU(6)
45013 IF(KCHG(KCT,4).GT.100) KCN=KCT
45014 310 CONTINUE
45015 KCN=KCN+1
45016 KCHG(KCN,4)=KFN
45017 MSTU(20)=0
45018 ENDIF
45019C... Set stable for now
45020 PMAS(KCN,2)=1D-6
45021 MWID(KCN)=0
45022 MDCY(KCN,1)=0
45023 MDCY(KCN,2)=0
45024 MDCY(KCN,3)=0
45025 CHAF(KCN,1)='~chi_50'
45026 CHAF(KCN,2)=' '
45027 ENDIF
45028 ELSE
45029 MERR=1
45030 ENDIF
45031 ELSEIF (MUPDA.EQ.5) THEN
45032C...If MUPDA = 5, skip all except MASS, return if MODSEL
45033 MERR=8
45034 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
45035 & CHBLCK(1:8).EQ.'PARTICLE') THEN
45036C...Don't print a warning for QNUMBERS when reading spectrum
45037 MERR=8
45038C...MINPAR: Minimal model parameters
45039 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
45040 READ(CHINL,*) INDX, VAL
45041 IF (INDX.LE.100.AND.INDX.GT.0) THEN
45042 PARMIN(INDX)=VAL
45043 MMOD(2)=MMOD(2)+1
45044 ELSE
45045 MERR=1
45046 ENDIF
45047 IF (MMOD(3).NE.0) THEN
45048 WRITE(MSTU(11),*)
45049 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45050 MERR=1
45051 ENDIF
45052C...tan(beta)
45053 IF (INDX.EQ.3) RMSS(5)=VAL
45054C...EXTPAR: non-minimal model parameters.
45055 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
45056 IF (MMOD(1).NE.0) THEN
45057 READ(CHINL,*) INDX, VAL
45058 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45059 PAREXT(INDX)=VAL
45060 MMOD(3)=MMOD(3)+1
45061 ELSE
45062 MERR=1
45063 ENDIF
45064 ELSE
45065 WRITE(MSTU(11),*)
45066 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45067 MERR=1
45068 ENDIF
45069C...tan(beta)
45070 IF (INDX.EQ.25) RMSS(5)=VAL
45071 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
45072 READ(CHINL,*) INDX, VAL
45073 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
45074 MERR=1
45075 ELSEIF (INDX.EQ.4) THEN
45076 PMAS(PYCOMP(23),1)=VAL
45077 ELSEIF (INDX.EQ.6) THEN
45078 PMAS(PYCOMP(6),1)=VAL
45079 ENDIF
45080 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
45081 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
45082 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
45083 $ THEN
45084C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45085 IM=0
45086 IF (CHBLCK(5:6).EQ.'IM') IM=1
45087 320 READ(CHINL,*) INDX1, INDX2, VAL
45088 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
45089 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
45090 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
45091 MSPC(2)=MSPC(2)+1
45092 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
45093 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
45094 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
45095 MSPC(3)=MSPC(3)+1
45096 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
45097 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
45098 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
45099 MSPC(4)=MSPC(4)+1
45100 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
45101 $ .CHBLCK(1:4).EQ.'STAU') THEN
45102 IF (CHBLCK(1:4).EQ.'STOP') THEN
45103 KFSM=6
45104 ISPC=6
45105 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
45106 KFSM=5
45107 ISPC=5
45108 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
45109 KFSM=15
45110 ISPC=7
45111 ENDIF
45112C...Set SFMIX element
45113 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
45114 MSPC(ISPC)=MSPC(ISPC)+1
45115 ENDIF
45116C...Running parameters
45117 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
45118 READ(CHBLCK(8:25),*,ERR=620) Q
45119 READ(CHINL,*) INDX, VAL
45120 MSPC(8)=MSPC(8)+1
45121 IF (INDX.EQ.1) THEN
45122 RMSS(4) = VAL
45123 ELSE
45124 MERR=1
45125 MSPC(8)=MSPC(8)-1
45126 ENDIF
45127 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
45128 READ(CHINL,*,ERR=630) VAL
45129 RMSS(18)= VAL
45130 MSPC(17)=MSPC(17)+1
45131C...Higgs parameters set manually or with FeynHiggs.
45132 IMSS(4)=MAX(2,IMSS(4))
45133 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
45134 & .CHBLCK(1:2).EQ.'AE') THEN
45135 READ(CHBLCK(9:26),*,ERR=620) Q
45136 READ(CHINL,*) INDX1, INDX2, VAL
45137 IF (CHBLCK(2:2).EQ.'U') THEN
45138 AU(INDX1,INDX2)=VAL
45139 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
45140 MSPC(11)=MSPC(11)+1
45141 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
45142 AD(INDX1,INDX2)=VAL
45143 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
45144 MSPC(10)=MSPC(10)+1
45145 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
45146 AE(INDX1,INDX2)=VAL
45147 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
45148 MSPC(12)=MSPC(12)+1
45149 ELSE
45150 MERR=1
45151 ENDIF
45152 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
45153 IF (MSPC(18).EQ.0) THEN
45154 READ(CHBLCK(9:25),*,ERR=620) Q
45155 RMSOFT(0)=Q
45156 ENDIF
45157 READ(CHINL,*) INDX, VAL
45158 RMSOFT(INDX)=VAL
45159 MSPC(18)=MSPC(18)+1
45160 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
45161 MERR=8
45162 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
45163 & .CHBLCK(1:2).EQ.'YE') THEN
45164 MERR=8
45165 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
45166 READ(CHINL(1:6),*) INDX
45167 IT=0
45168 MIRD=0
45169 330 IT=IT+1
45170 IF (CHINL(IT:IT).EQ.' ') GOTO 330
45171C...Don't read index
45172 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
45173 MIRD=1
45174 GOTO 330
45175 ENDIF
45176 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
45177 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
45178 ELSE
45179C... Set unrecognized block flag.
45180 MERR=6
45181 ENDIF
45182
45183C...DECAY TABLES
45184C...Read in decay information
45185 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
45186C...Read new decay chanel
45187 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
45188 NDC=NDC+1
45189C...Read in branching ratio and number of daughters for this mode.
45190 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
45191 READ(CHINL(4:50),*,ERR=600) DUM, NDA
45192 IF (NDA.LE.5) THEN
45193 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
45194 & '(PYSLHA:) Decay data arrays full by KF ='
45195 $ //CHAF(KC,1))
45196C...If first decay channel, set decays start point in decay table
45197 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
45198 IF (KFORIG.EQ.0) WRITE(MSTU(11),*)
45199 & '* (PYSLHA:) Reading in SLHA decay table for ',
45200 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
45201C...Set particle parameters (mass set when reading BLOCK MASS above)
45202 PMAS(KC,2)=WIDTH
45203 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
45204 WRITE(MSTU(11),*)
45205 & '* Note: the Pythia gg->h/H/A cross section'//
45206 & ' is proportional to the h/H/A->gg width'
45207 ENDIF
45208 PMAS(KC,3)=0D0
45209 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
45210 MWID(KC)=2
45211 MDCY(KC,1)=1
45212 MDCY(KC,2)=NDC
45213 MDCY(KC,3)=0
45214C...Add to list of DECAY blocks currently read
45215 NDECAY=NDECAY+1
45216 KFDEC(NDECAY)=KF
45217C...Return ok
45218 IRETRN=0
45219 ENDIF
45220C... Count up number of decay modes for this particle
45221 MDCY(KC,3)=MDCY(KC,3)+1
45222C... Read in decay daughters.
45223 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
45224C... Flip sign if reading antiparticle decays (if antipartner exists)
45225 DO 340 IDA=1,NDA
45226 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
45227 & IDC(IDA)=MPSIGN*IDC(IDA)
45228 340 CONTINUE
45229C...Switch on decay channel, with products ordered in decreasing ABS(KF)
45230 MDME(NDC,1)=1
45231 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
45232 BRSUM=BRSUM+ABS(BRAT(NDC))
45233 BRAT(NDC)=ABS(BRAT(NDC))
45234 350 IFLIP=0
45235 DO 360 IDA=1,NDA-1
45236 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
45237 ITMP=IDC(IDA)
45238 IDC(IDA)=IDC(IDA+1)
45239 IDC(IDA+1)=ITMP
45240 IFLIP=IFLIP+1
45241 ENDIF
45242 360 CONTINUE
45243 IF (IFLIP.GT.0) GOTO 350
45244C...Treat as ordinary decay, no fancy stuff.
45245 MDME(NDC,2)=0
45246 DO 370 IDA=1,5
45247 IF (IDA.LE.NDA) THEN
45248 KFDP(NDC,IDA)=IDC(IDA)
45249 ELSE
45250 KFDP(NDC,IDA)=0
45251 ENDIF
45252 370 CONTINUE
45253C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
45254C & (KFDP(NDC,J),J=1,NDA)
45255 ELSE
45256 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line'//
45257 & CHNLIN)
45258 MERR=11
45259 NDC=NDC-1
45260 ENDIF
45261 ELSEIF(CHINL(1:1).EQ.'+') THEN
45262 MERR=11
45263 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
45264 MERR=16
45265 ELSE
45266 MERR=16
45267 ENDIF
45268 ENDIF
45269C... Error check.
45270 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
45271 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
45272 & //CHINL(1:40)
45273 MERR=0
45274 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
45275 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
45276 & CHBLCK(1:MIN(INL,40))//'... on line'//CHNLIN
45277 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
45278 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
45279 & //CHBLCK(1:INL)//'... on line'//CHNLIN
45280 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
45281 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
45282 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
45283 & //'... on line'//CHNLIN
45284 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
45285 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
45286 & /CHBLCK(1:INL)//'... on line'//CHNLIN
45287 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
45288 WRITE (CHTMP,*) KF
45289 WRITE(MSTU(11),*)
45290 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
45291 & CHTMP(1:9)//' on line'//CHNLIN
45292 ENDIF
45293C...Iterate read loop
45294 GOTO 170
45295C...Error catching
45296 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
45297 & ', ignoring subsequent lines.'
45298 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
45299 CHBLCK=' '
45300 GOTO 170
45301C...End of read loop
45302 400 CONTINUE
45303C...Set flag that KC codes have been rearranged.
45304 MSTU(20)=0
45305 VERBOS=0
45306
45307C...Perform possible tests that new information is consistent.
45308 IF (MUPDA.EQ.1) THEN
45309 MSTU23=MSTU(23)
45310 MSTU27=MSTU(27)
45311C...Check Z and top masses
45312 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
45313 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45314 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
45315 ENDIF
45316 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
45317 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45318 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
45319 & //CHTMP//'GeV')
45320 ENDIF
45321C...Check masses
45322 DO 410 ISUSY=1,37
45323 KF=KFSUSY(ISUSY)
45324C...Don't complain about right-handed neutrinos
45325 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
45326 & +16) GOTO 410
45327C...Only check gravitino in GMSB scenarios
45328 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
45329 KC=PYCOMP(KF)
45330 IF (PMAS(KC,1).EQ.0D0) THEN
45331 WRITE(CHTMP,*) KF
45332 CALL PYERRM(9
45333 & ,'(PYSLHA:) No mass information found for KF ='
45334 & //CHTMP)
45335 ENDIF
45336 410 CONTINUE
45337C...Check mixing matrices (MSSM only)
45338 IF (IMSS(13).EQ.0) THEN
45339 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
45340 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
45341 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
45342 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
45343 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
45344 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
45345 IF (MSPC(5).NE.4) CALL PYERRM(9
45346 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
45347 IF (MSPC(6).NE.4) CALL PYERRM(9
45348 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
45349 IF (MSPC(7).NE.4) CALL PYERRM(9
45350 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
45351 IF (MSPC(8).LT.1) CALL PYERRM(9
45352 & ,'(PYSLHA:) Too few elements in HMIX')
45353 IF (MSPC(10).EQ.0) CALL PYERRM(9
45354 & ,'(PYSLHA:) Missing A_b trilinear coupling')
45355 IF (MSPC(11).EQ.0) CALL PYERRM(9
45356 & ,'(PYSLHA:) Missing A_t trilinear coupling')
45357 IF (MSPC(12).EQ.0) CALL PYERRM(9
45358 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
45359 IF (MSPC(17).LT.1) CALL PYERRM(9
45360 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
45361 ENDIF
45362C...Check wavefunction normalizations.
45363C...Sfermions
45364 DO 420 ISPC=5,7
45365 IF (MSPC(ISPC).EQ.4) THEN
45366 KFSM=ISPC
45367 IF (ISPC.EQ.7) KFSM=15
45368 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
45369 & *SFMIX(KFSM,3))
45370 IF (ABS(1D0-CHECK).GT.1D-3) THEN
45371 KCSM=PYCOMP(KFSM)
45372 CALL PYERRM(17
45373 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
45374 & //CHAF(KCSM,1))
45375 ENDIF
45376 ENDIF
45377 420 CONTINUE
45378C...Neutralinos + charginos
45379 DO 440 J=1,4
45380 CN1=0D0
45381 CN2=0D0
45382 CU1=0D0
45383 CU2=0D0
45384 CV1=0D0
45385 CV2=0D0
45386 DO 430 L=1,4
45387 CN1=CN1+ZMIX(J,L)**2
45388 CN2=CN2+ZMIX(L,J)**2
45389 IF (J.LE.2.AND.L.LE.2) THEN
45390 CU1=CU1+UMIX(J,L)**2
45391 CU2=CU2+UMIX(L,J)**2
45392 CV1=CV1+VMIX(J,L)**2
45393 CV2=CV2+VMIX(L,J)**2
45394 ENDIF
45395 430 CONTINUE
45396C...NMIX normalization
45397 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
45398 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
45399 CALL PYERRM(19,
45400 & '(PYSLHA:) NMIX: Inconsistent normalization.')
45401 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
45402 ENDIF
45403C...UMIX, VMIX normalizations
45404 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
45405 IF (J.LE.2) THEN
45406 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
45407 CALL PYERRM(19
45408 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
45409 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
45410 & CU2
45411 ENDIF
45412 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
45413 CALL PYERRM(19,
45414 & '(PYSLHA:) VMIX: Inconsistent normalization.')
45415 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
45416 & CV2
45417 ENDIF
45418 ENDIF
45419 ENDIF
45420 440 CONTINUE
45421 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
45422 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
45423 & '* PYSLHA: No spectrum inconsistencies were found.'
45424 ELSE
45425 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
45426 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
45427 & ,' Warning: one or more (serious)'//
45428 & ' inconsistencies were found in the spectrum !'
45429 & ,' Read the error messages above and check your'//
45430 & ' input file.'
45431 ENDIF
45432C...Increase precision in Higgs sector using FeynHiggs
45433 IF (IMSS(4).EQ.3) THEN
45434C...FeynHiggs needs MSOFT.
45435 IERR=0
45436 IF (MSPC(18).EQ.0) THEN
45437 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
45438 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
45439 & ' Cannot call FeynHiggs.'
45440 IERR=-1
45441 ELSE
45442 WRITE(MSTU(11),'(1x,/1x,A/)')
45443 & '* (PYSLHA:) Now calling FeynHiggs.'
45444 CALL PYFEYN(IERR)
45445 IF (IERR.NE.0) IMSS(4)=2
45446 ENDIF
45447 ENDIF
45448 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
45449 IBEG=1
45450 IF (KFORIG.NE.0) IBEG=NDECAY
45451 DO 490 IDECAY=IBEG,NDECAY
45452 KF = KFDEC(IDECAY)
45453 KC = PYCOMP(KF)
45454 WRITE(CHKF,8300) KF
45455 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
45456 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
45457 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
45458 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
45459 $ //CHKF)
45460 BRSUM=0D0
45461 BROPN=0D0
45462 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45463 IF(MDME(IDA,2).GT.80) GOTO 460
45464 KQ=KCHG(KC,1)
45465 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
45466 MERR=0
45467 DO 450 J=1,5
45468 KP=KFDP(IDA,J)
45469 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
45470 IF(KP.EQ.81) KQ=0
45471 ELSEIF(PYCOMP(KP).EQ.0) THEN
45472 MERR=3
45473 ELSE
45474 KQ=KQ-PYCHGE(KP)
45475 KPC=PYCOMP(KP)
45476 PMS=PMS-PMAS(KPC,1)
45477 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
45478 & PMAS(KPC,3))
45479 ENDIF
45480 450 CONTINUE
45481 IF(KQ.NE.0) MERR=MAX(2,MERR)
45482 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
45483 & MERR=MAX(1,MERR)
45484 IF(MERR.EQ.3) CALL PYERRM(17,
45485 & '(PYSLHA:) Unknown particle code in decay of KF ='
45486 $ //CHKF)
45487 IF(MERR.EQ.2) CALL PYERRM(17,
45488 & '(PYSLHA:) Charge not conserved in decay of KF ='
45489 $ //CHKF)
45490 IF(MERR.EQ.1) CALL PYERRM(7,
45491 & '(PYSLHA:) Kinematically unallowed decay of KF ='
45492 $ //CHKF)
45493 BRSUM=BRSUM+BRAT(IDA)
45494 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
45495 460 CONTINUE
45496C...Check branching ratio sum.
45497 IF (BROPN.LE.0D0) THEN
45498C...If zero, set stable.
45499 WRITE(CHTMP,8500) BROPN
45500 CALL PYERRM(7
45501 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
45502 & CHTMP(9:16)//'. Changed to stable.')
45503 PMAS(KC,2)=1D-6
45504 MWID(KC)=0
45505C...If BR's > 1, rescale.
45506 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
45507 WRITE(CHTMP,8500) BRSUM
45508 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
45509 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
45510 & ' ; sum was'//CHTMP(9:16)//'.')
45511 FAC=1D0/BRSUM
45512 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45513 IF(MDME(IDA,2).GT.80) GOTO 470
45514 BRAT(IDA)=FAC*BRAT(IDA)
45515 470 CONTINUE
45516 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
45517C...If BR's < 1, insert dummy mode for proper cross section rescaling.
45518 WRITE(CHTMP,8500) BRSUM
45519 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
45520 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
45521 & CHTMP(9:16)//'. Dummy mode will be inserted.')
45522C...Move table and insert dummy mode
45523 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45524 NDC=NDC+1
45525 BRAT(NDC)=BRAT(IDA)
45526 KFDP(NDC,1)=KFDP(IDA,1)
45527 KFDP(NDC,2)=KFDP(IDA,2)
45528 KFDP(NDC,3)=KFDP(IDA,3)
45529 KFDP(NDC,4)=KFDP(IDA,4)
45530 KFDP(NDC,5)=KFDP(IDA,5)
45531 MDME(NDC,1)=MDME(IDA,1)
45532 480 CONTINUE
45533 NDC=NDC+1
45534 BRAT(NDC)=1D0-BRSUM
45535 KFDP(NDC,1)=0
45536 KFDP(NDC,2)=0
45537 KFDP(NDC,3)=0
45538 KFDP(NDC,4)=0
45539 KFDP(NDC,5)=0
45540 MDME(NDC,1)=0
45541 BRSUM=1D0
45542C...Update MDCY
45543 MDCY(KC,3)=MDCY(KC,3)+1
45544 MDCY(KC,2)=NDC-MDCY(KC,3)+1
45545 ENDIF
45546 490 CONTINUE
45547 ENDIF
45548
45549
45550C...WRITE SPECTRUM ON SLHA FILE
45551 ELSEIF(MUPDA.EQ.3) THEN
45552C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
45553 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
45554 MODSEL(1)=1
45555 PARMIN(1)=RMSS(8)
45556 PARMIN(2)=RMSS(1)
45557 PARMIN(3)=RMSS(5)
45558 PARMIN(4)=SIGN(1D0,RMSS(4))
45559 PARMIN(5)=RMSS(36)
45560 ENDIF
45561C...Write spectrum
45562 WRITE(LFN,7000) 'SLHA MSSM spectrum'
45563 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
45564 & // ' P. Skands.'
45565 WRITE(LFN,7010) 'MODSEL', 'Model selection'
45566 WRITE(LFN,7110) 1, MODSEL(1)
45567 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
45568 IF (MODSEL(1).EQ.1) THEN
45569 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
45570 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
45571 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45572 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45573 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
45574 ELSEIF(MODSEL(2).EQ.2) THEN
45575 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
45576 WRITE(LFN,7210) 2, PARMIN(2), 'M'
45577 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45578 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45579 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
45580 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
45581 ENDIF
45582 WRITE(LFN,7000) ' '
45583 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
45584 DO 500 I=1,36
45585 KF=KFSUSY(I)
45586 KC=PYCOMP(KF)
45587 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
45588 KFSM=KF-KSUSY1
45589 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
45590 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
45591 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
45592 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
45593 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
45594 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
45595 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
45596 ELSE
45597 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
45598 ENDIF
45599 500 CONTINUE
45600C...SUSY scale
45601 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
45602 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
45603 WRITE(LFN,7210) 1, RMSS(4),'mu'
45604 WRITE(LFN,7010) 'ALPHA',' '
45605 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
45606 WRITE(LFN,7020) 'AU',RMSUSY
45607 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
45608 WRITE(LFN,7020) 'AD',RMSUSY
45609 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
45610 WRITE(LFN,7020) 'AE',RMSUSY
45611 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
45612 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
45613 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
45614 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
45615 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
45616 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
45617 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
45618 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
45619 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
45620 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
45621 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
45622 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
45623 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
45624 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
45625 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
45626 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
45627 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
45628 DO 520 I1=1,4
45629 DO 510 I2=1,4
45630 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
45631 510 CONTINUE
45632 520 CONTINUE
45633 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
45634 DO 540 I1=1,2
45635 DO 530 I2=1,2
45636 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
45637 530 CONTINUE
45638 540 CONTINUE
45639 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
45640 DO 560 I1=1,2
45641 DO 550 I2=1,2
45642 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
45643 550 CONTINUE
45644 560 CONTINUE
45645 WRITE(LFN,7010) 'SPINFO'
45646 IF (IMSS(1).EQ.2) THEN
45647 CPRO(1)='PYTHIA'
45648 CVER(1)='6.4'
45649 ELSEIF (IMSS(1).EQ.12) THEN
45650 ISAVER=VISAJE()
45651 CPRO(1)='ISASUSY'
45652 CVER(1)=ISAVER(1:12)
45653 ENDIF
45654 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
45655 WRITE(LFN,7310) 2, CVER(1), 'Version number'
45656 ENDIF
45657
45658C...Print user information about spectrum
45659 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
45660 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
45661 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
45662 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
45663 IF (MUPDA.EQ.1) THEN
45664 WRITE(MSTU(11),5020) LFN
45665 ELSE
45666 WRITE(MSTU(11),5010) LFN
45667 ENDIF
45668
45669 WRITE(MSTU(11),5400)
45670 WRITE(MSTU(11),5500) 'Pole masses'
45671 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
45672 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
45673 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
45674 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
45675 IF (IMSS(13).EQ.0) THEN
45676 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
45677 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
45678 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
45679 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
45680 & CHAF(37,1), ' ', ' ',' ',' ',
45681 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
45682 ELSEIF (IMSS(13).EQ.1) THEN
45683 KF1=KSUSY1+21
45684 KF2=KSUSY1+22
45685 KF3=KSUSY1+23
45686 KF4=KSUSY1+25
45687 KF5=KSUSY1+35
45688 KF6=KSUSY1+45
45689 KF7=KSUSY1+24
45690 KF8=KSUSY1+37
45691 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
45692 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
45693 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
45694 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
45695 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
45696 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
45697 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
45698 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
45699 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
45700 & RMFUN(37)
45701 ENDIF
45702 WRITE(MSTU(11),5400)
45703 WRITE(MSTU(11),5500) 'Mixing structure'
45704 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45705 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45706 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45707 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45708 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45709 & ),(SFMIX(15,J),J=3,4)
45710 WRITE(MSTU(11),5400)
45711 WRITE(MSTU(11),5500) 'Couplings'
45712 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
45713 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
45714 WRITE(MSTU(11),5400)
45715 WRITE(MSTU(11),6500)
45716
45717 ENDIF
45718
45719C...Only rewind when reading
45720 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
45721
45722 9999 RETURN
45723
45724C...Serious error catching
45725 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
45726 write(*,*) CHINL(1:80)
45727 CALL PYSTOP(106)
45728 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
45729 WRITE(*,*) CHINL(1:72)
45730 CALL PYSTOP(106)
45731 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
45732 WRITE(*,*) CHINL(1:80)
45733 CALL PYSTOP(106)
45734 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
45735 WRITE(*,*) CHINL(1:80)
45736 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
45737 CALL PYSTOP(106)
45738 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
45739 WRITE(*,*) CHINL(1:80)
45740 CALL PYSTOP(106)
45741
45742 8300 FORMAT(I9)
45743 8500 FORMAT(F16.5)
45744
45745C...Formats for user information printout.
45746 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.10: SUSY/BSM SPECTRUM '
45747 & ,'INTERFACE',1x,17('*')/1x,'*',2x
45748 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
45749 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
45750 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
45751 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
45752 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
45753 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
45754 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45755 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45756 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
45757 & ,'----------------')
45758 5400 FORMAT(1x,'*',1x,A)
45759 5500 FORMAT(1x,'*',1x,A,':')
45760 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45761 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45762 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
45763 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
45764 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45765 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
45766 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
45767 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45768 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45769 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45770 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45771 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
45772 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45773 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45774 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45775 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45776 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45777 & ,1x,F6.3,1x),'|')
45778 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45779 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45780 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45781 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45782 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45783 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45784 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45785 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45786 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45787 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45788 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45789 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45790 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
45791 & ,'A_tau = ',F8.2)
45792 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
45793 & ,' mu = ',F8.2)
45794 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
45795
45796C...Format to use for comments
45797 7000 FORMAT('# ',A)
45798C...Format to use for block statements
45799 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
45800 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
45801C...Indexed Int
45802 7110 FORMAT(1x,I4,1x,I4,3x,'#')
45803C...Non-Indexed Double
45804 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
45805C...Indexed Double
45806 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
45807C...Long Indexed Double (PDG + double)
45808 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
45809C...Indexed Char(12)
45810 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
45811C...Single matrix
45812 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
45813C...Double Matrix
45814 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
45815C...Write Decay Table
45816 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
45817 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
45818 & 3x,'#',1x,A)
45819
45820 END
45821
45822
45823C*********************************************************************
45824
45825C...PYAPPS
45826C...Uses approximate analytical formulae to determine the full set of
45827C...MSSM parameters from SUGRA input.
45828C...See M. Drees and S.P. Martin, hep-ph/9504124
45829
45830 SUBROUTINE PYAPPS
45831
45832C...Double precision and integer declarations.
45833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45834 IMPLICIT INTEGER(I-N)
45835 INTEGER PYK,PYCHGE,PYCOMP
45836C...Parameter statement to help give large particle numbers.
45837 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45838 &KEXCIT=4000000,KDIMEN=5000000)
45839C...Commonblocks.
45840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45842 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45843 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
45844
45845 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
45846 &' not intended for serious physics studies'
45847 IMSS(5)=0
45848 IMSS(8)=0
45849 XMT=PMAS(6,1)
45850 XMZ2=PMAS(23,1)**2
45851 XMW2=PMAS(24,1)**2
45852 TANB=RMSS(5)
45853 BETA=ATAN(TANB)
45854 XW=PARU(102)
45855 XMG=RMSS(1)
45856 XMG2=XMG*XMG
45857 XM0=RMSS(8)
45858 XM02=XM0*XM0
45859C...Temporary sign change for AT. Others unchanged.
45860 AT=-RMSS(16)
45861 RMSS(15)=RMSS(16)
45862 RMSS(17)=RMSS(16)
45863 SINB=TANB/SQRT(TANB**2+1D0)
45864 COSB=SINB/TANB
45865
45866 DTERM=XMZ2*COS(2D0*BETA)
45867 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
45868 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
45869 RMSS(6)=XMEL
45870 RMSS(7)=XMER
45871 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
45872 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
45873 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
45874 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
45875 DO 100 I=1,5,2
45876 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
45877 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
45878 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
45879 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
45880 100 CONTINUE
45881 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
45882 IF(XARG.LT.0D0) THEN
45883 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45884 & ' FROM THE SUM RULE. '
45885 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45886 RETURN
45887 ELSE
45888 XARG=SQRT(XARG)
45889 ENDIF
45890 DO 110 I=11,15,2
45891 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
45892 PMAS(PYCOMP(KSUSY2+I),1)=XMER
45893 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45894 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45895 110 CONTINUE
45896 RMT=PYMRUN(6,PMAS(6,1)**2)
45897 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
45898 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
45899 RMB=PYMRUN(5,PMAS(6,1)**2)
45900 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
45901 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
45902 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
45903 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
45904 &SINB)**2)
45905 RMSS(16)=-ATP
45906 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
45907 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
45908 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
45909 XMU=SIGN(SQRT(XMU2),RMSS(4))
45910 RMSS(4)=XMU
45911 IF(XMA2.GT.0D0) THEN
45912 RMSS(19)=SQRT(XMA2)
45913 ELSE
45914 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
45915 CALL PYSTOP(102)
45916 ENDIF
45917 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
45918 IF(ARG.GT.0D0) THEN
45919 RMSS(14)=SQRT(ARG)
45920 ELSE
45921 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
45922 CALL PYSTOP(102)
45923 ENDIF
45924 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
45925 IF(ARG.GT.0D0) THEN
45926 RMSS(13)=SQRT(ARG)
45927 ELSE
45928 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
45929 CALL PYSTOP(102)
45930 ENDIF
45931 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
45932 IF(ARG.GT.0D0) THEN
45933 RMSS(10)=SQRT(ARG)
45934 ELSE
45935 RMSS(10)=-SQRT(-ARG)
45936 ENDIF
45937 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
45938 IF(ARG.GT.0D0) THEN
45939 RMSS(12)=SQRT(ARG)
45940 ELSE
45941 RMSS(12)=-SQRT(-ARG)
45942 ENDIF
45943 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
45944 IF(ARG.GT.0D0) THEN
45945 RMSS(11)=SQRT(ARG)
45946 ELSE
45947 RMSS(11)=-SQRT(-ARG)
45948 ENDIF
45949
45950 RETURN
45951 END
45952
45953C*********************************************************************
45954
45955C...PYSUGI
45956C...Interface to ISASUSY version 7.71.
45957C...Warning: this interface should not be used with earlier versions
45958C...of ISASUSY, since common block incompatibilities may then arise.
45959C...Calls SUGRA (in ISAJET) to perform RGE evolution.
45960C...Then converts to Gunion-Haber conventions.
45961
45962 SUBROUTINE PYSUGI
45963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45964
45965 INTEGER PYK,PYCHGE,PYCOMP
45966 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45967 &KEXCIT=4000000,KDIMEN=5000000)
45968
45969C...Date of Change
45970 CHARACTER DOC*11
45971 PARAMETER (DOC='01 May 2006')
45972
45973C...ISASUGRA Input:
45974 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
45975C...XISAIN contains the MSSMi inputs in natural order.
45976 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
45977 $XAMIN(7)
45978 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
45979 SAVE /SUGXIN/
45980C...ISASUGRA Output
45981 CHARACTER*40 ISAVER,VISAJE
45982 REAL SUPER
45983 COMMON /SSPAR/ SUPER(72)
45984 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
45985 $FBGUT,FTAGUT,FNGUT
45986 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
45987 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
45988 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
45989 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
45990 $VUMT,VDMT,ASMTP,ASMSS,M3Q
45991 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
45992 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
45993 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
45994 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
45995 INTEGER IALLOW
45996 SAVE /SUGMG/,/SSPAR/
45997C SUPER: Filled by ISASUGRA.
45998C SUPER(1) = mass of ~g
45999C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46000C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46001C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46002C ,~tau_2
46003C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46004C SUPER(29) = Higgsino mass = - mu
46005C SUPER(30) = ratio v2/v1 of vev's
46006C SUPER(31:34) = Signed neutralino masses
46007C SUPER(35:50) = Neutralino mixing matrix
46008C SUPER(51:52) = Signed chargino masses
46009C SUPER(53:54) = Chargino left, right mixing angles
46010C SUPER(55:58) = mass of h0, H0, A0, H+
46011C SUPER(59) = Higgs mixing angle alpha
46012C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46013C SUPER(66) = Gravitino mass
46014C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46015C SUPER(70) = b-Yukawa at mA scale (not used)
46016C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46017C GSS: Filled by ISASUGRA
46018C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46019C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46020C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46021C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46022C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46023C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46024C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46025C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46026C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46027C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46028C GSS(31) = log(vuq)
46029C MSS: Filled by ISASUGRA
46030C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46031C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46032C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46033C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46034C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46035C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46036C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46037C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46038C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46039C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46040C MSS(31) = ha0 MSS(32) = h+
46041C Unification, filled by ISASUGRA if applicable.
46042C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46043
46044C...SPYTHIA Input/Output
46045 INTEGER IMSS
46046 DOUBLE PRECISION RMSS
46047 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46048 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46049 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46050C...SLHA Input/Output
46051 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46052 & AU(3,3),AD(3,3),AE(3,3)
46053C...PYTHIA common blocks
46054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46055 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46056 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46057
46058 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
46059CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46060 INTEGER IMODEL
46061 REAL M0,MHF,A0,MT
46062 CHARACTER*20 CHMOD(5)
46063 CHARACTER*32 FNAME
46064
46065 COMMON /SUGNU/ XNUSUG(18)
46066 REAL XNUSUG
46067 SAVE /SUGNU/
46068
46069 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
46070 & 'truly unified SUGRA', 'non-minimal GMSB'/
46071
46072C...Start by checking for incompatibilities/inconsistencies:
46073 DO 100 ICHK=2,9
46074 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
46075 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
46076 & ,' option not used by PYSUGI'
46077 ENDIF
46078 100 CONTINUE
46079C...ISAJET works with REAL numbers.
46080 MZERO=REAL(RMSS(8))
46081 MHLF=REAL(RMSS(1))
46082 AZERO=REAL(RMSS(16))
46083 TANB=REAL(RMSS(5))
46084 SGNMU=REAL(RMSS(4))
46085 MTOP=REAL(PMAS(6,1))
46086 IMODEL=0
46087 IF (IMSS(1).EQ.12) THEN
46088 IMODEL=1
46089 GOTO 130
46090 ELSEIF(IMSS(1).EQ.13) THEN
46091C...Read from isajet par file in IMSS(20)
46092 LFN=IMSS(20)
46093C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46094 IF (LFN.EQ.0) THEN
46095 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46096 GOTO 9999
46097 ENDIF
46098 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
46099CMrenna change to allow any susy model
46100 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
46101 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
46102 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
46103 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
46104 & ' gauge couplings:'
46105 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
46106 READ(LFN,*) IMODEL
46107 IF (IMODEL.EQ.4) THEN
46108 IAL3UN=1
46109 IMODEL=1
46110 ENDIF
46111 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
46112 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46113 & //' sgn(mu), M_t:'
46114 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
46115 IF (IMODEL.EQ.3) THEN
46116 IMODEL=1
46117 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46118 & //' 0 to continue:'
46119 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
46120 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
46121 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
46122 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
46123 & //' generation masses'
46124 WRITE(MSTU(11),*)
46125 & ' NUSUG5 = GUT scale 3rd generation masses'
46126 READ(LFN,*) INUSUG
46127 IF (INUSUG.EQ.0) THEN
46128 GOTO 120
46129 ELSEIF (INUSUG.EQ.1) THEN
46130 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
46131 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
46132 IF (XNUSUG(3).LE.0.) THEN
46133 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
46134 CALL PYSTOP(109)
46135 END IF
46136 ELSEIF (INUSUG.EQ.2) THEN
46137 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
46138 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
46139 ELSEIF (INUSUG.EQ.3) THEN
46140 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
46141 READ(LFN,*) XNUSUG(7),XNUSUG(8)
46142 ELSEIF (INUSUG.EQ.4) THEN
46143 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
46144 & //' M(ur), M(el), M(er):'
46145 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
46146 & XNUSUG(10),XNUSUG(9)
46147 ELSEIF (INUSUG.EQ.5) THEN
46148 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
46149 & //' M(Ll), M(Lr):'
46150 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
46151 & XNUSUG(15),XNUSUG(14)
46152 ENDIF
46153 GOTO 110
46154 ENDIF
46155 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
46156 IMSS(11)=1
46157 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
46158 & ,' sgn(mu), M_t, C_gv:'
46159 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
46160 XGMIN(7)=XCMGV
46161 XGMIN(8)=1.
46162C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
46163 AMPL=2.4D18
46164 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
46165 IF (IMODEL.EQ.5) THEN
46166 IMODEL=2
46167 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
46168 & ,' masses at M_mes'
46169 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
46170 & ,' shifts at M_mes'
46171 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
46172 & ' Y at M_mes'
46173 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
46174 & ,'SU(2),SU(3)'
46175 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
46176 & ,' n5_2, n5_3'
46177 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
46178 $ XGMIN(13),XGMIN(14)
46179 ENDIF
46180 ELSE
46181 WRITE(MSTU(11),*) 'Invalid model choice.'
46182 GOTO 9999
46183 ENDIF
46184 ENDIF
46185
46186 120 MZERO=M0
46187 MHLF=MHF
46188 AZERO=A0
46189C TANB=REAL(RMSS(5))
46190C SGNMU=REAL(RMSS(4))
46191 MTOP=MT
46192
46193C...Initialize MSSM parameter array
46194 130 DO 140 IPAR=1,72
46195 SUPER(IPAR)=0.0
46196 140 CONTINUE
46197C...Call ISASUGRA
46198 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
46199C...Check whether ISASUSY thought the model was OK.
46200 IF (NOGOOD.NE.0) THEN
46201 IF (NOGOOD.EQ.1) CALL PYERRM(26
46202 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
46203 IF (NOGOOD.EQ.2) CALL PYERRM(26
46204 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
46205 IF (NOGOOD.EQ.3) CALL PYERRM(26
46206 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
46207 IF (NOGOOD.EQ.4) CALL PYERRM(26
46208 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
46209 IF (NOGOOD.EQ.7) CALL PYERRM(26
46210 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
46211 IF (NOGOOD.EQ.8) CALL PYERRM(26
46212 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
46213C...Give warning, but don't stop, if LSP not ~chi_10.
46214 IF (NOGOOD.EQ.5) CALL PYERRM(16
46215 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
46216 ENDIF
46217C...Warn about possible GUT scale tachyons.
46218 IF (ITACHY.NE.0) CALL PYERRM(16,
46219 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
46220C...Finalize spectrum (last iteration)
46221C...(Thanks to A. Raklev for pointing this out.)
46222C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
46223 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
46224 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
46225 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
46226 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
46227 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
46228 $ MTOP,IALLOW,1)
46229
46230C...M1, M2, M3.
46231 RMSS(1)=dble(GSS(7))
46232 RMSS(2)=dble(GSS(8))
46233 RMSS(3)=dble(GSS(9))
46234 RMSOFT(1)=dble(GSS(7))
46235 RMSOFT(2)=dble(GSS(8))
46236 RMSOFT(3)=dble(GSS(9))
46237C...Mu = - Higgsino mass.
46238 RMSS(4)=-SUPER(29)
46239 RMSS(5)=TANB
46240C...Slepton and squark masses. 2 first generations.
46241 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
46242 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
46243 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
46244 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
46245C...Third generation.
46246 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
46247 RMSS(11)=SUPER(11)
46248 RMSS(12)=SUPER(15)
46249 RMSS(13)=SUPER(22)
46250 RMSS(14)=SUPER(23)
46251C...SLHA: store exact soft spectrum in RMSOFT
46252 RMSOFT(31)=SUPER(18)
46253 RMSOFT(32)=SUPER(20)
46254 RMSOFT(33)=SUPER(22)
46255 RMSOFT(34)=SUPER(19)
46256 RMSOFT(35)=SUPER(21)
46257 RMSOFT(36)=SUPER(23)
46258 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
46259 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
46260 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
46261 RMSOFT(44)=SUPER(3)
46262 RMSOFT(45)=SUPER(9)
46263 RMSOFT(46)=SUPER(15)
46264 RMSOFT(47)=SUPER(5)
46265 RMSOFT(48)=SUPER(7)
46266 RMSOFT(49)=SUPER(11)
46267
46268C...~b, ~t, and ~tau trilinear couplings and mixing angles.
46269 RMSS(15)=SUPER(62)
46270 RMSS(16)=SUPER(60)
46271 RMSS(17)=SUPER(64)
46272 RMSS(26)=SUPER(63)
46273 RMSS(27)=SUPER(61)
46274 RMSS(28)=SUPER(65)
46275C...SLHA trilinears
46276 DO 142 K1=1,3
46277 DO 141 K2=1,3
46278 AE(K1,K2)=0D0
46279 AU(K1,K2)=0D0
46280 AD(K1,K2)=0D0
46281 141 CONTINUE
46282 142 CONTINUE
46283 AE(3,3)=SUPER(64)
46284 AU(3,3)=SUPER(60)
46285 AD(3,3)=SUPER(62)
46286C...Higgs mixing angle alpha (Gunion-Haber convention).
46287 RMSS(18)=-SUPER(59)
46288C...A0 mass.
46289 RMSS(19)=SUPER(57)
46290C...GUT scale coupling
46291 RMSS(20)=AGUTSS
46292C...Gravitino mass (for future compatibility)
46293 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
46294
46295C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
46296C...Higgs sector.
46297 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
46298 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
46299 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
46300 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
46301C...Gluino.
46302 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
46303C...Squarks and Sleptons.
46304 DO 150 ILR=1,2
46305 ILRM=ILR-1
46306 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
46307 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
46308 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
46309 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
46310 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
46311 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
46312 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
46313 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
46314 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
46315 150 CONTINUE
46316 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
46317 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
46318 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
46319C...Neutralinos.
46320 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
46321 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
46322 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
46323 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
46324C...Signed masses (extra minus from going to G-H convention).
46325 SMZ(1)=-SUPER(31)
46326 SMZ(2)=-SUPER(32)
46327 SMZ(3)=-SUPER(33)
46328 SMZ(4)=-SUPER(34)
46329C...Charginos
46330 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
46331 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
46332C...Signed masses (extra minus from going to G-H convention).
46333 SMW(1)=-SUPER(51)
46334 SMW(2)=-SUPER(52)
46335
46336C... Neutralino Mixing.
46337 DO 160 IN=1,4
46338 ZMIX(IN,1)= SUPER(38+4*(IN-1))
46339 ZMIX(IN,2)= SUPER(37+4*(IN-1))
46340 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
46341 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
46342 160 CONTINUE
46343C...Chargino Mixing (PYTHIA same angle as HERWIG).
46344 THX=1D0
46345 THY=1D0
46346 IF (SUPER(53).GT.0) THX=-1D0
46347 IF (SUPER(54).GT.0) THY=-1D0
46348 UMIX(1,1) = -SIN(SUPER(53))
46349 UMIX(1,2) = -COS(SUPER(53))
46350 UMIX(2,1) = -THX*COS(SUPER(53))
46351 UMIX(2,2) = THX*SIN(SUPER(53))
46352 VMIX(1,1) = -SIN(SUPER(54))
46353 VMIX(1,2) = -COS(SUPER(54))
46354 VMIX(2,1) = -THY*COS(SUPER(54))
46355 VMIX(2,2) = THY*SIN(SUPER(54))
46356C...Sfermion mixing (PYTHIA same angle as ISAJET)
46357 SFMIX(5,1)=COS(SUPER(63))
46358 SFMIX(5,2)=SIN(SUPER(63))
46359 SFMIX(5,3)=-SIN(SUPER(63))
46360 SFMIX(5,4)=COS(SUPER(63))
46361 SFMIX(6,1)=COS(SUPER(61))
46362 SFMIX(6,2)=SIN(SUPER(61))
46363 SFMIX(6,3)=-SIN(SUPER(61))
46364 SFMIX(6,4)=COS(SUPER(61))
46365 SFMIX(15,1)=COS(SUPER(65))
46366 SFMIX(15,2)=SIN(SUPER(65))
46367 SFMIX(15,3)=-SIN(SUPER(65))
46368 SFMIX(15,4)=COS(SUPER(65))
46369
46370 IF (MSTP(122).NE.0) THEN
46371C...Print a few lines to make the user know what's happening
46372 ISAVER=VISAJE()
46373 WRITE(MSTU(11),5000) DOC, ISAVER
46374 WRITE(MSTU(11),5100)
46375 IF (IMODEL.EQ.1) THEN
46376 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
46377 & MTOP
46378 WRITE(MSTU(11),5300)
46379 ENDIF
46380 WRITE(MSTU(11),5500) 'Pole masses'
46381 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
46382 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
46383 & ,(SUPER(IP),IP=19,25,2)
46384 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
46385 & ,IP=1,2)
46386 WRITE(MSTU(11),5400)
46387 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
46388 WRITE(MSTU(11),5400)
46389 WRITE(MSTU(11),5500) 'EW scale mixing structure'
46390 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46391 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46392 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46393 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46394 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46395 & ),(SFMIX(15,J),J=3,4)
46396 WRITE(MSTU(11),5400)
46397 WRITE(MSTU(11),6450) RMSS(18)
46398 WRITE(MSTU(11),5400)
46399 WRITE(MSTU(11),5500) 'Couplings'
46400 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
46401 WRITE(MSTU(11),5400)
46402 ENDIF
46403
46404C...Call FeynHiggs to improve Higgs sector if requested
46405 IF (IMSS(4).EQ.3) THEN
46406 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
46407 & ' (PYSUGI:) Now calling FeynHiggs.'
46408 CALL PYFEYN(IERR)
46409 IF (IERR.EQ.0) THEN
46410 IMSS(4)=2
46411 IF (MSTP(122).NE.0) THEN
46412 WRITE(MSTU(11),5400)
46413 WRITE(MSTU(11),5500)
46414 & 'Corrected Higgs masses and mixing'
46415 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
46416 & PMAS(37,1)
46417 WRITE(MSTU(11),6450) RMSS(18)
46418 WRITE(MSTU(11),5400)
46419 ENDIF
46420 ENDIF
46421 ENDIF
46422
46423 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
46424
46425C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
46426C...output by ISASUSY.
46427 IMSS(4)=MAX(2,IMSS(4))
46428
46429 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
46430 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
46431 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
46432 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
46433 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46434 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46435 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
46436 & ,'----------------')
46437 5400 FORMAT(1x,'*',1x,A)
46438 5500 FORMAT(1x,'*',1x,A,':')
46439 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46440 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46441 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
46442 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
46443 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
46444 & ,1x))
46445 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
46446 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
46447 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
46448 & .2,1x))
46449 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46450 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46451 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46452 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46453 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
46454 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46455 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
46456 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46457 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46458 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46459 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46460 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46461 & ,1x,F6.3,1x),'|')
46462 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46463 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46464 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46465 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46466 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46467 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46468 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46469 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46470 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46471 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46472 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46473 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46474 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
46475 & ,4x,'Alpha_GUT = ',F8.2)
46476 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
46477 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
46478
46479 9999 RETURN
46480 END
46481
46482C*********************************************************************
46483
46484C...PYFEYN
46485C...Interface to FeynHiggs for MSSM Higgs sector.
46486C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
46487C...P. Skands
46488
46489 SUBROUTINE PYFEYN(IERR)
46490
46491C...Double precision and integer declarations.
46492 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46493 IMPLICIT INTEGER(I-N)
46494 INTEGER PYK,PYCHGE,PYCOMP
46495C...Commonblocks.
46496 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46497 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46498C...SUSY blocks
46499 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46500C...FeynHiggs variables
46501 DOUBLE PRECISION RMHIGG(4)
46502 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
46503 DOUBLE COMPLEX DMU,
46504 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46505 & DM1, DM2, DM3
46506C...SLHA Common Block
46507 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46508 & AU(3,3),AD(3,3),AE(3,3)
46509 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
46510
46511 IERR=0
46512 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
46513 IF (IERR.NE.0) THEN
46514 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
46515 & //'Will not use FeynHiggs for this run.')
46516 RETURN
46517 ENDIF
46518 Q=RMSOFT(0)
46519 DMB=PMAS(5,1)
46520 DMT=PMAS(6,1)
46521 DMZ=PMAS(23,1)
46522 DMW=PMAS(24,1)
46523 DMA=PMAS(36,1)
46524 DM1=RMSOFT(1)
46525 DM2=RMSOFT(2)
46526 DM3=RMSOFT(3)
46527 DTANB=RMSS(5)
46528 DMU=RMSS(4)
46529 DM3SL=RMSOFT(33)
46530 DM3SE=RMSOFT(36)
46531 DM3SQ=RMSOFT(43)
46532 DM3SU=RMSOFT(46)
46533 DM3SD=RMSOFT(49)
46534 DM2SL=RMSOFT(32)
46535 DM2SE=RMSOFT(35)
46536 DM2SQ=RMSOFT(42)
46537 DM2SU=RMSOFT(45)
46538 DM2SD=RMSOFT(48)
46539 DM1SL=RMSOFT(31)
46540 DM1SE=RMSOFT(34)
46541 DM1SQ=RMSOFT(41)
46542 DM1SU=RMSOFT(44)
46543 DM1SD=RMSOFT(47)
46544 AE33=AE(3,3)
46545 AE22=AE(2,2)
46546 AE11=AE(1,1)
46547 AU33=AU(3,3)
46548 AU22=AU(2,2)
46549 AU11=AU(1,1)
46550 AD33=AD(3,3)
46551 AD22=AD(2,2)
46552 AD11=AD(1,1)
46553 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
46554 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
46555 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
46556 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
46557 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46558 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
46559 IF (IERR.NE.0) THEN
46560 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
46561 & //' Will not use FeynHiggs for this run.')
46562 RETURN
46563 ENDIF
46564C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
46565 SAEFF=0D0
46566 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
46567 IF (IERR.NE.0) THEN
46568 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
46569 & 'GSCORR. Will not use FeynHiggs for this run.')
46570 RETURN
46571 ENDIF
46572 ALPHA = ASIN(DBLE(SAEFF))
46573 R=RMSS(18)/ALPHA
46574 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
46575 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46576 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
46577 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
46578 ENDIF
46579 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
46580 & 1.15D0*PMAS(25,1)) THEN
46581 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46582 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
46583 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
46584 ENDIF
46585 RMSS(18)=ALPHA
46586 PMAS(25,1)=RMHIGG(1)
46587 PMAS(35,1)=RMHIGG(2)
46588 PMAS(36,1)=RMHIGG(3)
46589 PMAS(37,1)=RMHIGG(4)
46590
46591 RETURN
46592 END
46593
46594C*********************************************************************
46595
46596C...PYRNMQ
46597C...Determines the running mass of Squarks.
46598
46599 FUNCTION PYRNMQ(ID,DTERM)
46600
46601C...Double precision and integer declarations.
46602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46603 IMPLICIT INTEGER(I-N)
46604 INTEGER PYK,PYCHGE,PYCOMP
46605C...Commonblock.
46606 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46607 SAVE /PYMSSM/
46608
46609C...Local variables.
46610 DOUBLE PRECISION PI,R
46611 DOUBLE PRECISION TOL
46612 DOUBLE PRECISION CI(3)
46613 EXTERNAL PYALPS
46614 DOUBLE PRECISION PYALPS
46615 DATA TOL/0.001D0/
46616 DATA PI,R/3.141592654D0,.61803399D0/
46617 DATA CI/0.47D0,0.07D0,0.02D0/
46618
46619 C=1D0-R
46620 CA=CI(ID)
46621 AG=(0.71D0)**2/4D0/PI
46622 AG=RMSS(20)
46623 XM0=RMSS(8)
46624 XMG=RMSS(1)
46625 XM02=XM0*XM0
46626 XMG2=XMG*XMG
46627
46628 AS=PYALPS(XM02+6D0*XMG2)
46629 CG=8D0/9D0*((AS/AG)**2-1D0)
46630 BX=XM02+(CA+CG)*XMG2+DTERM
46631 AX=MIN(50D0**2,0.5D0*BX)
46632 CX=MAX(2000D0**2,2D0*BX)
46633
46634 X0=AX
46635 X3=CX
46636 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46637 X1=BX
46638 X2=BX+C*(CX-BX)
46639 ELSE
46640 X2=BX
46641 X1=BX-C*(BX-AX)
46642 ENDIF
46643 AS1=PYALPS(X1)
46644 CG=8D0/9D0*((AS1/AG)**2-1D0)
46645 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46646 AS2=PYALPS(X2)
46647 CG=8D0/9D0*((AS2/AG)**2-1D0)
46648 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46649 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46650 IF(F2.LT.F1) THEN
46651 X0=X1
46652 X1=X2
46653 X2=R*X1+C*X3
46654 F1=F2
46655 AS2=PYALPS(X2)
46656 CG=8D0/9D0*((AS2/AG)**2-1D0)
46657 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46658 ELSE
46659 X3=X2
46660 X2=X1
46661 X1=R*X2+C*X0
46662 F2=F1
46663 AS1=PYALPS(X1)
46664 CG=8D0/9D0*((AS1/AG)**2-1D0)
46665 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46666 ENDIF
46667 GOTO 100
46668 ENDIF
46669 IF(F1.LT.F2) THEN
46670 PYRNMQ=X1
46671 XMIN=X1
46672 ELSE
46673 PYRNMQ=X2
46674 XMIN=X2
46675 ENDIF
46676
46677 RETURN
46678 END
46679
46680C*********************************************************************
46681
46682C...PYTHRG
46683C...Calculates the mass eigenstates of the third generation sfermions.
46684C...Created: 5-31-96
46685
46686 SUBROUTINE PYTHRG
46687
46688C...Double precision and integer declarations.
46689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46690 IMPLICIT INTEGER(I-N)
46691 INTEGER PYK,PYCHGE,PYCOMP
46692C...Parameter statement to help give large particle numbers.
46693 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46694 &KEXCIT=4000000,KDIMEN=5000000)
46695C...Commonblocks.
46696 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46697 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46698 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46699 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46700 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46701 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46702
46703C...Local variables.
46704 DOUBLE PRECISION BETA
46705 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
46706 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
46707 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
46708 DOUBLE PRECISION ATR,AMQR,AMQL
46709 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
46710 INTEGER IF,I,J,II,JJ,IT,L
46711 LOGICAL DTERM
46712 DATA SMALL/1D-3/
46713 DATA ID1/10,10,13/
46714 DATA ID2/5,6,15/
46715 DATA ID3/15,16,17/
46716 DATA ID4/11,12,14/
46717 DATA DTERM/.TRUE./
46718
46719 XMZ2=PMAS(23,1)**2
46720 XMW2=PMAS(24,1)**2
46721 TANB=RMSS(5)
46722 XMU=-RMSS(4)
46723 BETA=ATAN(TANB)
46724 COS2B=COS(2D0*BETA)
46725
46726C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
46727
46728 IOPT=IMSS(5)
46729 IF(IOPT.EQ.1) THEN
46730 CTT=DCOS(RMSS(27))
46731 CTT2=CTT**2
46732 STT=DSIN(RMSS(27))
46733 STT2=STT**2
46734 XM12=RMSS(10)**2
46735 XM22=RMSS(12)**2
46736 XMQL2=CTT2*XM12+STT2*XM22
46737 XMQR2=STT2*XM12+CTT2*XM22
46738 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
46739 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46740 RMSS(16)=ATOP
46741C......SUBTRACT OUT D-TERM AND FERMION MASS
46742 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
46743 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
46744 IF(XMQL2.GE.0D0) THEN
46745 RMSS(10)=SQRT(XMQL2)
46746 ELSE
46747 RMSS(10)=-SQRT(-XMQL2)
46748 ENDIF
46749 IF(XMQR2.GE.0D0) THEN
46750 RMSS(12)=SQRT(XMQR2)
46751 ELSE
46752 RMSS(12)=-SQRT(-XMQR2)
46753 ENDIF
46754
46755C SAME FOR BOTTOM SQUARK
46756 CTT=DCOS(RMSS(26))
46757 CTT2=CTT**2
46758 STT=DSIN(RMSS(26))
46759 STT2=STT**2
46760 XM22=RMSS(11)**2
46761 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
46762 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
46763 IF(ABS(CTT).GE..9999D0) THEN
46764 ABOT=-XMU*TANB
46765 XMQR2=RMSS(11)**2
46766 ELSEIF(ABS(CTT).LE.1D-4) THEN
46767 ABOT=-XMU*TANB
46768 XMQR2=RMSS(11)**2
46769 ELSE
46770 XM12=(XMQL2-STT2*XM22)/CTT2
46771 XMQR2=STT2*XM12+CTT2*XM22
46772 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46773 ENDIF
46774 RMSS(15)=ABOT
46775C......SUBTRACT OUT D-TERM AND FERMION MASS
46776 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
46777 IF(XMQR2.GE.0D0) THEN
46778 RMSS(11)=SQRT(XMQR2)
46779 ELSE
46780 RMSS(11)=-SQRT(-XMQR2)
46781 ENDIF
46782C SAME FOR TAU SLEPTON
46783 CTT=DCOS(RMSS(28))
46784 CTT2=CTT**2
46785 STT=DSIN(RMSS(28))
46786 STT2=STT**2
46787 XM12=RMSS(13)**2
46788 XM22=RMSS(14)**2
46789 XMQL2=CTT2*XM12+STT2*XM22
46790 XMQR2=STT2*XM12+CTT2*XM22
46791 XMFR=PMAS(15,1)
46792 XMF2=XMFR**2
46793 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46794 RMSS(17)=ATAU
46795C......SUBTRACT OUT D-TERM AND FERMION MASS
46796 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
46797 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
46798 IF(XMQL2.GE.0D0) THEN
46799 RMSS(13)=SQRT(XMQL2)
46800 ELSE
46801 RMSS(13)=-SQRT(-XMQL2)
46802 ENDIF
46803 IF(XMQR2.GE.0D0) THEN
46804 RMSS(14)=SQRT(XMQR2)
46805 ELSE
46806 RMSS(14)=-SQRT(-XMQR2)
46807 ENDIF
46808 ENDIF
46809 DO 170 L=1,3
46810 AMQL=RMSS(ID1(L))
46811 IF(AMQL.LT.0D0) THEN
46812 XMQL2=-AMQL**2
46813 ELSE
46814 XMQL2=AMQL**2
46815 ENDIF
46816 ATR=RMSS(ID3(L))
46817 AMQR=RMSS(ID4(L))
46818 IF(AMQR.LT.0D0) THEN
46819 XMQR2=-AMQR**2
46820 ELSE
46821 XMQR2=AMQR**2
46822 ENDIF
46823 IF=ID2(L)
46824 XMF=PYMRUN(IF,PMAS(6,1)**2)
46825 XMF2=XMF**2
46826 AM2(1,1)=XMQL2+XMF2
46827 AM2(2,2)=XMQR2+XMF2
46828 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
46829 IF(DTERM) THEN
46830 IF(L.EQ.1) THEN
46831 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
46832 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
46833 AM2(1,2)=XMF*(ATR+XMU*TANB)
46834 ELSEIF(L.EQ.2) THEN
46835 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
46836 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
46837 AM2(1,2)=XMF*(ATR+XMU/TANB)
46838 ELSEIF(L.EQ.3) THEN
46839 IF(IMSS(8).EQ.1) THEN
46840 AM2(1,1)=RMSS(6)**2
46841 AM2(2,2)=RMSS(7)**2
46842 AM2(1,2)=0D0
46843 RMSS(13)=RMSS(6)
46844 RMSS(14)=RMSS(7)
46845 ELSE
46846 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
46847 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
46848 AM2(1,2)=XMF*(ATR+XMU*TANB)
46849 ENDIF
46850 ENDIF
46851 ENDIF
46852 AM2(2,1)=AM2(1,2)
46853 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
46854 IF(DETM.LT.0D0) THEN
46855 WRITE(MSTU(11),*) ID2(L),DETM,AM2
46856 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
46857 ENDIF
46858 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
46859 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
46860 XMF12=SAME-DIFF
46861 XMF22=SAME+DIFF
46862 IT=0
46863 IF(XMF22-XMF12.GT.0D0) THEN
46864 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
46865 RT(2,2) = RT(1,1)
46866 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
46867 & AM2(1,2)/(XMF22-XMF12))
46868 RT(2,1) = -RT(1,2)
46869 ELSE
46870 RT(1,1) = 1D0
46871 RT(2,2) = RT(1,1)
46872 RT(1,2) = 0D0
46873 RT(2,1) = -RT(1,2)
46874 ENDIF
46875 100 CONTINUE
46876 IT=IT+1
46877
46878 DO 140 I=1,2
46879 DO 130 JJ=1,2
46880 DI(I,JJ)=0D0
46881 DO 120 II=1,2
46882 DO 110 J=1,2
46883 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
46884 110 CONTINUE
46885 120 CONTINUE
46886 130 CONTINUE
46887 140 CONTINUE
46888
46889 IF(DI(1,1).GT.DI(2,2)) THEN
46890 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
46891 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
46892 WRITE(MSTU(11),*) AM2
46893 WRITE(MSTU(11),*) DI
46894 WRITE(MSTU(11),*) RT
46895 DI(1,1)=-RT(2,1)
46896 DI(2,2)=RT(1,2)
46897 DI(1,2)=-RT(2,2)
46898 DI(2,1)=RT(1,1)
46899 DO 160 I=1,2
46900 DO 150 J=1,2
46901 RT(I,J)=DI(I,J)
46902 150 CONTINUE
46903 160 CONTINUE
46904 GOTO 100
46905 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
46906 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46907 & ' OFF DIAGONAL ELEMENTS '
46908 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
46909 WRITE(MSTU(11),*) DI
46910 WRITE(MSTU(11),*) ' ROTATION = ',RT
46911C...STOP
46912 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
46913 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46914 & ' NEGATIVE MASSES '
46915 CALL PYSTOP(111)
46916 ENDIF
46917 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
46918 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
46919 SFMIX(IF,1)=RT(1,1)
46920 SFMIX(IF,2)=RT(1,2)
46921 SFMIX(IF,3)=RT(2,1)
46922 SFMIX(IF,4)=RT(2,2)
46923 170 CONTINUE
46924
46925C.....TAU SNEUTRINO MASS...L=3
46926
46927 XARG=AM2(1,1)+XMW2*COS2B
46928 IF(XARG.LT.0D0) THEN
46929 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
46930 & ' FROM THE SUM RULE. '
46931 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46932 RETURN
46933 ELSE
46934 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
46935 ENDIF
46936
46937 RETURN
46938 END
46939C*********************************************************************
46940
46941C...PYINOM
46942C...Finds the mass eigenstates and mixing matrices for neutralinos
46943C...and charginos.
46944
46945 SUBROUTINE PYINOM
46946
46947C...Double precision and integer declarations.
46948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46949 IMPLICIT INTEGER(I-N)
46950 INTEGER PYCOMP
46951C...Parameter statement to help give large particle numbers.
46952 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46953 &KEXCIT=4000000,KDIMEN=5000000)
46954C...Commonblocks.
46955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46956 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46957 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46958 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46959 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46960 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46961
46962C...Local variables.
46963 DOUBLE PRECISION XMW,XMZ,XM(4)
46964 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
46965 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
46966 DOUBLE PRECISION COSW,SINW
46967 DOUBLE PRECISION XMU
46968 DOUBLE PRECISION TANB,COSB,SINB
46969 DOUBLE PRECISION XM1,XM2,XM3,BETA
46970 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
46971 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
46972 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
46973 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
46974 DOUBLE PRECISION PYALPS,PYALEM
46975 DOUBLE PRECISION PYRNM3
46976 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
46977 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
46978 DATA KFNCHI/1000022,1000023,1000025,1000035/
46979
46980 IOPT=IMSS(2)
46981 IF(IMSS(1).EQ.2) THEN
46982 IOPT=1
46983 ENDIF
46984C...M1, M2, AND M3 ARE INDEPENDENT
46985 IF(IOPT.EQ.0) THEN
46986 XM1=RMSS(1)
46987 XM2=RMSS(2)
46988 XM3=RMSS(3)
46989 ELSEIF(IOPT.GE.1) THEN
46990 Q2=PMAS(23,1)**2
46991 AEM=PYALEM(Q2)
46992 A2=AEM/PARU(102)
46993 A1=AEM/(1D0-PARU(102))
46994 XM1=RMSS(1)
46995 XM2=RMSS(2)
46996 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
46997 IF(IOPT.EQ.1) THEN
46998 XM2=XM1*A2/A1*3D0/5D0
46999 RMSS(2)=XM2
47000 ELSEIF(IOPT.EQ.3) THEN
47001 XM1=XM2*5D0/3D0*A1/A2
47002 RMSS(1)=XM1
47003 ENDIF
47004 XM3=PYRNM3(XM2/A2)
47005 RMSS(3)=XM3
47006 IF(XM3.LE.0D0) THEN
47007 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47008 CALL PYSTOP(105)
47009 ENDIF
47010 ENDIF
47011
47012C...GLUINO MASS
47013 IF(IMSS(3).EQ.1) THEN
47014 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
47015 ELSE
47016 AQ=0D0
47017 DO 110 I=1,4
47018 DO 100 ILR=1,2
47019 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47020 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
47021 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
47022 100 CONTINUE
47023 110 CONTINUE
47024
47025 DO 130 I=5,6
47026 DO 120 ILR=1,2
47027 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47028 RM2=PMAS(I,1)**2/XM3**2
47029 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
47030 IF(ARG.GE.0D0) THEN
47031 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
47032 AX0=ABS(X0)
47033 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
47034 AX1=ABS(X1)
47035 IF(X0.EQ.1D0) THEN
47036 AT=-1D0
47037 BT=0.25D0
47038 ELSEIF(X0.EQ.0D0) THEN
47039 AT=0D0
47040 BT=-0.25D0
47041 ELSE
47042 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
47043 & 0.5D0*X0**2*LOG(AX0)
47044 BT=(-1D0-2D0*X0)/4D0
47045 ENDIF
47046 IF(X1.EQ.1D0) THEN
47047 AT=-1D0+AT
47048 BT=0.25D0+BT
47049 ELSEIF(X1.EQ.0D0) THEN
47050 AT=0D0+AT
47051 BT=-0.25D0+BT
47052 ELSE
47053 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
47054 & X1**2*LOG(AX1)+AT
47055 BT=(-1D0-2D0*X1)/4D0+BT
47056 ENDIF
47057 AQ=AQ+AT+BT
47058 ELSE
47059 X0=0.5D0*(1D0+RM2-RM1)
47060 Y0=-0.5D0*SQRT(-ARG)
47061 AMGX0=SQRT(X0**2+Y0**2)
47062 AM1X0=SQRT((1D0-X0)**2+Y0**2)
47063 ARGX0=ATAN2(-X0,-Y0)
47064 AR1X0=ATAN2(1D0-X0,Y0)
47065 X1=X0
47066 Y1=-Y0
47067 AMGX1=AMGX0
47068 AM1X1=AM1X0
47069 ARGX1=ATAN2(-X1,-Y1)
47070 AR1X1=ATAN2(1D0-X1,Y1)
47071 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
47072 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
47073 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
47074 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
47075 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
47076 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
47077 AQ=AQ+AT+BT
47078 ENDIF
47079 120 CONTINUE
47080 130 CONTINUE
47081 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
47082 & /(2D0*PARU(2))*(15D0+AQ))
47083 ENDIF
47084
47085C...NEUTRALINO MASSES
47086 DO 150 I=1,4
47087 DO 140 J=1,4
47088 AI(I,J)=0D0
47089 140 CONTINUE
47090 150 CONTINUE
47091 XMZ=PMAS(23,1)/100D0
47092 XMW=PMAS(24,1)/100D0
47093 XMU=RMSS(4)/100D0
47094 SINW=SQRT(PARU(102))
47095 COSW=SQRT(1D0-PARU(102))
47096 TANB=RMSS(5)
47097 BETA=ATAN(TANB)
47098 COSB=COS(BETA)
47099 SINB=TANB*COSB
47100
47101 XM2=XM2/100D0
47102 XM1=XM1/100D0
47103
47104
47105C... Definitions:
47106C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47107C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47108 AR(1,1) = XM1*COS(RMSS(30))
47109 AI(1,1) = XM1*SIN(RMSS(30))
47110 AR(2,2) = XM2*COS(RMSS(31))
47111 AI(2,2) = XM2*SIN(RMSS(31))
47112 AR(3,3) = 0D0
47113 AR(4,4) = 0D0
47114 AR(1,2) = 0D0
47115 AR(2,1) = 0D0
47116 AR(1,3) = -XMZ*SINW*COSB
47117 AR(3,1) = AR(1,3)
47118 AR(1,4) = XMZ*SINW*SINB
47119 AR(4,1) = AR(1,4)
47120 AR(2,3) = XMZ*COSW*COSB
47121 AR(3,2) = AR(2,3)
47122 AR(2,4) = -XMZ*COSW*SINB
47123 AR(4,2) = AR(2,4)
47124 AR(3,4) = -XMU*COS(RMSS(33))
47125 AI(3,4) = -XMU*SIN(RMSS(33))
47126 AR(4,3) = -XMU*COS(RMSS(33))
47127 AI(4,3) = -XMU*SIN(RMSS(33))
47128C CALL PYEIG4(AR,WR,ZR)
47129 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47130 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47131 & 'PROBLEM WITH PYEICG IN PYINOM ')
47132 DO 160 I=1,4
47133 INDEX(I)=I
47134 XM(I)=ABS(WR(I))
47135 160 CONTINUE
47136 DO 180 I=2,4
47137 K=I
47138 DO 170 J=I-1,1,-1
47139 IF(XM(K).LT.XM(J)) THEN
47140 ITMP=INDEX(J)
47141 XTMP=XM(J)
47142 INDEX(J)=INDEX(K)
47143 XM(J)=XM(K)
47144 INDEX(K)=ITMP
47145 XM(K)=XTMP
47146 K=K-1
47147 ELSE
47148 GOTO 180
47149 ENDIF
47150 170 CONTINUE
47151 180 CONTINUE
47152
47153
47154 DO 210 I=1,4
47155 K=INDEX(I)
47156 SMZ(I)=WR(K)*100D0
47157 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
47158 S=0D0
47159 DO 190 J=1,4
47160 S=S+ZR(J,K)**2+ZI(J,K)**2
47161 190 CONTINUE
47162 DO 200 J=1,4
47163 ZMIX(I,J)=ZR(J,K)/SQRT(S)
47164 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
47165 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
47166 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
47167 200 CONTINUE
47168 210 CONTINUE
47169
47170C...CHARGINO MASSES
47171C.....Find eigenvectors of X X^*
47172 DO I=1,4
47173 DO J=1,4
47174 AR(I,J)=0D0
47175 AI(I,J)=0D0
47176 ENDDO
47177 ENDDO
47178 AI(1,1) = 0D0
47179 AI(2,2) = 0D0
47180 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
47181 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
47182 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47183 &XMU*COS(RMSS(33))*SINB)
47184 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
47185 &XMU*SIN(RMSS(33))*SINB)
47186 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47187 &XMU*COS(RMSS(33))*SINB)
47188 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
47189 &XMU*SIN(RMSS(33))*SINB)
47190 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47191 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47192 & 'PROBLEM WITH PYEICG IN PYINOM ')
47193 INDEX(1)=1
47194 INDEX(2)=2
47195 IF(WR(2).LT.WR(1)) THEN
47196 INDEX(1)=2
47197 INDEX(2)=1
47198 ENDIF
47199
47200
47201 DO 240 I=1,2
47202 K=INDEX(I)
47203 SMW(I)=SQRT(WR(K))*100D0
47204 S=0D0
47205 DO 220 J=1,2
47206 S=S+ZR(J,K)**2+ZI(J,K)**2
47207 220 CONTINUE
47208 DO 230 J=1,2
47209 UMIX(I,J)=ZR(J,K)/SQRT(S)
47210 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
47211 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
47212 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
47213 230 CONTINUE
47214 240 CONTINUE
47215C...Force chargino mass > neutralino mass
47216 IFRC=0
47217 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
47218 CALL PYERRM(18,'(PYINOM:) '//
47219 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
47220 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
47221 IFRC=1
47222 ENDIF
47223 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
47224 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
47225
47226C.....Find eigenvectors of X^* X
47227 DO I=1,4
47228 DO J=1,4
47229 AR(I,J)=0D0
47230 AI(I,J)=0D0
47231 ZR(I,J)=0D0
47232 ZI(I,J)=0D0
47233 ENDDO
47234 ENDDO
47235 AI(1,1) = 0D0
47236 AI(2,2) = 0D0
47237 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
47238 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
47239 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47240 &XMU*COS(RMSS(33))*COSB)
47241 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
47242 &XMU*SIN(RMSS(33))*COSB)
47243 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47244 &XMU*COS(RMSS(33))*COSB)
47245 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
47246 &XMU*SIN(RMSS(33))*COSB)
47247 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47248 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47249 & 'PROBLEM WITH PYEICG IN PYINOM ')
47250 INDEX(1)=1
47251 INDEX(2)=2
47252 IF(WR(2).LT.WR(1)) THEN
47253 INDEX(1)=2
47254 INDEX(2)=1
47255 ENDIF
47256
47257 SIMAG=0D0
47258 DO 270 I=1,2
47259 K=INDEX(I)
47260 S=0D0
47261 DO 250 J=1,2
47262 S=S+ZR(J,K)**2+ZI(J,K)**2
47263 SIMAG=SIMAG+ZI(J,K)**2
47264 250 CONTINUE
47265 DO 260 J=1,2
47266 VMIX(I,J)=ZR(J,K)/SQRT(S)
47267 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
47268 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
47269 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
47270 260 CONTINUE
47271 270 CONTINUE
47272
47273C.....Simplify if no phases
47274 IF(SIMAG.LT.1D-6) THEN
47275 AR(1,1) = XM2*COS(RMSS(31))
47276 AR(2,2) = XMU*COS(RMSS(33))
47277 AR(1,2) = SQRT(2D0)*XMW*SINB
47278 AR(2,1) = SQRT(2D0)*XMW*COSB
47279 IKNT=0
47280 300 CONTINUE
47281 DO I=1,2
47282 DO J=1,2
47283 ZR(I,J)=0D0
47284 ENDDO
47285 ENDDO
47286
47287 DO I=1,2
47288 DO J=1,2
47289 DO K=1,2
47290 DO L=1,2
47291 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
47292 ENDDO
47293 ENDDO
47294 ENDDO
47295 ENDDO
47296 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
47297 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
47298 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
47299 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
47300 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47301 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47302 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
47303 IKNT=IKNT+1
47304 GOTO 300
47305 ENDIF
47306C.....Must deal with phases
47307 ELSE
47308 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
47309 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
47310 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
47311 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
47312
47313 IKNT=0
47314 310 CONTINUE
47315 DO I=1,2
47316 DO J=1,2
47317 CAI(I,J)=CMPLX(0D0,0D0)
47318 ENDDO
47319 ENDDO
47320
47321 DO I=1,2
47322 DO J=1,2
47323 DO K=1,2
47324 DO L=1,2
47325 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
47326 & CMPLX(VMIX(J,L),VMIXI(J,L))
47327 ENDDO
47328 ENDDO
47329 ENDDO
47330 ENDDO
47331
47332 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
47333 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
47334 TEMPR=VMIX(1,1)
47335 TEMPI=VMIXI(1,1)
47336 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47337 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47338 TEMPR=VMIX(1,2)
47339 TEMPI=VMIXI(1,2)
47340 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47341 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47342 TEMPR=VMIX(2,1)
47343 TEMPI=VMIXI(2,1)
47344 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47345 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47346 TEMPR=VMIX(2,2)
47347 TEMPI=VMIXI(2,2)
47348 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47349 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47350 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47351 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47352 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
47353 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
47354 IKNT=IKNT+1
47355 GOTO 310
47356 ENDIF
47357 ENDIF
47358 RETURN
47359 END
47360
47361C*********************************************************************
47362
47363C...PYRNM3
47364C...Calculates the running of M3, the SU(3) gluino mass parameter.
47365
47366 FUNCTION PYRNM3(RGUT)
47367
47368C...Double precision and integer declarations.
47369 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47370 IMPLICIT INTEGER(I-N)
47371 INTEGER PYK,PYCHGE,PYCOMP
47372
47373C...Local variables.
47374 DOUBLE PRECISION R
47375 DOUBLE PRECISION TOL
47376 EXTERNAL PYALPS
47377 DOUBLE PRECISION PYALPS
47378 DATA TOL/0.001D0/
47379 DATA R/0.61803399D0/
47380
47381 C=1D0-R
47382
47383 BX=RGUT*PYALPS(RGUT**2)
47384 AX=MIN(50D0,BX*0.5D0)
47385 CX=MAX(2000D0,2D0*BX)
47386
47387 X0=AX
47388 X3=CX
47389 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47390 X1=BX
47391 X2=BX+C*(CX-BX)
47392 ELSE
47393 X2=BX
47394 X1=BX-C*(BX-AX)
47395 ENDIF
47396 AS1=PYALPS(X1**2)
47397 F1=ABS(X1-RGUT*AS1)
47398 AS2=PYALPS(X2**2)
47399 F2=ABS(X2-RGUT*AS2)
47400 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47401 IF(F2.LT.F1) THEN
47402 X0=X1
47403 X1=X2
47404 X2=R*X1+C*X3
47405 F1=F2
47406 AS2=PYALPS(X2**2)
47407 F2=ABS(X2-RGUT*AS2)
47408 ELSE
47409 X3=X2
47410 X2=X1
47411 X1=R*X2+C*X0
47412 F2=F1
47413 AS1=PYALPS(X1**2)
47414 F1=ABS(X1-RGUT*AS1)
47415 ENDIF
47416 GOTO 100
47417 ENDIF
47418 IF(F1.LT.F2) THEN
47419 PYRNM3=X1
47420 XMIN=X1
47421 ELSE
47422 PYRNM3=X2
47423 XMIN=X2
47424 ENDIF
47425
47426 RETURN
47427 END
47428
47429C*********************************************************************
47430
47431C...PYEIG4
47432C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
47433C...Specific application: mixing in neutralino sector.
47434
47435 SUBROUTINE PYEIG4(A,W,Z)
47436
47437C...Double precision and integer declarations.
47438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47439 IMPLICIT INTEGER(I-N)
47440 INTEGER PYK,PYCHGE,PYCOMP
47441
47442C...Arrays: in call and local.
47443 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
47444
47445C...Coefficients of fourth-degree equation from matrix.
47446C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
47447 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
47448 B2=0D0
47449 DO 110 I=1,3
47450 DO 100 J=I+1,4
47451 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
47452 100 CONTINUE
47453 110 CONTINUE
47454 B1=0D0
47455 B0=0D0
47456 DO 120 I=1,4
47457 I1=MOD(I,4)+1
47458 I2=MOD(I+1,4)+1
47459 I3=MOD(I+2,4)+1
47460 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
47461 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
47462 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
47463 B0=B0+(-1D0)**(I+1)*A(1,I)*(
47464 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
47465 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
47466 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
47467 120 CONTINUE
47468
47469C...Coefficients of third-degree equation needed for
47470C...separation into two second-degree equations.
47471C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
47472 C2=-B2
47473 C1=B1*B3-4D0*B0
47474 C0=-B1**2-B0*B3**2+4D0*B0*B2
47475 CQ=C1/3D0-C2**2/9D0
47476 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
47477 CQR=CQ**3+CR**2
47478
47479C...Cases with one or three real roots.
47480 IF(CQR.GE.0D0) THEN
47481 S1=(CR+SQRT(CQR))**(1D0/3D0)
47482 S2=(CR-SQRT(CQR))**(1D0/3D0)
47483 U=S1+S2-C2/3D0
47484 ELSE
47485 SABS=SQRT(-CQ)
47486 THE=ACOS(CR/SABS**3)/3D0
47487 SRE=SABS*COS(THE)
47488 U=2D0*SRE-C2/3D0
47489 ENDIF
47490
47491C...Find and solve two second-degree equations.
47492 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
47493 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
47494 Q1=U/2D0+SQRT(U**2/4D0-B0)
47495 Q2=U/2D0-SQRT(U**2/4D0-B0)
47496 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
47497 QSAV=Q1
47498 Q1=Q2
47499 Q2=QSAV
47500 ENDIF
47501 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
47502 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
47503 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
47504 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
47505
47506C...Order eigenvalues in asceding mass.
47507 W(1)=X(1)
47508 DO 150 I1=2,4
47509 DO 130 I2=I1-1,1,-1
47510 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
47511 W(I2+1)=W(I2)
47512 130 CONTINUE
47513 140 W(I2+1)=X(I1)
47514 150 CONTINUE
47515
47516C...Find equation system for eigenvectors.
47517 DO 250 I=1,4
47518 DO 170 J1=1,4
47519 D(J1,J1)=A(J1,J1)-W(I)
47520 DO 160 J2=J1+1,4
47521 D(J1,J2)=A(J1,J2)
47522 D(J2,J1)=A(J2,J1)
47523 160 CONTINUE
47524 170 CONTINUE
47525
47526C...Find largest element in matrix.
47527 DAMAX=0D0
47528 DO 190 J1=1,4
47529 DO 180 J2=1,4
47530 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
47531 JA=J1
47532 JB=J2
47533 DAMAX=ABS(D(J1,J2))
47534 180 CONTINUE
47535 190 CONTINUE
47536
47537C...Subtract others by multiple of row selected above.
47538 DAMAX=0D0
47539 DO 210 J3=JA+1,JA+3
47540 J1=J3-4*((J3-1)/4)
47541 RL=D(J1,JB)/D(JA,JB)
47542 DO 200 J2=1,4
47543 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
47544 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
47545 JC=J1
47546 JD=J2
47547 DAMAX=ABS(D(J1,J2))
47548 200 CONTINUE
47549 210 CONTINUE
47550
47551C...Do one more subtraction of a row.
47552 DAMAX=0D0
47553 DO 230 J3=JC+1,JC+3
47554 J1=J3-4*((J3-1)/4)
47555 IF(J1.EQ.JA) GOTO 230
47556 RL=D(J1,JD)/D(JC,JD)
47557 DO 220 J2=1,4
47558 IF(J2.EQ.JB) GOTO 220
47559 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
47560 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
47561 JE=J1
47562 DAMAX=ABS(D(J1,J2))
47563 220 CONTINUE
47564 230 CONTINUE
47565
47566C...Construct unnormalized eigenvector.
47567 JF1=JD+1-4*(JD/4)
47568 JF2=JD+2-4*((JD+1)/4)
47569 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
47570 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
47571 E(JF1)=-D(JE,JF2)
47572 E(JF2)=D(JE,JF1)
47573 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
47574 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
47575 & D(JA,JB)
47576
47577C...Normalize and fill in final array.
47578 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
47579 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47580 DO 240 J=1,4
47581 Z(I,J)=SGN*E(J)/EA
47582 240 CONTINUE
47583 250 CONTINUE
47584
47585 RETURN
47586 END
47587
47588C*********************************************************************
47589
47590C...PYHGGM
47591C...Determines the Higgs boson mass spectrum using several inputs.
47592
47593 SUBROUTINE PYHGGM(ALPHA)
47594
47595C...Double precision and integer declarations.
47596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47597 IMPLICIT INTEGER(I-N)
47598 INTEGER PYK,PYCHGE,PYCOMP
47599C...Parameter statement to help give large particle numbers.
47600 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47601 &KEXCIT=4000000,KDIMEN=5000000)
47602C...Commonblocks.
47603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47605 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47606 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47607 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
47608
47609C...Local variables.
47610 DOUBLE PRECISION AT,AB,XMU,TANB
47611 DOUBLE PRECISION ALPHA
47612 INTEGER IHOPT
47613 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
47614 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
47615 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
47616 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
47617
47618 IHOPT=IMSS(4)
47619 IF(IHOPT.EQ.2) THEN
47620 ALPHA=RMSS(18)
47621 RETURN
47622 ENDIF
47623 AT=RMSS(16)
47624 AB=RMSS(15)
47625 DMGL=RMSS(3)
47626 XMU=RMSS(4)
47627 TANB=RMSS(5)
47628
47629 DMA=RMSS(19)
47630 DTANB=TANB
47631 DMQ=RMSS(10)
47632 DMUR=RMSS(12)
47633 DMDR=RMSS(11)
47634 DMTOP=PMAS(6,1)
47635 DMC=PMAS(PYCOMP(KSUSY1+37),1)
47636 DAU=AT
47637 DAD=AB
47638 DMU=XMU
47639 RMSS(40)=0D0
47640 RMSS(41)=0D0
47641
47642 IF(IHOPT.EQ.0) THEN
47643 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47644 & DMHCH,DSA,DCA,DTANBA)
47645 ELSEIF(IHOPT.EQ.1) THEN
47646 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47647 & DMHCH,DSA,DCA,DTANBA)
47648 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
47649 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
47650 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
47651 RMSS(40)=DDT
47652 RMSS(41)=DDB
47653 DMH=DMHP
47654 DHM=DHMP
47655 DMA=DAMP
47656 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
47657 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
47658 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
47659 & PMAS(PYCOMP(1000006),1),DSTOP2
47660 ENDIF
47661 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
47662 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
47663 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
47664 & PMAS(PYCOMP(2000006),1),DSTOP1
47665 ENDIF
47666 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
47667 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
47668 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
47669 & PMAS(PYCOMP(1000005),1),DSBOT2
47670 ENDIF
47671 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
47672 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
47673 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
47674 & PMAS(PYCOMP(2000005),1),DSBOT1
47675 ENDIF
47676
47677 ELSEIF (IHOPT.EQ.3) THEN
47678c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
47679C...Currently only available for SLHA spectrum read-in.
47680 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
47681 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
47682 & //' spectrum, change IMSS(1) or IMSS(4) option.')
47683 ENDIF
47684 ALPHA=RMSS(18)
47685 RETURN
47686 ENDIF
47687
47688 ALPHA=ACOS(DCA)
47689
47690 PMAS(25,1)=DMH
47691 PMAS(35,1)=DHM
47692 PMAS(36,1)=DMA
47693 PMAS(37,1)=DMHCH
47694
47695 RETURN
47696 END
47697
47698C*********************************************************************
47699
47700C...PYSUBH
47701C...This routine computes the renormalization group improved
47702C...values of Higgs masses and couplings in the MSSM.
47703
47704C...Program based on the work by M. Carena, J.R. Espinosa,
47705c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
47706
47707C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
47708C...All masses in GeV units. MA is the CP-odd Higgs mass,
47709C...MTOP is the physical top mass, MQ and MUR are the soft
47710C...supersymmetry breaking mass parameters of left handed
47711C...and right handed stops respectively, AU and AD are the
47712C...stop and sbottom trilinear soft breaking terms,
47713C...respectively, and MU is the supersymmetric
47714C...Higgs mass parameter. We use the conventions from
47715C...the physics report of Haber and Kane: left right
47716C...stop mixing term proportional to (AU - MU/TANB)
47717C...We use as input TANB defined at the scale MTOP
47718
47719C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
47720C...where MH and HM are the lightest and heaviest CP-even
47721C...Higgs masses, MHCH is the charged Higgs mass and
47722C...ALPHA is the Higgs mixing angle
47723C...TANBA is the angle TANB at the CP-odd Higgs mass scale
47724
47725C...Range of validity:
47726C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
47727C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
47728C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
47729C...are the sbottom mass eigenvalues, respectively. This
47730C...range automatically excludes the existence of tachyons.
47731C...For the charged Higgs mass computation, the method is
47732C...valid if
47733C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
47734C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
47735C...where M_SUSY**2 is the average of the squared stop mass
47736C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
47737C...masses have been assumed to be of order of the stop ones
47738C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
47739
47740 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
47741 &XMHCH,SA,CA,TANBA)
47742
47743C...Double precision and integer declarations.
47744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47745 IMPLICIT INTEGER(I-N)
47746 INTEGER PYK,PYCHGE,PYCOMP
47747C...Parameter statement to help give large particle numbers.
47748 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47749 &KEXCIT=4000000,KDIMEN=5000000)
47750C...Commonblocks.
47751 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47752 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47753 COMMON/PYHTRI/HHH(7)
47754 SAVE /PYDAT1/,/PYDAT2/
47755
47756C...Local variables.
47757 DOUBLE PRECISION PYALEM,PYALPS
47758 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
47759 DOUBLE PRECISION XMHCH,SA,CA
47760 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
47761 DOUBLE PRECISION Q02
47762 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
47763 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
47764 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
47765 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
47766 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
47767 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
47768 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
47769 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
47770
47771 XMZ = PMAS(23,1)
47772 Q02=XMZ**2
47773 AEM=PYALEM(Q02)
47774 ALP1=AEM/(1D0-PARU(102))
47775 ALP2=AEM/PARU(102)
47776 ALPH3Z=PYALPS(Q02)
47777
47778 ALP1 = 0.0101D0
47779 ALP2 = 0.0337D0
47780 ALPH3Z = 0.12D0
47781
47782 V = 174.1D0
47783 PI = PARU(1)
47784 TANBA = TANB
47785 TANBT = TANB
47786
47787C...MBOTTOM(MTOP) = 3. GEV
47788 XMB = PYMRUN(5,XMTOP**2)
47789 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
47790 &LOG(XMTOP**2/XMZ**2))
47791
47792C...RMTOP= RUNNING TOP QUARK MASS
47793 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
47794 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
47795 T = LOG(XMS**2/XMTOP**2)
47796 SINB = TANB/((1D0 + TANB**2)**0.5D0)
47797 COSB = SINB/TANB
47798C...IF(MA.LE.XMTOP) TANBA = TANBT
47799 IF(XMA.GT.XMTOP)
47800 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
47801 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
47802 &LOG(XMA**2/XMTOP**2))
47803
47804 SINBT = TANBT/SQRT(1D0 + TANBT**2)
47805 COSBT = 1D0/SQRT(1D0 + TANBT**2)
47806C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
47807 G1 = SQRT(ALP1*4D0*PI)
47808 G2 = SQRT(ALP2*4D0*PI)
47809 G3 = SQRT(ALP3*4D0*PI)
47810 HU = RMTOP/V/SINBT
47811 HD = XMB/V/COSBT
47812 HU2=HU*HU
47813 HD2=HD*HD
47814 HU4=HU2*HU2
47815 HD4=HD2*HD2
47816 AU2=AU**2
47817 AD2=AD**2
47818 XMS2=XMS**2
47819 XMS3=XMS**3
47820 XMS4=XMS2*XMS2
47821 XMU2=XMU*XMU
47822 PI2=PI*PI
47823
47824 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
47825 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
47826 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
47827 &+ 3D0*(AU + AD)**2/XMS2)/6D0
47828 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
47829 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
47830 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
47831 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
47832 &- 16D0*G3**2) *T/16D0/PI2)
47833 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
47834 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
47835 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
47836 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
47837 &- 16D0*G3**2) *T/16D0/PI2)
47838 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47839 &(HU2 + HD2)*T/16D0/PI2)
47840 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47841 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47842 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47843 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
47844 &- 16D0*G3**2) *T/16D0/PI2)
47845 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47846 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
47847 &- 16D0*G3**2) *T/16D0/PI2)
47848 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
47849 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47850 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47851 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47852 &XMS4)*
47853 &(1+ (6D0*HU2 -2D0* HD2
47854 &- 16D0*G3**2) *T/16D0/PI2)
47855 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47856 &XMS4)*
47857 &(1+ (6D0*HD2 -2D0* HU2/2D0
47858 &- 16D0*G3**2) *T/16D0/PI2)
47859 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
47860 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
47861 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
47862 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
47863 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
47864 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47865 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
47866 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47867 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
47868 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47869 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
47870 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47871 HHH(1)=XLAM1
47872 HHH(2)=XLAM2
47873 HHH(3)=XLAM3
47874 HHH(4)=XLAM4
47875 HHH(5)=XLAM5
47876 HHH(6)=XLAM6
47877 HHH(7)=XLAM7
47878 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
47879 &2D0* XLAM6*SINBT*COSBT
47880 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
47881 &+ XLAM5*COSBT**2)
47882 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
47883 &XLAM6*COSBT**2
47884 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
47885 &2D0* XLAM6* COSBT*SINBT
47886 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47887 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
47888 &((XLAM1* COSBT**2 +2D0*
47889 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
47890 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
47891 &*SINBT**2
47892 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
47893 &+ XLAM4) + XLAM6*COSBT**2
47894 &+ XLAM7* SINBT**2))
47895
47896 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
47897 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
47898 XHM = SQRT(XHM2)
47899 XMH = SQRT(XMH2)
47900 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
47901 XMHCH = SQRT(XMHCH2)
47902
47903 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47904 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47905 &XLAM6* COSBT*SINBT
47906 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47907 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47908 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
47909 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
47910
47911 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
47912 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
47913 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
47914 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
47915 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47916 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47917 &XLAM6* COSBT*SINBT
47918 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47919 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47920 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
47921
47922 SA = -SINALP
47923 CA = -COSALP
47924
47925 100 CONTINUE
47926
47927 RETURN
47928 END
47929
47930C*********************************************************************
47931
47932C...PYPOLE
47933C...This subroutine computes the CP-even higgs and CP-odd pole
47934c...Higgs masses and mixing angles.
47935
47936C...Program based on the work by M. Carena, M. Quiros
47937C...and C.E.M. Wagner, "Effective potential methods and
47938C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
47939
47940C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
47941C...AT,AB,MU
47942C...where MCHI is the largest chargino mass, MA is the running
47943C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
47944C...expectaion values at the scale MTOP, MQ is the third generation
47945C...left handed squark mass parameter, MUR is the third generation
47946C...right handed stop mass parameter, MDR is the third generation
47947C...right handed sbottom mass parameter, MTOP is the pole top quark
47948C...mass; AT,AB are the soft supersymmetry breaking trilinear
47949C...couplings of the stop and sbottoms, respectively, and MU is the
47950C...supersymmetric mass parameter
47951
47952C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
47953C...Higgses whose pole mass is computed. If IHIGGS=0 only running
47954C...masses are given, what makes the running of the program
47955c...much faster and it is quite generally a good approximation
47956c...(for a theoretical discussion see ref. above). If IHIGGS=1,
47957C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
47958c...and if IHIGGS=3, then h,H,A polarizations are computed
47959
47960C...Output: MH and MHP which are the lightest CP-even Higgs running
47961C...and pole masses, respectively; HM and HMP are the heaviest CP-even
47962C...Higgs running and pole masses, repectively; SA and CA are the
47963C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
47964C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
47965C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
47966C...the value of TANB at the CP-odd Higgs mass scale
47967
47968C...This subroutine makes use of CERN library subroutine
47969C...integration package, which makes the computation of the
47970C...pole Higgs masses somewhat faster. We thank P. Janot for this
47971C...improvement. Those who are not able to call the CERN
47972C...libraries, please use the subroutine SUBHPOLE2.F, which
47973C...although somewhat slower, gives identical results
47974
47975 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
47976 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
47977
47978C...Double precision and integer declarations.
47979 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47980 IMPLICIT INTEGER(I-N)
47981
47982C...Parameters.
47983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47984 SAVE /PYDAT1/
47985 INTEGER PYK,PYCHGE,PYCOMP
47986
47987C...Local variables.
47988 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
47989 &SSBOT2(2),B(2,2),COUPB(2,2),
47990 &HCOUPT(2,2),HCOUPB(2,2),
47991 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
47992
47993 DELTA(1,1) = 1D0
47994 DELTA(2,2) = 1D0
47995 DELTA(1,2) = 0D0
47996 DELTA(2,1) = 0D0
47997 V = 174.1D0
47998 XMZ=91.18D0
47999 PI=PARU(1)
48000 RXMT=PYMRUN(6,XMT**2)
48001 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48002 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48003
48004 SINB = TANB/(TANB**2+1D0)**0.5D0
48005 COSB = 1D0/(TANB**2+1D0)**0.5D0
48006 COS2B = SINB**2 - COSB**2
48007 SINBPA = SINB*CA + COSB*SA
48008 COSBPA = COSB*CA - SINB*SA
48009 RMBOT = PYMRUN(5,XMT**2)
48010 XMQ2 = XMQ**2
48011 XMUR2 = XMUR**2
48012 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48013 XMDR2 = XMDR**2
48014 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48015 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48016 IF(XMST11.LT.0D0) GOTO 500
48017 IF(XMST22.LT.0D0) GOTO 500
48018 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
48019 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
48020 IF(XMSB11.LT.0D0) GOTO 500
48021 IF(XMSB22.LT.0D0) GOTO 500
48022C WMST11 = RXMT**2 + XMQ2
48023C WMST22 = RXMT**2 + XMUR2
48024 XMST12 = RXMT*(AT - XMU/TANB)
48025 XMSB12 = RMBOT*(AB - XMU*TANB)
48026
48027CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48028C...STOP EIGENVALUES CALCULATION
48029CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48030
48031 STOP12 = 0.5D0*(XMST11+XMST22) +
48032 &0.5D0*((XMST11+XMST22)**2 -
48033 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
48034 STOP22 = 0.5D0*(XMST11+XMST22) -
48035 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
48036 &XMST12**2))**0.5D0
48037
48038 IF(STOP22.LT.0D0) GOTO 500
48039 SSTOP2(1) = STOP12
48040 SSTOP2(2) = STOP22
48041 STOP1 = STOP12**0.5D0
48042 STOP2 = STOP22**0.5D0
48043C STOP1W = STOP1
48044C STOP2W = STOP2
48045
48046 IF(XMST12.EQ.0D0) XST11 = 1D0
48047 IF(XMST12.EQ.0D0) XST12 = 0D0
48048 IF(XMST12.EQ.0D0) XST21 = 0D0
48049 IF(XMST12.EQ.0D0) XST22 = 1D0
48050
48051 IF(XMST12.EQ.0D0) GOTO 110
48052
48053 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48054 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48055 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48056 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48057
48058 110 T(1,1) = XST11
48059 T(2,2) = XST22
48060 T(1,2) = XST12
48061 T(2,1) = XST21
48062
48063 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
48064 &0.5D0*((XMSB11+XMSB22)**2 -
48065 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
48066 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
48067 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
48068 &XMSB12**2))**0.5D0
48069 IF(SBOT22.LT.0D0) GOTO 500
48070 SBOT1 = SBOT12**0.5D0
48071 SBOT2 = SBOT22**0.5D0
48072
48073 SSBOT2(1) = SBOT12
48074 SSBOT2(2) = SBOT22
48075
48076 IF(XMSB12.EQ.0D0) XSB11 = 1D0
48077 IF(XMSB12.EQ.0D0) XSB12 = 0D0
48078 IF(XMSB12.EQ.0D0) XSB21 = 0D0
48079 IF(XMSB12.EQ.0D0) XSB22 = 1D0
48080
48081 IF(XMSB12.EQ.0D0) GOTO 130
48082
48083 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48084 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48085 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48086 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48087
48088 130 B(1,1) = XSB11
48089 B(2,2) = XSB22
48090 B(1,2) = XSB12
48091 B(2,1) = XSB21
48092
48093
48094 SINT = 0.2320D0
48095 SQR = DSQRT(2D0)
48096 VP = 174.1D0*SQR
48097
48098CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48099C...STARTING OF LIGHT HIGGS
48100CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48101
48102 IF(IHIGGS.EQ.0) GOTO 490
48103
48104 DO 150 I = 1,2
48105 DO 140 J = 1,2
48106 COUPT(I,J) =
48107 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
48108 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48109 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
48110 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
48111 & T(1,J)*T(2,I))
48112 140 CONTINUE
48113 150 CONTINUE
48114
48115
48116 DO 170 I = 1,2
48117 DO 160 J = 1,2
48118 COUPB(I,J) =
48119 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
48120 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48121 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
48122 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
48123 & B(1,J)*B(2,I))
48124 160 CONTINUE
48125 170 CONTINUE
48126
48127 PRUN = XMH
48128 EPS = 1D-4*PRUN
48129 ITER = 0
48130 180 ITER = ITER + 1
48131 DO 230 I3 = 1,3
48132
48133 PR(I3)=PRUN+(I3-2)*EPS/2
48134 P2=PR(I3)**2
48135 POLT = 0D0
48136 DO 200 I = 1,2
48137 DO 190 J = 1,2
48138 POLT = POLT + COUPT(I,J)**2*3D0*
48139 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48140 190 CONTINUE
48141 200 CONTINUE
48142
48143 POLB = 0D0
48144 DO 220 I = 1,2
48145 DO 210 J = 1,2
48146 POLB = POLB + COUPB(I,J)**2*3D0*
48147 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48148 210 CONTINUE
48149 220 CONTINUE
48150C RXMT2 = RXMT**2
48151 XMT2=XMT**2
48152
48153 POLTT =
48154 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48155 & CA**2/SINB**2 *
48156 & (-2D0*XMT**2+0.5D0*P2)*
48157 & PYFINT(P2,XMT2,XMT2)
48158
48159 POL = POLT + POLB + POLTT
48160 POLAR(I3) = P2 - XMH**2 - POL
48161 230 CONTINUE
48162 DERIV = (POLAR(3)-POLAR(1))/EPS
48163 DRUN = - POLAR(2)/DERIV
48164 PRUN = PRUN + DRUN
48165 P2 = PRUN**2
48166 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
48167 GOTO 180
48168 240 CONTINUE
48169
48170 XMHP = DSQRT(P2)
48171
48172CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48173C...END OF LIGHT HIGGS
48174CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48175
48176 250 IF(IHIGGS.EQ.1) GOTO 490
48177
48178CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48179C... STARTING OF HEAVY HIGGS
48180CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48181
48182 DO 270 I = 1,2
48183 DO 260 J = 1,2
48184 HCOUPT(I,J) =
48185 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
48186 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48187 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
48188 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
48189 & T(1,J)*T(2,I))
48190 260 CONTINUE
48191 270 CONTINUE
48192
48193 DO 290 I = 1,2
48194 DO 280 J = 1,2
48195 HCOUPB(I,J) =
48196 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
48197 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48198 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
48199 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
48200 & B(1,J)*B(2,I))
48201 HCOUPB(I,J)=0D0
48202 280 CONTINUE
48203 290 CONTINUE
48204
48205 PRUN = HM
48206 EPS = 1D-4*PRUN
48207 ITER = 0
48208 300 ITER = ITER + 1
48209 DO 350 I3 = 1,3
48210 PR(I3)=PRUN+(I3-2)*EPS/2
48211 HP2=PR(I3)**2
48212
48213 HPOLT = 0D0
48214 DO 320 I = 1,2
48215 DO 310 J = 1,2
48216 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
48217 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48218 310 CONTINUE
48219 320 CONTINUE
48220
48221 HPOLB = 0D0
48222 DO 340 I = 1,2
48223 DO 330 J = 1,2
48224 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
48225 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48226 330 CONTINUE
48227 340 CONTINUE
48228
48229C RXMT2 = RXMT**2
48230 XMT2 = XMT**2
48231
48232 HPOLTT =
48233 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48234 & SA**2/SINB**2 *
48235 & (-2D0*XMT**2+0.5D0*HP2)*
48236 & PYFINT(HP2,XMT2,XMT2)
48237
48238 HPOL = HPOLT + HPOLB + HPOLTT
48239 POLAR(I3) =HP2-HM**2-HPOL
48240 350 CONTINUE
48241 DERIV = (POLAR(3)-POLAR(1))/EPS
48242 DRUN = - POLAR(2)/DERIV
48243 PRUN = PRUN + DRUN
48244 HP2 = PRUN**2
48245 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
48246 GOTO 300
48247 360 CONTINUE
48248
48249
48250 370 CONTINUE
48251 HMP = HP2**0.5D0
48252
48253CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48254C... END OF HEAVY HIGGS
48255CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48256
48257 IF(IHIGGS.EQ.2) GOTO 490
48258
48259CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48260C...BEGINNING OF PSEUDOSCALAR HIGGS
48261CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48262
48263 DO 390 I = 1,2
48264 DO 380 J = 1,2
48265 ACOUPT(I,J) =
48266 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
48267 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
48268 380 CONTINUE
48269 390 CONTINUE
48270 DO 410 I = 1,2
48271 DO 400 J = 1,2
48272 ACOUPB(I,J) =
48273 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
48274 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
48275 400 CONTINUE
48276 410 CONTINUE
48277
48278 PRUN = XMA
48279 EPS = 1D-4*PRUN
48280 ITER = 0
48281 420 ITER = ITER + 1
48282 DO 470 I3 = 1,3
48283 PR(I3)=PRUN+(I3-2)*EPS/2
48284 AP2=PR(I3)**2
48285 APOLT = 0D0
48286 DO 440 I = 1,2
48287 DO 430 J = 1,2
48288 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
48289 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48290 430 CONTINUE
48291 440 CONTINUE
48292 APOLB = 0D0
48293 DO 460 I = 1,2
48294 DO 450 J = 1,2
48295 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
48296 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48297 450 CONTINUE
48298 460 CONTINUE
48299C RXMT2 = RXMT**2
48300 XMT2=XMT**2
48301 APOLTT =
48302 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48303 & COSB**2/SINB**2 *
48304 & (-0.5D0*AP2)*
48305 & PYFINT(AP2,XMT2,XMT2)
48306 APOL = APOLT + APOLB + APOLTT
48307 POLAR(I3) = AP2 - XMA**2 -APOL
48308 470 CONTINUE
48309 DERIV = (POLAR(3)-POLAR(1))/EPS
48310 DRUN = - POLAR(2)/DERIV
48311 PRUN = PRUN + DRUN
48312 AP2 = PRUN**2
48313 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
48314 GOTO 420
48315 480 CONTINUE
48316
48317 AMP = DSQRT(AP2)
48318
48319CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48320C...END OF PSEUDOSCALAR HIGGS
48321CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48322
48323 IF(IHIGGS.EQ.3) GOTO 490
48324
48325 490 CONTINUE
48326 RETURN
48327 500 CONTINUE
48328 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
48329 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
48330 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
48331 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
48332 CALL PYSTOP(107)
48333 END
48334
48335C*********************************************************************
48336
48337C...PYRGHM
48338C...Auxiliary to PYPOLE.
48339
48340 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
48341 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
48342 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
48343 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
48344C...Parameters.
48345 INTEGER MSTU,MSTJ
48346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48347 SAVE /PYDAT1/
48348
48349 MZ = 91.18D0
48350 PI = PARU(1)
48351 V = 174.1D0
48352 ALPHA1 = 0.0101D0
48353 ALPHA2 = 0.0337D0
48354 ALPHA3Z = 0.12D0
48355 TANBA = TANB
48356 TANBT = TANB
48357C MBOTTOM(MTOP) = 3. GEV
48358 MB = PYMRUN(5,MTOP**2)
48359 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
48360 *LOG(MTOP**2/MZ**2))
48361C RMTOP= RUNNING TOP QUARK MASS
48362 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48363 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
48364 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
48365 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
48366CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48367C
48368C NEW DEFINITION, TGLU.
48369C
48370CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48371 TGLU = LOG(MGLU**2/MTOP**2)
48372 SINB = TANB/DSQRT(1D0 + TANB**2)
48373 COSB = SINB/TANB
48374 IF(MA.GT.MTOP)
48375 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
48376 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
48377 *LOG(MA**2/MTOP**2))
48378 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
48379 SINB = TANBT/SQRT(1D0 + TANBT**2)
48380 COSB = 1D0/DSQRT(1D0 + TANBT**2)
48381 G1 = SQRT(ALPHA1*4D0*PI)
48382 G2 = SQRT(ALPHA2*4D0*PI)
48383 G3 = SQRT(ALPHA3*4D0*PI)
48384 HU = RMTOP/V/SINB
48385 HD = MB/V/COSB
48386 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
48387 *SBOT1,SBOT2,DELTAMT,DELTAMB)
48388 IF(MQ.GT.MUR) TP = TQ - TU
48389 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
48390 IF(MQ.GT.MUR) TDP = TU
48391 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
48392 IF(MQ.GT.MD) TPD = TQ - TD
48393 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
48394 IF(MQ.GT.MD) TDPD = TD
48395 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
48396
48397 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
48398 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
48399 * HD**2*(G1**2/3D0+G2**2)*TPD
48400
48401 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
48402 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
48403 * HU**2*(-G1**2/3D0+G2**2)*TP
48404
48405CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48406C
48407C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
48408C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
48409C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
48410C TWO STOPS.
48411C
48412C
48413CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48414
48415 DLAMBDAP2 = 0D0
48416 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
48417 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
48418 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
48419 ENDIF
48420
48421 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
48422 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48423 ENDIF
48424
48425 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
48426 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48427 ENDIF
48428
48429 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
48430 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
48431 ENDIF
48432
48433 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
48434 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48435 ENDIF
48436
48437 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
48438 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48439 ENDIF
48440 ENDIF
48441 DLAMBDA3 = 0D0
48442 DLAMBDA4 = 0D0
48443 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
48444 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
48445 *(G2**2-G1**2/3D0)*TPD
48446 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
48447 *1D0/16D0/PI**2*G1**2*HU**2*TP
48448 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
48449 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
48450 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
48451 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
48452 *HD**2*TPD
48453 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
48454 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
48455 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
48456 *+ (3D0*HD**2/2D0 + HU**2/2D0
48457 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
48458 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
48459 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
48460 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
48461 *(TP + TDP)/8D0/PI**2)
48462 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
48463 *+ (3D0*HU**2/2D0 + HD**2/2D0
48464 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
48465 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
48466 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
48467 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48468 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
48469 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
48470 LAMBDA4 = (- G2**2/2D0)*(1D0
48471 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
48472 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
48473
48474 LAMBDA5 = 0D0
48475 LAMBDA6 = 0D0
48476 LAMBDA7 = 0D0
48477
48478 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
48479 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
48480
48481 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
48482 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
48483 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
48484 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
48485
48486 M2(2,1) = M2(1,2)
48487CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48488CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
48489CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48490
48491 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
48492
48493 IF(MCHI.GT.MSSUSY) GOTO 100
48494 IF(MCHI.LT.MTOP) MCHI=MTOP
48495
48496 TCHAR=LOG(MSSUSY**2/MCHI**2)
48497
48498 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
48499 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
48500 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
48501
48502 DELTAM112=2D0*DELTAL12*V**2*COSB**2
48503 DELTAM222=2D0*DELTAL12*V**2*SINB**2
48504 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
48505
48506 M2(1,1)=M2(1,1)+DELTAM112
48507 M2(2,2)=M2(2,2)+DELTAM222
48508 M2(1,2)=M2(1,2)+DELTAM122
48509 M2(2,1)=M2(2,1)+DELTAM122
48510
48511 100 CONTINUE
48512
48513CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48514CCC END OF CHARGINOS/NEUTRALINOS
48515CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48516
48517 DO 120 I = 1,2
48518 DO 110 J = 1,2
48519 M2P(I,J) = M2(I,J) + VH(I,J)
48520 110 CONTINUE
48521 120 CONTINUE
48522 TRM2P = M2P(1,1) + M2P(2,2)
48523 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
48524 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48525 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48526 HMP = DSQRT(HM2P)
48527 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
48528 MCH=DSQRT(MCH2)
48529 IF(MH2P.LT.0.) GOTO 130
48530 MHP = SQRT(MH2P)
48531 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
48532 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
48533 IF(COS2ALPHA.GE.0.) THEN
48534 ALPHA = ASIN(SIN2ALPHA)/2D0
48535 ELSE
48536 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
48537 ENDIF
48538 SA = SIN(ALPHA)
48539 CA = COS(ALPHA)
48540CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48541C
48542C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
48543C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
48544C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
48545C
48546C
48547CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48548 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
48549 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
48550 130 CONTINUE
48551 RETURN
48552 END
48553
48554C*********************************************************************
48555
48556C...PYGFXX
48557C...Auxiliary to PYRGHM.
48558
48559 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
48560 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
48561 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
48562 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
48563C...Commonblocks.
48564 INTEGER MSTU,MSTJ,KCHG
48565 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48566 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48567 SAVE /PYDAT1/,/PYDAT2/
48568
48569 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
48570
48571 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
48572 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
48573
48574 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
48575 MQ2 = MQ**2
48576 MUR2 = MUR**2
48577 MD2 = MD**2
48578 TANBA = TANB
48579 SINBA = TANBA/DSQRT(TANBA**2+1D0)
48580 COSBA = SINBA/TANBA
48581
48582 SINB = TANB/DSQRT(TANB**2+1D0)
48583 COSB = SINB/TANB
48584
48585 PI = PARU(1)
48586 MZ = PMAS(23,1)
48587 MW = PMAS(24,1)
48588 SW = 1D0-MW**2/MZ**2
48589 V = 174.1D0
48590
48591 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
48592 G2 = DSQRT(0.0336D0*4D0*PI)
48593 G1 = DSQRT(0.0101D0*4D0*PI)
48594
48595 IF(MQ.GT.MUR) MST = MQ
48596 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
48597
48598 MSUSYT = DSQRT(MST**2 + MTOP**2)
48599
48600 IF(MQ.GT.MD) MSB = MQ
48601 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
48602
48603 MB = PYMRUN(5,MSB**2)
48604 MSUSYB = DSQRT(MSB**2 + MB**2)
48605 TT = LOG(MSUSYT**2/MTOP**2)
48606 TB = LOG(MSUSYB**2/MTOP**2)
48607
48608 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48609 HT = RMTOP/(V*SINB)
48610 HTST = RMTOP/V
48611 HB = MB/V/COSB
48612 G32 = ALPHA3*4D0*PI
48613 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
48614 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
48615 AL2 = 3D0/8D0/PI**2*HT**2
48616C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
48617C ALST = 3./8./PI**2*HTST**2
48618 AL1 = 3D0/8D0/PI**2*HB**2
48619
48620 AL(1,1) = AL1
48621 AL(1,2) = (AL2+AL1)/2D0
48622 AL(2,1) = (AL2+AL1)/2D0
48623 AL(2,2) = AL2
48624
48625 IF(MA.GT.MTOP) THEN
48626 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
48627 * LOG(MTOP**2/MA**2))
48628 H1I = VI* COSBA
48629 H2I = VI*SINBA
48630 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
48631 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
48632 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
48633 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
48634 ELSE
48635 VI = V
48636 H1I = VI*COSB
48637 H2I = VI*SINB
48638 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48639 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48640 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48641 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48642 ENDIF
48643
48644 TANBST = H2T/H1T
48645 SINBT = TANBST/DSQRT(1D0+TANBST**2)
48646
48647 TANBSB = H2B/H1B
48648 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
48649 COSBB = SINBB/TANBSB
48650
48651 DELTAMT = 0D0
48652 DELTAMB = 0D0
48653
48654 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48655 MTOP2 = DSQRT(MTOP4)
48656 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48657 * /(1D0+DELTAMB)**4
48658 MBOT2 = DSQRT(MBOT4)
48659
48660 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48661 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48662 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48663 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48664 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48665 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48666 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48667 * MQ2 - MUR2)**2*0.25D0
48668 * + MTOP2*(AT-XMU/TANBST)**2)
48669 IF(STOP22.LT.0.) GOTO 120
48670 SBOT12 = (MQ2 + MD2)*.5D0
48671 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48672 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48673 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48674 SBOT22 = (MQ2 + MD2)*.5D0
48675 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48676 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48677 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48678 IF(SBOT22.LT.0.) SBOT22 = 10000D0
48679
48680 STOP1 = DSQRT(STOP12)
48681 STOP2 = DSQRT(STOP22)
48682 SBOT1 = DSQRT(SBOT12)
48683 SBOT2 = DSQRT(SBOT22)
48684
48685CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48686C
48687C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
48688C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
48689C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
48690C INDUCED CORRECTIONS.
48691C
48692CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48693
48694 X=SBOT1
48695 Y=SBOT2
48696 Z=XMGL
48697 IF(X.EQ.Y) X = X - 0.00001D0
48698 IF(X.EQ.Z) X = X - 0.00002D0
48699 IF(Y.EQ.Z) Y = Y - 0.00003D0
48700
48701 T1=T(X,Y,Z)
48702 X=STOP1
48703 Y=STOP2
48704 Z=XMU
48705 IF(X.EQ.Y) X = X - 0.00001D0
48706 IF(X.EQ.Z) X = X - 0.00002D0
48707 IF(Y.EQ.Z) Y = Y - 0.00003D0
48708 T2=T(X,Y,Z)
48709 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
48710 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
48711 X=STOP1
48712 Y=STOP2
48713 Z=XMGL
48714 IF(X.EQ.Y) X = X - 0.00001D0
48715 IF(X.EQ.Z) X = X - 0.00002D0
48716 IF(Y.EQ.Z) Y = Y - 0.00003D0
48717 T3=T(X,Y,Z)
48718 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
48719
48720CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48721C
48722C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
48723C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
48724C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
48725C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
48726C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
48727C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
48728C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
48729C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
48730C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
48731C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
48732C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
48733C
48734C
48735CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48736
48737 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48738 MTOP2 = DSQRT(MTOP4)
48739 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48740 * /(1D0+DELTAMB)**4
48741 MBOT2 = DSQRT(MBOT4)
48742
48743 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48744 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48745 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48746 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48747 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48748 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48749 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48750 * MQ2 - MUR2)**2*0.25D0
48751 * + MTOP2*(AT-XMU/TANBST)**2)
48752
48753 IF(STOP22.LT.0.) GOTO 120
48754 SBOT12 = (MQ2 + MD2)*.5D0
48755 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48756 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48757 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48758 SBOT22 = (MQ2 + MD2)*.5D0
48759 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48760 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48761 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48762 IF(SBOT22.LT.0.) GOTO 120
48763
48764
48765 STOP1 = DSQRT(STOP12)
48766 STOP2 = DSQRT(STOP22)
48767 SBOT1 = DSQRT(SBOT12)
48768 SBOT2 = DSQRT(SBOT22)
48769
48770CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48771CCC D-TERMS
48772CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48773 STW=SW
48774
48775 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
48776 * LOG(STOP1/STOP2)
48777 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
48778 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
48779
48780 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
48781 * LOG(SBOT1/SBOT2)
48782 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
48783 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
48784
48785 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
48786 * (-.5D0*LOG(STOP12/STOP22)
48787 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
48788 * G(STOP12,STOP22))
48789
48790 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
48791 * (.5D0*LOG(SBOT12/SBOT22)
48792 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
48793 * G(SBOT12,SBOT22))
48794
48795 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
48796 * (MQ2+MBOT2)/(MD2+MBOT2))
48797 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
48798 * LOG(SBOT1**2/SBOT2**2)) +
48799 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
48800 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
48801
48802 VH3T(1,1) =
48803 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
48804 * -STOP2**2))**2*G(STOP12,STOP22)
48805
48806 VH3B(1,1)=VH3B(1,1)+
48807 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
48808
48809 VH3T(1,1) = VH3T(1,1) +
48810 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
48811
48812 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
48813 * (MQ2+MTOP2)/(MUR2+MTOP2))
48814 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
48815 * LOG(STOP1**2/STOP2**2)) +
48816 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
48817 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
48818
48819 VH3B(2,2) =
48820 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
48821 * -SBOT2**2))**2*G(SBOT12,SBOT22)
48822
48823 VH3T(2,2)=VH3T(2,2)+
48824 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
48825 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
48826 VH3T(1,2) = -
48827 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
48828 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
48829 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
48830
48831 VH3B(1,2) =
48832 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
48833 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
48834 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
48835
48836
48837 VH3T(1,2)=VH3T(1,2) +
48838 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
48839
48840 VH3B(1,2)=VH3B(1,2) +
48841 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
48842
48843 VH3T(2,1) = VH3T(1,2)
48844 VH3B(2,1) = VH3B(1,2)
48845
48846C TQ = LOG((MQ2 + MTOP2)/MTOP2)
48847C TU = LOG((MUR2+MTOP2)/MTOP2)
48848C TQD = LOG((MQ2 + MB**2)/MB**2)
48849C TD = LOG((MD2+MB**2)/MB**2)
48850
48851 DO 110 I = 1,2
48852 DO 100 J = 1,2
48853 VH(I,J) =
48854 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
48855 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
48856 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
48857 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
48858 100 CONTINUE
48859 110 CONTINUE
48860
48861 GOTO 150
48862 120 DO 140 I =1,2
48863 DO 130 J = 1,2
48864 VH(I,J) = -1D15
48865 130 CONTINUE
48866 140 CONTINUE
48867
48868
48869 150 RETURN
48870 END
48871
48872
48873
48874
48875
48876C*********************************************************************
48877
48878C...PYFINT
48879C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
48880
48881 FUNCTION PYFINT(A,B,C)
48882
48883C...Double precision and integer declarations.
48884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48885 IMPLICIT INTEGER(I-N)
48886 INTEGER PYK,PYCHGE,PYCOMP
48887C...Commonblock.
48888 COMMON/PYINTS/XXM(20)
48889 SAVE/PYINTS/
48890
48891C...Local variables.
48892 EXTERNAL PYFISB
48893 DOUBLE PRECISION PYFISB
48894
48895 XXM(1)=A
48896 XXM(2)=B
48897 XXM(3)=C
48898 XLO=0D0
48899 XHI=1D0
48900 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
48901
48902 RETURN
48903 END
48904
48905C*********************************************************************
48906
48907C...PYFISB
48908C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
48909
48910 FUNCTION PYFISB(X)
48911
48912C...Double precision and integer declarations.
48913 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48914 IMPLICIT INTEGER(I-N)
48915 INTEGER PYK,PYCHGE,PYCOMP
48916C...Commonblock.
48917 COMMON/PYINTS/XXM(20)
48918 SAVE/PYINTS/
48919
48920 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
48921 &(X*(XXM(2)-XXM(3))+XXM(3)))
48922
48923 RETURN
48924 END
48925
48926C*********************************************************************
48927
48928C...PYSFDC
48929C...Calculates decays of sfermions.
48930
48931 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
48932
48933C...Double precision and integer declarations.
48934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48935 IMPLICIT INTEGER(I-N)
48936 INTEGER PYK,PYCHGE,PYCOMP
48937C...Parameter statement to help give large particle numbers.
48938 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48939 &KEXCIT=4000000,KDIMEN=5000000)
48940C...Commonblocks.
48941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48943 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48944 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48945 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48946 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48947
48948C...Local variables.
48949 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
48950 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
48951 INTEGER KFIN,KCIN
48952 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
48953 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48954 DOUBLE PRECISION PYLAMF,XL
48955 DOUBLE PRECISION TANW,XW,AEM,C1,AS
48956 DOUBLE PRECISION AL,AR,BL,BR
48957 DOUBLE PRECISION CH1,CH2,CH3,CH4
48958 DOUBLE PRECISION XMBOT,XMTOP
48959 DOUBLE PRECISION XLAM(0:400)
48960 INTEGER IDLAM(400,3)
48961 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
48962 DOUBLE PRECISION SR2
48963 DOUBLE PRECISION CBETA,SBETA
48964 DOUBLE PRECISION CW
48965 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
48966 DOUBLE PRECISION COSA,SINA,TANB
48967 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
48968 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
48969 INTEGER IG,KF1,KF2
48970 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
48971 DATA IGG/23,25,35,36/
48972 DATA PI/3.141592654D0/
48973 DATA SR2/1.4142136D0/
48974 DATA KFNCHI/1000022,1000023,1000025,1000035/
48975 DATA KFCCHI/1000024,1000037/
48976
48977C...COUNT THE NUMBER OF DECAY MODES
48978 LKNT=0
48979
48980C...NO NU_R DECAYS
48981 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
48982 &KFIN.EQ.KSUSY2+16) RETURN
48983
48984 XMW=PMAS(24,1)
48985 XMW2=XMW**2
48986 XMZ=PMAS(23,1)
48987 XW=PARU(102)
48988 TANW = SQRT(XW/(1D0-XW))
48989 CW=SQRT(1D0-XW)
48990
48991 DO 110 I=1,4
48992 DO 100 J=1,4
48993 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
48994 100 CONTINUE
48995 110 CONTINUE
48996 DO 130 I=1,2
48997 DO 120 J=1,2
48998 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
48999 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49000 120 CONTINUE
49001 130 CONTINUE
49002
49003C...KCIN
49004 KCIN=PYCOMP(KFIN)
49005C...ILR is 1 for left and 2 for right.
49006 ILR=KFIN/KSUSY1
49007C...IFL is matching non-SUSY flavour.
49008 IFL=MOD(KFIN,KSUSY1)
49009C...IDU is weak isospin, 1 for down and 2 for up.
49010 IDU=2-MOD(IFL,2)
49011
49012 XMI=PMAS(KCIN,1)
49013 XMI2=XMI**2
49014 AEM=PYALEM(XMI2)
49015 AS =PYALPS(XMI2)
49016 C1=AEM/XW
49017 XMI3=XMI**3
49018 EI=KCHG(IFL,1)/3D0
49019
49020 XMBOT=PYMRUN(5,XMI2)
49021 XMTOP=PYMRUN(6,XMI2)
49022
49023 TANB=RMSS(5)
49024 BETA=ATAN(TANB)
49025 ALFA=RMSS(18)
49026 CBETA=COS(BETA)
49027 SBETA=TANB*CBETA
49028 SINA=SIN(ALFA)
49029 COSA=COS(ALFA)
49030 XMU=-RMSS(4)
49031 ATRIT=RMSS(16)
49032 ATRIB=RMSS(15)
49033 ATRIL=RMSS(17)
49034
49035C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49036
49037 IF(IMSS(11).EQ.1) THEN
49038 XMP=RMSS(29)
49039 IDG=39+KSUSY1
49040 XMGR=PMAS(PYCOMP(IDG),1)
49041 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
49042 IF(IFL.EQ.5) THEN
49043 XMF=XMBOT
49044 ELSEIF(IFL.EQ.6) THEN
49045 XMF=XMTOP
49046 ELSE
49047 XMF=PMAS(IFL,1)
49048 ENDIF
49049 IF(XMI.GT.XMGR+XMF) THEN
49050 LKNT=LKNT+1
49051 IDLAM(LKNT,1)=IDG
49052 IDLAM(LKNT,2)=IFL
49053 IDLAM(LKNT,3)=0
49054 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
49055 ENDIF
49056 ENDIF
49057
49058C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49059
49060C...CHARGED DECAYS:
49061 DO 140 IX=1,2
49062C...DI -> U CHI1-,CHI2-
49063 IF(IDU.EQ.1) THEN
49064 XMFP=PMAS(IFL+1,1)
49065 XMF =PMAS(IFL,1)
49066C...UI -> D CHI1+,CHI2+
49067 ELSE
49068 XMFP=PMAS(IFL-1,1)
49069 XMF =PMAS(IFL,1)
49070 ENDIF
49071 XMJ=SMW(IX)
49072 AXMJ=ABS(XMJ)
49073 IF(XMI.GE.AXMJ+XMFP) THEN
49074 XMA2=XMJ**2
49075 XMB2=XMFP**2
49076 IF(IDU.EQ.2) THEN
49077 IF(IFL.EQ.6) THEN
49078 XMFP=XMBOT
49079 XMF =XMTOP
49080 ELSEIF(IFL.LT.6) THEN
49081 XMF=0D0
49082 XMFP=0D0
49083 ENDIF
49084 CBL=VMIXC(IX,1)
49085 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
49086 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
49087 CAR=0D0
49088 ELSE
49089 IF(IFL.EQ.5) THEN
49090 XMF =XMBOT
49091 XMFP=XMTOP
49092 ELSEIF(IFL.LT.5) THEN
49093 XMF=0D0
49094 XMFP=0D0
49095 ENDIF
49096 CBL=UMIXC(IX,1)
49097 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
49098 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
49099 CAR=0D0
49100 ENDIF
49101
49102 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49103 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49104 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49105 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49106 CAL=CALP
49107 CBL=CBLP
49108 CAR=CARP
49109 CBR=CBRP
49110
49111C...F1 -> F` CHI
49112 IF(ILR.EQ.1) THEN
49113 CA=CAL
49114 CB=CBL
49115C...F2 -> F` CHI
49116 ELSE
49117 CA=CAR
49118 CB=CBR
49119 ENDIF
49120 LKNT=LKNT+1
49121 XL=PYLAMF(XMI2,XMA2,XMB2)
49122C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49123 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49124 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
49125 IDLAM(LKNT,3)=0
49126 IF(IDU.EQ.1) THEN
49127 IDLAM(LKNT,1)=-KFCCHI(IX)
49128 IDLAM(LKNT,2)=IFL+1
49129 ELSE
49130 IDLAM(LKNT,1)=KFCCHI(IX)
49131 IDLAM(LKNT,2)=IFL-1
49132 ENDIF
49133 ENDIF
49134 140 CONTINUE
49135
49136C...NEUTRAL DECAYS
49137 DO 150 IX=1,4
49138C...DI -> D CHI10
49139 XMF=PMAS(IFL,1)
49140 XMJ=SMZ(IX)
49141 AXMJ=ABS(XMJ)
49142 IF(XMI.GE.AXMJ+XMF) THEN
49143 XMA2=XMJ**2
49144 XMB2=XMF**2
49145 IF(IDU.EQ.1) THEN
49146 IF(IFL.EQ.5) THEN
49147 XMF=XMBOT
49148 ELSEIF(IFL.LT.5) THEN
49149 XMF=0D0
49150 ENDIF
49151 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
49152 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
49153 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49154 CBR=CAL
49155 ELSE
49156 IF(IFL.EQ.6) THEN
49157 XMF=XMTOP
49158 ELSEIF(IFL.LT.5) THEN
49159 XMF=0D0
49160 ENDIF
49161 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
49162 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
49163 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49164 CBR=CAL
49165 ENDIF
49166
49167 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49168 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49169 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49170 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49171 CAL=CALP
49172 CBL=CBLP
49173 CAR=CARP
49174 CBR=CBRP
49175
49176C...F1 -> F CHI
49177 IF(ILR.EQ.1) THEN
49178 CA=CAL
49179 CB=CBL
49180C...F2 -> F CHI
49181 ELSE
49182 CA=CAR
49183 CB=CBR
49184 ENDIF
49185 LKNT=LKNT+1
49186 XL=PYLAMF(XMI2,XMA2,XMB2)
49187C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49188 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49189 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
49190 IDLAM(LKNT,1)=KFNCHI(IX)
49191 IDLAM(LKNT,2)=IFL
49192 IDLAM(LKNT,3)=0
49193 ENDIF
49194 150 CONTINUE
49195
49196C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
49197C...IG=23,25,35,36
49198 DO 160 II=1,4
49199 IG=IGG(II)
49200 IF(ILR.EQ.1) GOTO 160
49201 XMB=PMAS(IG,1)
49202 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
49203 IF(XMI.LT.XMSF1+XMB) GOTO 160
49204 IF(IG.EQ.23) THEN
49205 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
49206 BR=EI*XW/CW
49207 BLR=0D0
49208 ELSEIF(IG.EQ.25) THEN
49209 IF(IFL.EQ.5) THEN
49210 XMF=XMBOT
49211 ELSEIF(IFL.EQ.6) THEN
49212 XMF=XMTOP
49213 ELSEIF(IFL.LT.5) THEN
49214 XMF=0D0
49215 ELSE
49216 XMF=PMAS(IFL,1)
49217 ENDIF
49218 IF(IDU.EQ.2) THEN
49219 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49220 & XMF**2/XMW*COSA/SBETA
49221 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49222 & XMF**2/XMW*COSA/SBETA
49223 ELSE
49224 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49225 & XMF**2/XMW*(-SINA)/CBETA
49226 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49227 & XMF**2/XMW*(-SINA)/CBETA
49228 ENDIF
49229 IF(IFL.EQ.5) THEN
49230 AT=ATRIB
49231 ELSEIF(IFL.EQ.6) THEN
49232 AT=ATRIT
49233 ELSEIF(IFL.EQ.15) THEN
49234 AT=ATRIL
49235 ELSE
49236 AT=0D0
49237 ENDIF
49238C.........need to complexify
49239 IF(IDU.EQ.2) THEN
49240 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
49241 & AT*COSA)
49242 ELSE
49243 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
49244 & AT*SINA)
49245 ENDIF
49246 BL=GHLL
49247 BR=GHRR
49248 BLR=-GHLR
49249 ELSEIF(IG.EQ.35) THEN
49250 IF(IFL.EQ.5) THEN
49251 XMF=XMBOT
49252 ELSEIF(IFL.EQ.6) THEN
49253 XMF=XMTOP
49254 ELSEIF(IFL.LT.5) THEN
49255 XMF=0D0
49256 ELSE
49257 XMF=PMAS(IFL,1)
49258 ENDIF
49259 IF(IDU.EQ.2) THEN
49260 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49261 & XMF**2/XMW*SINA/SBETA
49262 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49263 & XMF**2/XMW*SINA/SBETA
49264 ELSE
49265 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49266 & XMF**2/XMW*COSA/CBETA
49267 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49268 & XMF**2/XMW*COSA/CBETA
49269 ENDIF
49270 IF(IFL.EQ.5) THEN
49271 AT=ATRIB
49272 ELSEIF(IFL.EQ.6) THEN
49273 AT=ATRIT
49274 ELSEIF(IFL.EQ.15) THEN
49275 AT=ATRIL
49276 ELSE
49277 AT=0D0
49278 ENDIF
49279C.........Need to complexify
49280 IF(IDU.EQ.2) THEN
49281 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
49282 & AT*SINA)
49283 ELSE
49284 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
49285 & AT*COSA)
49286 ENDIF
49287 BL=GHLL
49288 BR=GHRR
49289 BLR=GHLR
49290 ELSEIF(IG.EQ.36) THEN
49291 GHLL=0D0
49292 GHRR=0D0
49293 IF(IFL.EQ.5) THEN
49294 XMF=XMBOT
49295 ELSEIF(IFL.EQ.6) THEN
49296 XMF=XMTOP
49297 ELSEIF(IFL.LT.5) THEN
49298 XMF=0D0
49299 ELSE
49300 XMF=PMAS(IFL,1)
49301 ENDIF
49302 IF(IFL.EQ.5) THEN
49303 AT=ATRIB
49304 ELSEIF(IFL.EQ.6) THEN
49305 AT=ATRIT
49306 ELSEIF(IFL.EQ.15) THEN
49307 AT=ATRIL
49308 ELSE
49309 AT=0D0
49310 ENDIF
49311C.........Need to complexify
49312 IF(IDU.EQ.2) THEN
49313 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
49314 ELSE
49315 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
49316 ENDIF
49317 BL=GHLL
49318 BR=GHRR
49319 BLR=GHLR
49320 ENDIF
49321 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
49322 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
49323 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
49324 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49325 LKNT=LKNT+1
49326 IF(IG.EQ.23) THEN
49327 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49328 ELSE
49329 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
49330 ENDIF
49331 IDLAM(LKNT,3)=0
49332 IDLAM(LKNT,1)=KFIN-KSUSY1
49333 IDLAM(LKNT,2)=IG
49334 160 CONTINUE
49335
49336C...SF -> SF' + W
49337 XMB=PMAS(24,1)
49338 IF(MOD(IFL,2).EQ.0) THEN
49339 KF1=KSUSY1+IFL-1
49340 ELSE
49341 KF1=KSUSY1+IFL+1
49342 ENDIF
49343 KF2=KF1+KSUSY1
49344 XMSF1=PMAS(PYCOMP(KF1),1)
49345 XMSF2=PMAS(PYCOMP(KF2),1)
49346 IF(XMI.GT.XMB+XMSF1) THEN
49347 IF(MOD(IFL,2).EQ.0) THEN
49348 IF(ILR.EQ.1) THEN
49349 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
49350 ELSE
49351 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
49352 ENDIF
49353 ELSE
49354 IF(ILR.EQ.1) THEN
49355 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
49356 ELSE
49357 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
49358 ENDIF
49359 ENDIF
49360 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49361 LKNT=LKNT+1
49362 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49363 IDLAM(LKNT,3)=0
49364 IDLAM(LKNT,1)=KF1
49365 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49366 ENDIF
49367 IF(XMI.GT.XMB+XMSF2) THEN
49368 IF(MOD(IFL,2).EQ.0) THEN
49369 IF(ILR.EQ.1) THEN
49370 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
49371 ELSE
49372 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
49373 ENDIF
49374 ELSE
49375 IF(ILR.EQ.1) THEN
49376 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
49377 ELSE
49378 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
49379 ENDIF
49380 ENDIF
49381 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
49382 LKNT=LKNT+1
49383 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49384 IDLAM(LKNT,3)=0
49385 IDLAM(LKNT,1)=KF2
49386 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49387 ENDIF
49388
49389C...SF -> SF' + HC
49390 XMB=PMAS(37,1)
49391 IF(MOD(IFL,2).EQ.0) THEN
49392 KF1=KSUSY1+IFL-1
49393 ELSE
49394 KF1=KSUSY1+IFL+1
49395 ENDIF
49396 KF2=KF1+KSUSY1
49397 XMSF1=PMAS(PYCOMP(KF1),1)
49398 XMSF2=PMAS(PYCOMP(KF2),1)
49399 IF(XMI.GT.XMB+XMSF1) THEN
49400 XMF=0D0
49401 XMFP=0D0
49402 AT=0D0
49403 AB=0D0
49404 IF(MOD(IFL,2).EQ.0) THEN
49405C...T1-> B1 HC
49406 IF(ILR.EQ.1) THEN
49407 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
49408 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
49409 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
49410 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
49411C...T2-> B1 HC
49412 ELSE
49413 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
49414 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
49415 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
49416 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
49417 ENDIF
49418 IF(IFL.EQ.6) THEN
49419 XMF=XMTOP
49420 XMFP=XMBOT
49421 AT=ATRIT
49422 AB=ATRIB
49423 ENDIF
49424 ELSE
49425C...B1 -> T1 HC
49426 IF(ILR.EQ.1) THEN
49427 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
49428 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
49429 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
49430 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
49431C...B2-> T1 HC
49432 ELSE
49433 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
49434 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
49435 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
49436 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
49437 ENDIF
49438 IF(IFL.EQ.5) THEN
49439 XMF=XMTOP
49440 XMFP=XMBOT
49441 AT=ATRIT
49442 AB=ATRIB
49443 ENDIF
49444 ENDIF
49445 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49446 LKNT=LKNT+1
49447C.......Need to complexify
49448 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49449 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49450 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49451 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49452 IDLAM(LKNT,3)=0
49453 IDLAM(LKNT,1)=KF1
49454 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49455 ENDIF
49456 IF(XMI.GT.XMB+XMSF2) THEN
49457 XMF=0D0
49458 XMFP=0D0
49459 AT=0D0
49460 AB=0D0
49461 IF(MOD(IFL,2).EQ.0) THEN
49462C...T1-> B2 HC
49463 IF(ILR.EQ.1) THEN
49464 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
49465 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
49466 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
49467 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
49468C...T2-> B2 HC
49469 ELSE
49470 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
49471 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
49472 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
49473 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
49474 ENDIF
49475 IF(IFL.EQ.6) THEN
49476 XMF=XMTOP
49477 XMFP=XMBOT
49478 AT=ATRIT
49479 AB=ATRIB
49480 ENDIF
49481 ELSE
49482C...B1 -> T2 HC
49483 IF(ILR.EQ.1) THEN
49484 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
49485 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
49486 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
49487 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
49488C...B2-> T2 HC
49489 ELSE
49490 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
49491 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
49492 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
49493 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
49494 ENDIF
49495 IF(IFL.EQ.5) THEN
49496 XMF=XMTOP
49497 XMFP=XMBOT
49498 AT=ATRIT
49499 AB=ATRIB
49500 ENDIF
49501 ENDIF
49502 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49503 LKNT=LKNT+1
49504C.......Need to complexify
49505 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49506 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49507 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49508 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49509 IDLAM(LKNT,3)=0
49510 IDLAM(LKNT,1)=KF2
49511 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49512 ENDIF
49513
49514C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
49515
49516 IF(IFL.LE.6) THEN
49517 XMFP=0D0
49518 XMF=0D0
49519 IF(IFL.EQ.6) XMF=PMAS(6,1)
49520 IF(IFL.EQ.5) XMF=PMAS(5,1)
49521 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
49522 AXMJ=ABS(XMJ)
49523 IF(XMI.GE.AXMJ+XMF) THEN
49524 AL=-SFMIX(IFL,3)
49525 BL=SFMIX(IFL,1)
49526 AR=-SFMIX(IFL,4)
49527 BR=SFMIX(IFL,2)
49528C...F1 -> F CHI
49529 IF(ILR.EQ.1) THEN
49530 XCA=AL
49531 XCB=BL
49532C...F2 -> F CHI
49533 ELSE
49534 XCA=AR
49535 XCB=BR
49536 ENDIF
49537 LKNT=LKNT+1
49538 XMA2=XMJ**2
49539 XMB2=XMF**2
49540 XL=PYLAMF(XMI2,XMA2,XMB2)
49541 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49542 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
49543 IDLAM(LKNT,1)=KSUSY1+21
49544 IDLAM(LKNT,2)=IFL
49545 IDLAM(LKNT,3)=0
49546 ENDIF
49547 ENDIF
49548
49549C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
49550 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
49551 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
49552C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
49553C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
49554C...M*M = C1**2 * G**2/(16PI**2)
49555C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
49556 LKNT=LKNT+1
49557 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
49558 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
49559 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
49560 IDLAM(LKNT,1)=KSUSY1+22
49561 IDLAM(LKNT,2)=4
49562 IDLAM(LKNT,3)=0
49563 ENDIF
49564
49565C...R-violating sfermion decays (SKANDS).
49566 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
49567
49568 IKNT=LKNT
49569 XLAM(0)=0D0
49570 DO 170 I=1,IKNT
49571 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49572 XLAM(0)=XLAM(0)+XLAM(I)
49573 170 CONTINUE
49574 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
49575
49576 RETURN
49577 END
49578
49579C*********************************************************************
49580
49581C...PYGLUI
49582C...Calculates gluino decay modes.
49583
49584 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
49585
49586C...Double precision and integer declarations.
49587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49588 IMPLICIT INTEGER(I-N)
49589 INTEGER PYK,PYCHGE,PYCOMP
49590C...Parameter statement to help give large particle numbers.
49591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49592 &KEXCIT=4000000,KDIMEN=5000000)
49593C...Commonblocks.
49594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49596 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49597 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49598 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49599CC &SFMIX(16,4),
49600C COMMON/PYINTS/XXM(20)
49601 COMPLEX*16 CXC
49602 COMMON/PYINTC/XXC(10),CXC(8)
49603 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49604
49605C...Local variables
49606 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49607 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
49608 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49609 DOUBLE PRECISION PYLAMF,XL
49610 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
49611 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
49612 DOUBLE PRECISION XLAM(0:400)
49613 INTEGER IDLAM(400,3)
49614 INTEGER LKNT,IX,ILR,I,IKNT,IFL
49615 DOUBLE PRECISION SR2
49616 DOUBLE PRECISION GAM
49617 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
49618 EXTERNAL PYGAUS,PYXXZ6
49619 DOUBLE PRECISION PYGAUS,PYXXZ6
49620 DOUBLE PRECISION PREC
49621 INTEGER KFNCHI(4),KFCCHI(2)
49622 DATA PI/3.141592654D0/
49623 DATA SR2/1.4142136D0/
49624 DATA PREC/1D-2/
49625 DATA KFNCHI/1000022,1000023,1000025,1000035/
49626 DATA KFCCHI/1000024,1000037/
49627
49628C...COUNT THE NUMBER OF DECAY MODES
49629 LKNT=0
49630 IF(KFIN.NE.KSUSY1+21) RETURN
49631 KCIN=PYCOMP(KFIN)
49632
49633 XW=PARU(102)
49634 TANW = SQRT(XW/(1D0-XW))
49635
49636 XMI=PMAS(KCIN,1)
49637 AXMI=ABS(XMI)
49638 XMI2=XMI**2
49639 AEM=PYALEM(XMI2)
49640 AS =PYALPS(XMI2)
49641 C1=AEM/XW
49642 XMI3=AXMI**3
49643
49644 XMI=SIGN(XMI,RMSS(3))
49645
49646C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
49647
49648 IF(IMSS(11).EQ.1) THEN
49649 XMP=RMSS(29)
49650 IDG=39+KSUSY1
49651 XMGR=PMAS(PYCOMP(IDG),1)
49652 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49653 IF(AXMI.GT.XMGR) THEN
49654 LKNT=LKNT+1
49655 IDLAM(LKNT,1)=IDG
49656 IDLAM(LKNT,2)=21
49657 IDLAM(LKNT,3)=0
49658 XLAM(LKNT)=XFAC
49659 ENDIF
49660 ENDIF
49661
49662C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
49663
49664 DO 110 IFL=1,6
49665 DO 100 ILR=1,2
49666 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
49667 AXMJ=ABS(XMJ)
49668 XMF=PMAS(IFL,1)
49669 IF(AXMI.GE.AXMJ+XMF) THEN
49670C...Minus sign difference from gluino-quark-squark feynman rules
49671 AL=SFMIX(IFL,1)
49672 BL=-SFMIX(IFL,3)
49673 AR=SFMIX(IFL,2)
49674 BR=-SFMIX(IFL,4)
49675C...F1 -> F CHI
49676 IF(ILR.EQ.1) THEN
49677 CA=AL
49678 CB=BL
49679C...F2 -> F CHI
49680 ELSE
49681 CA=AR
49682 CB=BR
49683 ENDIF
49684 LKNT=LKNT+1
49685 XMA2=XMJ**2
49686 XMB2=XMF**2
49687 XL=PYLAMF(XMI2,XMA2,XMB2)
49688 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
49689 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
49690 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
49691 IDLAM(LKNT,2)=-IFL
49692 IDLAM(LKNT,3)=0
49693 LKNT=LKNT+1
49694 XLAM(LKNT)=XLAM(LKNT-1)
49695 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49696 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49697 IDLAM(LKNT,3)=0
49698 ENDIF
49699 100 CONTINUE
49700 110 CONTINUE
49701
49702C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
49703C...GLUINO -> NI Q QBAR
49704 DO 170 IX=1,4
49705 XMJ=SMZ(IX)
49706 AXMJ=ABS(XMJ)
49707 IF(AXMI.GE.AXMJ) THEN
49708 DO 120 I=1,4
49709 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
49710 120 CONTINUE
49711 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
49712 ORPP=DCONJG(OLPP)
49713 XXC(1)=0D0
49714 XXC(2)=XMJ
49715 XXC(3)=0D0
49716 XXC(4)=XMI
49717 IA=1
49718 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49719 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49720 XXC(7)=XXC(5)
49721 XXC(8)=XXC(6)
49722 XXC(9)=1D6
49723 XXC(10)=0D0
49724 EI=KCHG(IA,1)/3D0
49725 T3I=SIGN(1D0,EI+1D-6)/2D0
49726 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49727 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49728 CXC(1)=0D0
49729 CXC(2)=-GLIJ
49730 CXC(3)=0D0
49731 CXC(4)=DCONJG(GLIJ)
49732 CXC(5)=0D0
49733 CXC(6)=GRIJ
49734 CXC(7)=0D0
49735 CXC(8)=-DCONJG(GRIJ)
49736 S12MIN=0D0
49737 S12MAX=(AXMI-AXMJ)**2
49738 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
49739 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49740 LKNT=LKNT+1
49741 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49742 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49743 IDLAM(LKNT,1)=KFNCHI(IX)
49744 IDLAM(LKNT,2)=1
49745 IDLAM(LKNT,3)=-1
49746 ENDIF
49747 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49748 LKNT=LKNT+1
49749 XLAM(LKNT)=XLAM(LKNT-1)
49750 IDLAM(LKNT,1)=KFNCHI(IX)
49751 IDLAM(LKNT,2)=3
49752 IDLAM(LKNT,3)=-3
49753 ENDIF
49754 130 CONTINUE
49755 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49756 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
49757 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
49758 GOTO 140
49759 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
49760 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
49761 ENDIF
49762 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
49763 LKNT=LKNT+1
49764 XLAM(LKNT)=GAM
49765 IDLAM(LKNT,1)=KFNCHI(IX)
49766 IDLAM(LKNT,2)=5
49767 IDLAM(LKNT,3)=-5
49768 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
49769 ENDIF
49770C...U-TYPE QUARKS
49771 140 CONTINUE
49772 IA=2
49773 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49774 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49775C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
49776 XXC(7)=XXC(5)
49777 XXC(8)=XXC(6)
49778 EI=KCHG(IA,1)/3D0
49779 T3I=SIGN(1D0,EI+1D-6)/2D0
49780 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49781 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49782 CXC(2)=-GLIJ
49783 CXC(4)=DCONJG(GLIJ)
49784 CXC(6)=GRIJ
49785 CXC(8)=-DCONJG(GRIJ)
49786 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
49787 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49788 LKNT=LKNT+1
49789 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49790 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49791 IDLAM(LKNT,1)=KFNCHI(IX)
49792 IDLAM(LKNT,2)=2
49793 IDLAM(LKNT,3)=-2
49794 ENDIF
49795 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49796 LKNT=LKNT+1
49797 XLAM(LKNT)=XLAM(LKNT-1)
49798 IDLAM(LKNT,1)=KFNCHI(IX)
49799 IDLAM(LKNT,2)=4
49800 IDLAM(LKNT,3)=-4
49801 ENDIF
49802 150 CONTINUE
49803C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
49804C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
49805 XMF=PMAS(6,1)
49806 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
49807 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
49808 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
49809 GOTO 160
49810 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
49811 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
49812 ENDIF
49813 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
49814 LKNT=LKNT+1
49815 XLAM(LKNT)=GAM
49816 IDLAM(LKNT,1)=KFNCHI(IX)
49817 IDLAM(LKNT,2)=6
49818 IDLAM(LKNT,3)=-6
49819 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
49820 ENDIF
49821 160 CONTINUE
49822 ENDIF
49823 170 CONTINUE
49824
49825C...GLUINO -> CI Q QBAR'
49826 DO 210 IX=1,2
49827 XMJ=SMW(IX)
49828 AXMJ=ABS(XMJ)
49829 IF(AXMI.GE.AXMJ) THEN
49830 DO 180 I=1,2
49831 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
49832 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
49833 180 CONTINUE
49834 S12MIN=0D0
49835 S12MAX=(AXMI-AXMJ)**2
49836 XXC(1)=0D0
49837 XXC(2)=XMJ
49838 XXC(3)=0D0
49839 XXC(4)=XMI
49840 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
49841 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
49842 XXC(9)=1D6
49843 XXC(10)=0D0
49844 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
49845 ORPP=DCONJG(OLPP)
49846 CXC(1)=DCMPLX(0D0,0D0)
49847 CXC(3)=DCMPLX(0D0,0D0)
49848 CXC(5)=DCMPLX(0D0,0D0)
49849 CXC(7)=DCMPLX(0D0,0D0)
49850 CXC(2)=UMIXC(IX,1)*OLPP/SR2
49851 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
49852 CXC(6)=DCMPLX(0D0,0D0)
49853 CXC(8)=DCMPLX(0D0,0D0)
49854 IF(XXC(5).LT.AXMI) THEN
49855 XXC(5)=1D6
49856 ELSEIF(XXC(6).LT.AXMI) THEN
49857 XXC(6)=1D6
49858 ENDIF
49859 XXC(7)=XXC(6)
49860 XXC(8)=XXC(5)
49861 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
49862 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
49863 LKNT=LKNT+1
49864 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
49865 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49866 IDLAM(LKNT,1)=KFCCHI(IX)
49867 IDLAM(LKNT,2)=1
49868 IDLAM(LKNT,3)=-2
49869 LKNT=LKNT+1
49870 XLAM(LKNT)=XLAM(LKNT-1)
49871 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49872 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49873 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49874 ENDIF
49875 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49876 LKNT=LKNT+1
49877 XLAM(LKNT)=XLAM(LKNT-1)
49878 IDLAM(LKNT,1)=KFCCHI(IX)
49879 IDLAM(LKNT,2)=3
49880 IDLAM(LKNT,3)=-4
49881 LKNT=LKNT+1
49882 XLAM(LKNT)=XLAM(LKNT-1)
49883 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49884 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49885 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49886 ENDIF
49887 190 CONTINUE
49888
49889 XMF=PMAS(6,1)
49890 XMFP=PMAS(5,1)
49891 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
49892 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
49893 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
49894 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
49895 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
49896 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
49897 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
49898 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
49899 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
49900 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
49901 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
49902 CALL PYTBBC(IX,100,XMI,GAM)
49903 LKNT=LKNT+1
49904 XLAM(LKNT)=GAM
49905 IDLAM(LKNT,1)=KFCCHI(IX)
49906 IDLAM(LKNT,2)=5
49907 IDLAM(LKNT,3)=-6
49908 LKNT=LKNT+1
49909 XLAM(LKNT)=XLAM(LKNT-1)
49910 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49911 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49912 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49913 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
49914 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
49915 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
49916 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
49917 ENDIF
49918 200 CONTINUE
49919 ENDIF
49920 210 CONTINUE
49921
49922C...R-parity violating (3-body) decays.
49923 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
49924
49925 IKNT=LKNT
49926 XLAM(0)=0D0
49927 DO 220 I=1,IKNT
49928 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49929 XLAM(0)=XLAM(0)+XLAM(I)
49930 220 CONTINUE
49931 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
49932
49933 RETURN
49934 END
49935
49936
49937C*********************************************************************
49938
49939C...PYTBBN
49940C...Calculates the three-body decay of gluinos into
49941C...neutralinos and third generation fermions.
49942
49943 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
49944
49945C...Double precision and integer declarations.
49946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49947 IMPLICIT INTEGER(I-N)
49948 INTEGER PYK,PYCHGE,PYCOMP
49949C...Parameter statement to help give large particle numbers.
49950 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49951 &KEXCIT=4000000,KDIMEN=5000000)
49952C...Commonblocks.
49953 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49954 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49955 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49956 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49957 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49958 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49959
49960C...Local variables.
49961 EXTERNAL PYSIMP,PYLAMF
49962 DOUBLE PRECISION PYSIMP,PYLAMF
49963 INTEGER LIN,NN
49964 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
49965 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
49966 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
49967 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
49968 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
49969 DOUBLE PRECISION XLN1,XLN2,B1,B2
49970 DOUBLE PRECISION E,XMGLU,GAM
49971 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
49972 SAVE HRB,HLB,FLB,FRB
49973 DOUBLE PRECISION ALPHAW,ALPHAS
49974 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
49975 SAVE HLT,HRT,FLT,FRT
49976 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
49977 SAVE AMN,AN,ZN
49978 DOUBLE PRECISION AMBOT,SINC,COSC
49979 DOUBLE PRECISION AMTOP,SINA,COSA
49980 DOUBLE PRECISION SINW,COSW,TANW
49981 DOUBLE PRECISION ROT1(4,4)
49982 LOGICAL IFIRST
49983 SAVE IFIRST
49984 DATA IFIRST/.TRUE./
49985
49986 TANB=RMSS(5)
49987 SINB=TANB/SQRT(1D0+TANB**2)
49988 COSB=SINB/TANB
49989 XW=PARU(102)
49990 SINW=SQRT(XW)
49991 COSW=SQRT(1D0-XW)
49992 TANW=SINW/COSW
49993 AMW=PMAS(24,1)
49994 COSC=SFMIX(5,1)
49995 SINC=SFMIX(5,3)
49996 COSA=SFMIX(6,1)
49997 SINA=SFMIX(6,3)
49998 AMBOT=PYMRUN(5,XMGLU**2)
49999 AMTOP=PYMRUN(6,XMGLU**2)
50000 W2=SQRT(2D0)
50001 FAKT1=AMBOT/W2/AMW/COSB
50002 FAKT2=AMTOP/W2/AMW/SINB
50003 IF(IFIRST) THEN
50004 DO 110 II=1,4
50005 AMN(II)=SMZ(II)
50006 DO 100 J=1,4
50007 ROT1(II,J)=0D0
50008 AN(II,J)=0D0
50009 100 CONTINUE
50010 110 CONTINUE
50011 ROT1(1,1)=COSW
50012 ROT1(1,2)=-SINW
50013 ROT1(2,1)=-ROT1(1,2)
50014 ROT1(2,2)=ROT1(1,1)
50015 ROT1(3,3)=COSB
50016 ROT1(3,4)=SINB
50017 ROT1(4,3)=-ROT1(3,4)
50018 ROT1(4,4)=ROT1(3,3)
50019 DO 140 II=1,4
50020 DO 130 J=1,4
50021 DO 120 JJ=1,4
50022 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
50023 120 CONTINUE
50024 130 CONTINUE
50025 140 CONTINUE
50026 DO 150 J=1,4
50027 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
50028 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50029 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
50030 & XW)*AN(J,2)/COSW
50031 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
50032 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
50033 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
50034 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
50035C FLU(J)=ZN(3)
50036C FRU(J)=ZN(2)
50037 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
50038 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50039 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
50040 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
50041 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
50042 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
50043 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
50044C FLD(J)=ZN(3)
50045C FRD(J)=ZN(2)
50046 150 CONTINUE
50047C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50048C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50049C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50050C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50051 IFIRST=.FALSE.
50052 ENDIF
50053
50054 IF(NINT(3D0*E).EQ.2) THEN
50055 HL=HLT(I)
50056 HR=HRT(I)
50057 FL=FLT(I)
50058 FR=FRT(I)
50059 COSD=SFMIX(6,1)
50060 SIND=SFMIX(6,3)
50061 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
50062 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
50063 XM=PMAS(6,1)
50064 ELSE
50065 HL=HLB(I)
50066 HR=HRB(I)
50067 FL=FLB(I)
50068 FR=FRB(I)
50069 COSD=SFMIX(5,1)
50070 SIND=SFMIX(5,3)
50071 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
50072 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
50073 XM=PMAS(5,1)
50074 ENDIF
50075 COSD2=COSD*COSD
50076 SIND2=SIND*SIND
50077 COS2D=COSD2-SIND2
50078 SIN2D=SIND*COSD*2D0
50079 HL2=HL*HL
50080 HR2=HR*HR
50081 FL2=FL*FL
50082 FR2=FR*FR
50083 FF=FL*FR
50084 HH=HL*HR
50085 HFL=HL*FL
50086 HFR=HR*FR
50087 HRFL=HR*FL
50088 HLFR=HL*FR
50089 XM2=XM*XM
50090 XMG=XMGLU
50091 XMG2=XMG*XMG
50092 ALPHAW=PYALEM(XMG2)
50093 ALPHAS=PYALPS(XMG2)
50094 XMR=AMN(I)
50095 XMR2=XMR*XMR
50096 XMQ4=XMG*XM2*XMR
50097 XM24=(XMG2+XM2)*(XM2+XMR2)
50098 SMIN=4D0*XM2
50099 SMAX=(XMG-ABS(XMR))**2
50100 XMQA=XMG2+2D0*XM2+XMR2
50101 DO 170 LIN=1,NN-1
50102 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50103 GRS=SBAR-XMQA
50104 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
50105 W=DSQRT(W)
50106 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
50107 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
50108 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
50109 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
50110 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
50111 & +2D0*(FF*SIND2-HH*COSD2))*W
50112 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
50113 & +4D0*HFL*XM*XMR)*XLN1
50114 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
50115 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
50116 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
50117 & +8D0*HFL*XMQ4*SIN2D)*B1
50118 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
50119 & +4D0*HFR*XMR*XM)*XLN2
50120 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
50121 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
50122 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
50123 & -8D0*HFR*XMQ4*SIN2D)*B2
50124 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
50125 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
50126 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
50127 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
50128 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
50129 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
50130 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
50131 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
50132 G(5)=(2D0*(HH*COSD2-FF*SIND2)
50133 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
50134 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
50135 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
50136 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
50137 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
50138 & +COS2D*XM*(SBAR+XMG2-XMR2))
50139 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
50140 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
50141 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
50142 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
50143 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
50144 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
50145 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
50146 SUMME(LIN)=0D0
50147 DO 160 J=0,6
50148 SUMME(LIN)=SUMME(LIN)+G(J)
50149 160 CONTINUE
50150 170 CONTINUE
50151 SUMME(0)=0D0
50152 SUMME(NN)=0D0
50153 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50154 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50155
50156 RETURN
50157 END
50158
50159C*********************************************************************
50160
50161C...PYTBBC
50162C...Calculates the three-body decay of gluinos into
50163C...charginos and third generation fermions.
50164
50165 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
50166
50167C...Double precision and integer declarations.
50168 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50169 IMPLICIT INTEGER(I-N)
50170 INTEGER PYK,PYCHGE,PYCOMP
50171C...Parameter statement to help give large particle numbers.
50172 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50173 &KEXCIT=4000000,KDIMEN=5000000)
50174C...Commonblocks.
50175 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50176 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50177 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50178 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50179 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50180 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50181
50182C...Local variables.
50183 EXTERNAL PYSIMP,PYLAMF
50184 DOUBLE PRECISION PYSIMP,PYLAMF
50185 INTEGER I,NN,LIN
50186 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
50187 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
50188 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
50189 DOUBLE PRECISION SUMME(0:100),A(4,8)
50190 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
50191 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
50192 DOUBLE PRECISION XMGLU,GAM
50193 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
50194 &DDD(2),EEE(2),FFF(2)
50195 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
50196 DOUBLE PRECISION ALPHAW,ALPHAS
50197 DOUBLE PRECISION AMC(2)
50198 SAVE AMC
50199 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
50200 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
50201 SAVE AMSB,AMST
50202 LOGICAL IFIRST
50203 SAVE IFIRST
50204 DATA IFIRST/.TRUE./
50205
50206 TANB=RMSS(5)
50207 SINB=TANB/SQRT(1D0+TANB**2)
50208 COSB=SINB/TANB
50209 XW=PARU(102)
50210 AMW=PMAS(24,1)
50211 COSC=SFMIX(5,1)
50212 SINC=SFMIX(5,3)
50213 COSA=SFMIX(6,1)
50214 SINA=SFMIX(6,3)
50215 AMBOT=PYMRUN(5,XMGLU**2)
50216 AMTOP=PYMRUN(6,XMGLU**2)
50217 W2=SQRT(2D0)
50218 AMW=PMAS(24,1)
50219 FAKT1=AMBOT/W2/AMW/COSB
50220 FAKT2=AMTOP/W2/AMW/SINB
50221 IF(IFIRST) THEN
50222 AMC(1)=SMW(1)
50223 AMC(2)=SMW(2)
50224 DO 100 JJ=1,2
50225 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
50226 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
50227 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
50228 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
50229 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
50230 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
50231 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
50232 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
50233 100 CONTINUE
50234 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50235 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50236 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50237 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50238 IFIRST=.FALSE.
50239 ENDIF
50240
50241 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
50242 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
50243 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
50244 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
50245
50246 COS2A=COSA**2-SINA**2
50247 SIN2A=SINA*COSA*2D0
50248 COS2C=COSC**2-SINC**2
50249 SIN2C=SINC*COSC*2D0
50250
50251 XMG=XMGLU
50252 XMT=PMAS(6,1)
50253 XMB=PMAS(5,1)
50254 XMR=AMC(I)
50255 XMG2=XMG*XMG
50256 ALPHAW=PYALEM(XMG2)
50257 ALPHAS=PYALPS(XMG2)
50258 XMT2=XMT*XMT
50259 XMB2=XMB*XMB
50260 XMR2=XMR*XMR
50261 XMQ2=XMG2+XMT2+XMB2+XMR2
50262 XMQ4=XMG*XMT*XMB*XMR
50263 XMQ3=XMG2*XMR2+XMT2*XMB2
50264 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
50265 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
50266
50267 XMST(1)=AMST(1)*AMST(1)
50268 XMST(2)=AMST(1)*AMST(1)
50269 XMST(3)=AMST(2)*AMST(2)
50270 XMST(4)=AMST(2)*AMST(2)
50271 XMSB(1)=AMSB(1)*AMSB(1)
50272 XMSB(2)=AMSB(2)*AMSB(2)
50273 XMSB(3)=AMSB(1)*AMSB(1)
50274 XMSB(4)=AMSB(2)*AMSB(2)
50275
50276 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
50277 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
50278 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
50279 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
50280 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
50281 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
50282 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
50283 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
50284
50285 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
50286 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
50287 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
50288 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
50289 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
50290 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
50291 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
50292 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
50293
50294 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
50295 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
50296 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
50297 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
50298 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
50299 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
50300 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
50301 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
50302
50303 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
50304 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
50305 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
50306 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
50307 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
50308 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
50309 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
50310 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
50311
50312 SMAX=(XMG-ABS(XMR))**2
50313 SMIN=(XMB+XMT)**2+0.1D0
50314
50315 DO 120 LIN=0,NN-1
50316 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50317 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
50318 GRS=SBAR-XMQ2
50319 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
50320 W=DSQRT(W)/2D0/SBAR
50321 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
50322 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
50323 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
50324 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
50325 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
50326 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
50327 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
50328 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
50329 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
50330 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
50331 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
50332 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
50333 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
50334 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
50335 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
50336 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
50337 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
50338 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
50339 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
50340 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
50341 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
50342 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
50343 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
50344 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
50345 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
50346 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
50347 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
50348 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
50349 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
50350 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
50351 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
50352 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
50353 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
50354 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
50355 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
50356 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
50357 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
50358 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
50359 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
50360 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
50361 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
50362 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
50363 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
50364 DO 110 J=1,4
50365 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
50366 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
50367 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
50368 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
50369 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
50370 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
50371 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
50372 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
50373 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
50374 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
50375 & -A(J,6)*(XMG2+XMR2-SBAR)
50376 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
50377 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
50378 & /(GRS+XMSB(J)+XMST(J))
50379 110 CONTINUE
50380 120 CONTINUE
50381 SUMME(NN)=0D0
50382 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50383 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50384
50385 RETURN
50386 END
50387
50388C*********************************************************************
50389
50390C...PYNJDC
50391C...Calculates decay widths for the neutralinos (admixtures of
50392C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
50393
50394C...Input: KCIN = KF code for particle
50395C...Output: XLAM = widths
50396C... IDLAM = KF codes for decay particles
50397C... IKNT = number of decay channels defined
50398C...AUTHOR: STEPHEN MRENNA
50399C...Last change:
50400C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
50401C...when CHIGAMMA .NE. 0
50402C...10 FEB 96: Calculate this decay for small tan(beta)
50403
50404 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
50405
50406C...Double precision and integer declarations.
50407 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50408 IMPLICIT INTEGER(I-N)
50409 INTEGER PYK,PYCHGE,PYCOMP
50410C...Parameter statement to help give large particle numbers.
50411 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50412 &KEXCIT=4000000,KDIMEN=5000000)
50413C...Commonblocks.
50414 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50415 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50416 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50417c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50418c &SFMIX(16,4)
50419 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50420 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50421C COMMON/PYINTS/XXM(20)
50422 COMPLEX*16 CXC
50423 COMMON/PYINTC/XXC(10),CXC(8)
50424 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50425
50426C...Local variables.
50427 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50428 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
50429 INTEGER KFIN
50430 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50431 &XMZ,XMZ2,AXMJ,AXMI
50432 DOUBLE PRECISION S12MIN,S12MAX
50433 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
50434 DOUBLE PRECISION PYLAMF,XL
50435 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
50436 DOUBLE PRECISION PYX2XH,PYX2XG
50437 DOUBLE PRECISION XLAM(0:400)
50438 INTEGER IDLAM(400,3)
50439 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
50440 INTEGER ITH(3),KF1,KF2
50441 INTEGER ITHC
50442 DOUBLE PRECISION DH(3),EH(3)
50443 DOUBLE PRECISION SR2
50444 DOUBLE PRECISION CBETA,SBETA
50445 DOUBLE PRECISION GAMCON,XMT1,XMT2
50446 DOUBLE PRECISION PYALEM,PI,PYALPS
50447 DOUBLE PRECISION RAT1,RAT2
50448 DOUBLE PRECISION T3T,FCOL
50449 DOUBLE PRECISION ALFA,BETA,TANB
50450 DOUBLE PRECISION PYXXGA
50451 EXTERNAL PYGAUS,PYXXZ6
50452 DOUBLE PRECISION PYGAUS,PYXXZ6
50453 DOUBLE PRECISION PREC
50454 INTEGER KFNCHI(4),KFCCHI(2)
50455 DATA ITH/25,35,36/
50456 DATA ITHC/37/
50457 DATA PREC/1D-2/
50458 DATA PI/3.141592654D0/
50459 DATA SR2/1.4142136D0/
50460 DATA KFNCHI/1000022,1000023,1000025,1000035/
50461 DATA KFCCHI/1000024,1000037/
50462
50463C...COUNT THE NUMBER OF DECAY MODES
50464 LKNT=0
50465
50466 XMW=PMAS(24,1)
50467 XMW2=XMW**2
50468 XMZ=PMAS(23,1)
50469 XMZ2=XMZ**2
50470 XW=1D0-XMW2/XMZ2
50471 XW1=1D0-XW
50472 TANW = SQRT(XW/XW1)
50473
50474C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
50475 IX=1
50476 IF(KFIN.EQ.KFNCHI(2)) IX=2
50477 IF(KFIN.EQ.KFNCHI(3)) IX=3
50478 IF(KFIN.EQ.KFNCHI(4)) IX=4
50479
50480 XMI=SMZ(IX)
50481 XMI2=XMI**2
50482 AXMI=ABS(XMI)
50483 AEM=PYALEM(XMI2)
50484 AS =PYALPS(XMI2)
50485 C1=AEM/XW
50486 XMI3=ABS(XMI**3)
50487
50488 TANB=RMSS(5)
50489 BETA=ATAN(TANB)
50490 ALFA=RMSS(18)
50491 CBETA=COS(BETA)
50492 SBETA=TANB*CBETA
50493 CALFA=COS(ALFA)
50494 SALFA=SIN(ALFA)
50495
50496 DO 110 I=1,4
50497 DO 100 J=1,4
50498 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50499 100 CONTINUE
50500 110 CONTINUE
50501 DO 130 I=1,2
50502 DO 120 J=1,2
50503 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50504 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50505 120 CONTINUE
50506 130 CONTINUE
50507
50508C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50509 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
50510
50511C...FORCE CHI0_2 -> CHI0_1 + GAMMA
50512 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
50513 XMJ=SMZ(1)
50514 AXMJ=ABS(XMJ)
50515 LKNT=LKNT+1
50516 GAMCON=AEM**3/8D0/PI/XMW2/XW
50517 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50518 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50519 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50520 IDLAM(LKNT,1)=KSUSY1+22
50521 IDLAM(LKNT,2)=22
50522 IDLAM(LKNT,3)=0
50523 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
50524 GOTO 340
50525 ENDIF
50526
50527C...GRAVITINO DECAY MODES
50528
50529 IF(IMSS(11).EQ.1) THEN
50530 XMP=RMSS(29)
50531 IDG=39+KSUSY1
50532 XMGR=PMAS(PYCOMP(IDG),1)
50533 SINW=SQRT(XW)
50534 COSW=SQRT(1D0-XW)
50535 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50536 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
50537 LKNT=LKNT+1
50538 IDLAM(LKNT,1)=IDG
50539 IDLAM(LKNT,2)=22
50540 IDLAM(LKNT,3)=0
50541 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
50542 ENDIF
50543 IF(AXMI.GT.XMGR+XMZ) THEN
50544 LKNT=LKNT+1
50545 IDLAM(LKNT,1)=IDG
50546 IDLAM(LKNT,2)=23
50547 IDLAM(LKNT,3)=0
50548 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
50549 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
50550 & (1D0-XMZ2/XMI2)**4
50551 ENDIF
50552 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
50553 LKNT=LKNT+1
50554 IDLAM(LKNT,1)=IDG
50555 IDLAM(LKNT,2)=25
50556 IDLAM(LKNT,3)=0
50557 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
50558 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
50559 ENDIF
50560 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
50561 LKNT=LKNT+1
50562 IDLAM(LKNT,1)=IDG
50563 IDLAM(LKNT,2)=35
50564 IDLAM(LKNT,3)=0
50565 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
50566 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
50567 ENDIF
50568 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
50569 LKNT=LKNT+1
50570 IDLAM(LKNT,1)=IDG
50571 IDLAM(LKNT,2)=36
50572 IDLAM(LKNT,3)=0
50573 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
50574 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
50575 ENDIF
50576 IF(IX.EQ.1) GOTO 300
50577 ENDIF
50578
50579 DO 220 IJ=1,IX-1
50580 XMJ=SMZ(IJ)
50581 AXMJ=ABS(XMJ)
50582 XMJ2=XMJ**2
50583
50584C...CHI0_I -> CHI0_J + GAMMA
50585 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
50586 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
50587 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
50588 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
50589 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
50590 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
50591 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
50592 LKNT=LKNT+1
50593 IDLAM(LKNT,1)=KFNCHI(IJ)
50594 IDLAM(LKNT,2)=22
50595 IDLAM(LKNT,3)=0
50596 GAMCON=AEM**3/8D0/PI/XMW2/XW
50597 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50598 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50599 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50600 ENDIF
50601 ENDIF
50602
50603C...CHI0_I -> CHI0_J + Z0
50604 IF(AXMI.GE.AXMJ+XMZ) THEN
50605 LKNT=LKNT+1
50606 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50607 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50608 ORPP=-DCONJG(OLPP)
50609 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50610 GLR=DBLE(OLPP*DCONJG(ORPP))
50611 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50612 IDLAM(LKNT,1)=KFNCHI(IJ)
50613 IDLAM(LKNT,2)=23
50614 IDLAM(LKNT,3)=0
50615 ELSEIF(AXMI.GE.AXMJ) THEN
50616 XXC(1)=0D0
50617 XXC(2)=XMJ
50618 XXC(3)=0D0
50619 XXC(4)=XMI
50620 XXC(9)=XMZ
50621 XXC(10)=PMAS(23,2)
50622 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50623 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50624 ORPP=DCONJG(OLPP)
50625C...CHARGED LEPTONS
50626 FID=11
50627 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50628 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50629 EI=KCHG(FID,1)/3D0
50630 T3I=SIGN(1D0,EI+1D-6)/2D0
50631 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50632 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50633 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50634 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50635 CXC(2)=-GLIJ
50636 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50637 CXC(4)=DCONJG(GLIJ)
50638 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50639 CXC(6)=GRIJ
50640 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50641 CXC(8)=-DCONJG(GRIJ)
50642 S12MIN=0D0
50643 S12MAX=(AXMI-AXMJ)**2
50644 IF( XXC(5).LT.AXMI ) THEN
50645 XXC(5)=1D6
50646 ENDIF
50647 IF(XXC(6).LT.AXMI ) THEN
50648 XXC(6)=1D6
50649 ENDIF
50650 XXC(7)=XXC(5)
50651 XXC(8)=XXC(6)
50652
50653 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50654 LKNT=LKNT+1
50655 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50656 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50657 IDLAM(LKNT,1)=KFNCHI(IJ)
50658 IDLAM(LKNT,2)=FID
50659 IDLAM(LKNT,3)=-FID
50660 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50661 LKNT=LKNT+1
50662 XLAM(LKNT)=XLAM(LKNT-1)
50663 IDLAM(LKNT,1)=KFNCHI(IJ)
50664 IDLAM(LKNT,2)=13
50665 IDLAM(LKNT,3)=-13
50666 ENDIF
50667 ENDIF
50668 140 CONTINUE
50669 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50670 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50671 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50672 ELSE
50673 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50674 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50675 ENDIF
50676 IF( XXC(5).LT.AXMI ) THEN
50677 XXC(5)=1D6
50678 ENDIF
50679 IF(XXC(6).LT.AXMI ) THEN
50680 XXC(6)=1D6
50681 ENDIF
50682 XXC(7)=XXC(5)
50683 XXC(8)=XXC(6)
50684
50685 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50686 LKNT=LKNT+1
50687 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50688 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50689 IDLAM(LKNT,1)=KFNCHI(IJ)
50690 IDLAM(LKNT,2)=15
50691 IDLAM(LKNT,3)=-15
50692 ENDIF
50693
50694C...NEUTRINOS
50695 150 CONTINUE
50696 FID=12
50697 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50698 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50699 EI=KCHG(FID,1)/3D0
50700 T3I=SIGN(1D0,EI+1D-6)/2D0
50701 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50702 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50703 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50704 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50705 CXC(2)=-GLIJ
50706 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50707 CXC(4)=DCONJG(GLIJ)
50708 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50709 CXC(6)=GRIJ
50710 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50711 CXC(8)=-DCONJG(GRIJ)
50712 S12MIN=0D0
50713 S12MAX=(AXMI-AXMJ)**2
50714 IF( XXC(5).LT.AXMI ) THEN
50715 XXC(5)=1D6
50716 ENDIF
50717 IF( XXC(6).LT.AXMI ) THEN
50718 XXC(6)=1D6
50719 ENDIF
50720 XXC(7)=XXC(5)
50721 XXC(8)=XXC(6)
50722
50723 LKNT=LKNT+1
50724 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50725 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50726 IDLAM(LKNT,1)=KFNCHI(IJ)
50727 IDLAM(LKNT,2)=12
50728 IDLAM(LKNT,3)=-12
50729 LKNT=LKNT+1
50730 XLAM(LKNT)=XLAM(LKNT-1)
50731 IDLAM(LKNT,1)=KFNCHI(IJ)
50732 IDLAM(LKNT,2)=14
50733 IDLAM(LKNT,3)=-14
50734 160 CONTINUE
50735
50736 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
50737 & THEN
50738 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50739 IF( XXC(5).LT.AXMI ) THEN
50740 XXC(5)=1D6
50741 ENDIF
50742 XXC(7)=XXC(5)
50743 LKNT=LKNT+1
50744 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50745 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50746 ELSE
50747 LKNT=LKNT+1
50748 XLAM(LKNT)=XLAM(LKNT-1)
50749 ENDIF
50750 IDLAM(LKNT,1)=KFNCHI(IJ)
50751 IDLAM(LKNT,2)=16
50752 IDLAM(LKNT,3)=-16
50753C...D-TYPE QUARKS
50754 170 CONTINUE
50755 FID=1
50756 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50757 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50758 EI=KCHG(FID,1)/3D0
50759 T3I=SIGN(1D0,EI+1D-6)/2D0
50760 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50761 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50762 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50763 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50764 CXC(2)=-GLIJ
50765 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50766 CXC(4)=DCONJG(GLIJ)
50767 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50768 CXC(6)=GRIJ
50769 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50770 CXC(8)=-DCONJG(GRIJ)
50771 S12MIN=0D0
50772 S12MAX=(AXMI-AXMJ)**2
50773 IF( XXC(5).LT.AXMI ) THEN
50774 XXC(5)=1D6
50775 ENDIF
50776 IF( XXC(6).LT.AXMI ) THEN
50777 XXC(6)=1D6
50778 ENDIF
50779 XXC(7)=XXC(5)
50780 XXC(8)=XXC(6)
50781
50782 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50783 LKNT=LKNT+1
50784 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50785 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50786 IDLAM(LKNT,1)=KFNCHI(IJ)
50787 IDLAM(LKNT,2)=1
50788 IDLAM(LKNT,3)=-1
50789 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50790 LKNT=LKNT+1
50791 XLAM(LKNT)=XLAM(LKNT-1)
50792 IDLAM(LKNT,1)=KFNCHI(IJ)
50793 IDLAM(LKNT,2)=3
50794 IDLAM(LKNT,3)=-3
50795 ENDIF
50796 ENDIF
50797 180 CONTINUE
50798 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50799 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50800 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50801 ELSE
50802 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50803 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50804 ENDIF
50805 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50806 IF(XXC(5).LT.AXMI) THEN
50807 XXC(5)=1D6
50808 ELSEIF(XXC(6).LT.AXMI) THEN
50809 XXC(6)=1D6
50810 ENDIF
50811 XXC(7)=XXC(5)
50812 XXC(8)=XXC(6)
50813 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50814 LKNT=LKNT+1
50815 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50816 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50817 IDLAM(LKNT,1)=KFNCHI(IJ)
50818 IDLAM(LKNT,2)=5
50819 IDLAM(LKNT,3)=-5
50820 ENDIF
50821
50822C...U-TYPE QUARKS
50823 190 CONTINUE
50824 FID=2
50825 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50826 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50827 EI=KCHG(FID,1)/3D0
50828 T3I=SIGN(1D0,EI+1D-6)/2D0
50829 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50830 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50831 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50832 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50833 CXC(2)=-GLIJ
50834 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50835 CXC(4)=DCONJG(GLIJ)
50836 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50837 CXC(6)=GRIJ
50838 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50839 CXC(8)=-DCONJG(GRIJ)
50840
50841 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
50842 IF(XXC(5).LT.AXMI) THEN
50843 XXC(5)=1D6
50844 ELSEIF(XXC(6).LT.AXMI) THEN
50845 XXC(6)=1D6
50846 ENDIF
50847 XXC(7)=XXC(5)
50848 XXC(8)=XXC(6)
50849
50850 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50851 LKNT=LKNT+1
50852 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50853 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50854 IDLAM(LKNT,1)=KFNCHI(IJ)
50855 IDLAM(LKNT,2)=2
50856 IDLAM(LKNT,3)=-2
50857 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50858 LKNT=LKNT+1
50859 XLAM(LKNT)=XLAM(LKNT-1)
50860 IDLAM(LKNT,1)=KFNCHI(IJ)
50861 IDLAM(LKNT,2)=4
50862 IDLAM(LKNT,3)=-4
50863 ENDIF
50864 ENDIF
50865 200 CONTINUE
50866 ENDIF
50867
50868C...CHI0_I -> CHI0_J + H0_K
50869 EH(1)=SIN(ALFA)
50870 EH(2)=COS(ALFA)
50871 EH(3)=-SIN(BETA)
50872 DH(1)=COS(ALFA)
50873 DH(2)=-SIN(ALFA)
50874 DH(3)=COS(BETA)
50875 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
50876 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
50877 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
50878 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
50879 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
50880 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
50881 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
50882 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
50883 DO 210 IH=1,3
50884 XMH=PMAS(ITH(IH),1)
50885 XMH2=XMH**2
50886 IF(AXMI.GE.AXMJ+XMH) THEN
50887 LKNT=LKNT+1
50888 XL=PYLAMF(XMI2,XMJ2,XMH2)
50889 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
50890 F12K=F21K
50891C...SIGN OF MASSES I,J
50892 XMK=XMJ
50893 IF(IH.EQ.3) XMK=-XMK
50894 GX2=ABS(F21K)**2+ABS(F12K)**2
50895 GLR=DBLE(F21K*DCONJG(F12K))
50896 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50897 IDLAM(LKNT,1)=KFNCHI(IJ)
50898 IDLAM(LKNT,2)=ITH(IH)
50899 IDLAM(LKNT,3)=0
50900 ENDIF
50901 210 CONTINUE
50902 220 CONTINUE
50903
50904C...CHI0_I -> CHI+_J + W-
50905 DO 260 IJ=1,2
50906 XMJ=SMW(IJ)
50907 AXMJ=ABS(XMJ)
50908 XMJ2=XMJ**2
50909 IF(AXMI.GE.AXMJ+XMW) THEN
50910 LKNT=LKNT+1
50911 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50912 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
50913 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50914 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
50915 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50916 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50917 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50918 IDLAM(LKNT,1)=KFCCHI(IJ)
50919 IDLAM(LKNT,2)=-24
50920 IDLAM(LKNT,3)=0
50921 LKNT=LKNT+1
50922 XLAM(LKNT)=XLAM(LKNT-1)
50923 IDLAM(LKNT,1)=-KFCCHI(IJ)
50924 IDLAM(LKNT,2)=24
50925 IDLAM(LKNT,3)=0
50926 ELSEIF(AXMI.GE.AXMJ) THEN
50927 S12MIN=0D0
50928 S12MAX=(AXMI-AXMJ)**2
50929 RT2I = 1D0/SQRT(2D0)
50930 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50931 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
50932 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50933 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
50934 CXC(5)=DCMPLX(0D0,0D0)
50935 CXC(7)=DCMPLX(0D0,0D0)
50936 IA=11
50937 JA=12
50938 EI=KCHG(IA,1)/3D0
50939 T3I=SIGN(1D0,EI+1D-6)/2D0
50940 EJ=KCHG(JA,1)/3D0
50941 T3J=SIGN(1D0,EJ+1D-6)/2D0
50942 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
50943 & TANW+ZMIXC(IX,2)*T3J)*RT2I
50944 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
50945 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
50946 CXC(6)=DCMPLX(0D0,0D0)
50947 CXC(8)=DCMPLX(0D0,0D0)
50948 XXC(1)=0D0
50949 XXC(2)=XMJ
50950 XXC(3)=0D0
50951 XXC(4)=XMI
50952 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50953 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50954 XXC(9)=PMAS(24,1)
50955 XXC(10)=PMAS(24,2)
50956 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
50957 IF(XXC(5).LT.AXMI) THEN
50958 XXC(5)=1D6
50959 ELSEIF(XXC(6).LT.AXMI) THEN
50960 XXC(6)=1D6
50961 ENDIF
50962 XXC(7)=XXC(6)
50963 XXC(8)=XXC(5)
50964 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50965 LKNT=LKNT+1
50966 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50967 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50968 IDLAM(LKNT,1)=KFCCHI(IJ)
50969 IDLAM(LKNT,2)=11
50970 IDLAM(LKNT,3)=-12
50971 LKNT=LKNT+1
50972 XLAM(LKNT)=XLAM(LKNT-1)
50973 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50974 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50975 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50976 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50977 LKNT=LKNT+1
50978 XLAM(LKNT)=XLAM(LKNT-1)
50979 IDLAM(LKNT,1)=KFCCHI(IJ)
50980 IDLAM(LKNT,2)=13
50981 IDLAM(LKNT,3)=-14
50982 LKNT=LKNT+1
50983 XLAM(LKNT)=XLAM(LKNT-1)
50984 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50985 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50986 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50987 ENDIF
50988 ENDIF
50989 230 CONTINUE
50990 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50991 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50992 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
50993 ELSE
50994 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50995 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
50996 ENDIF
50997 IF(XXC(5).LT.AXMI) THEN
50998 XXC(5)=1D6
50999 ENDIF
51000 IF(XXC(6).LT.AXMI) THEN
51001 XXC(6)=1D6
51002 ENDIF
51003 XXC(7)=XXC(6)
51004 XXC(8)=XXC(5)
51005 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51006 LKNT=LKNT+1
51007 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51008 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51009 XLAM(LKNT)=XLAM(LKNT-1)
51010 IDLAM(LKNT,1)=KFCCHI(IJ)
51011 IDLAM(LKNT,2)=15
51012 IDLAM(LKNT,3)=-16
51013 LKNT=LKNT+1
51014 XLAM(LKNT)=XLAM(LKNT-1)
51015 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51016 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51017 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51018 ENDIF
51019
51020C...NOW, DO THE QUARKS
51021 240 CONTINUE
51022 IA=1
51023 JA=2
51024 EI=KCHG(IA,1)/3D0
51025 T3I=SIGN(1D0,EI+1D-6)/2D0
51026 EJ=KCHG(JA,1)/3D0
51027 T3J=SIGN(1D0,EJ+1D-6)/2D0
51028 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51029 & TANW+ZMIXC(IX,2)*T3J)
51030 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51031 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
51032 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51033 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
51034 IF(XXC(5).LT.AXMI) THEN
51035 XXC(5)=1D6
51036 ENDIF
51037 IF(XXC(6).LT.AXMI) THEN
51038 XXC(6)=1D6
51039 ENDIF
51040 XXC(7)=XXC(6)
51041 XXC(8)=XXC(5)
51042 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
51043 LKNT=LKNT+1
51044 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51045 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51046 IDLAM(LKNT,1)=KFCCHI(IJ)
51047 IDLAM(LKNT,2)=1
51048 IDLAM(LKNT,3)=-2
51049 LKNT=LKNT+1
51050 XLAM(LKNT)=XLAM(LKNT-1)
51051 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51052 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51053 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51054 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51055 LKNT=LKNT+1
51056 XLAM(LKNT)=XLAM(LKNT-1)
51057 IDLAM(LKNT,1)=KFCCHI(IJ)
51058 IDLAM(LKNT,2)=3
51059 IDLAM(LKNT,3)=-4
51060 LKNT=LKNT+1
51061 XLAM(LKNT)=XLAM(LKNT-1)
51062 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51063 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51064 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51065 ENDIF
51066 ENDIF
51067 250 CONTINUE
51068 ENDIF
51069 260 CONTINUE
51070 270 CONTINUE
51071
51072C...CHI0_I -> CHI+_I + H-
51073 DO 280 IJ=1,2
51074 XMJ=SMW(IJ)
51075 AXMJ=ABS(XMJ)
51076 XMJ2=XMJ**2
51077 XMHP=PMAS(ITHC,1)
51078 IF(AXMI.GE.AXMJ+XMHP) THEN
51079 LKNT=LKNT+1
51080 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
51081 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
51082 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
51083 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
51084 & UMIXC(IJ,2)/SR2)
51085 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51086 GLR=DBLE(OLPP*DCONJG(ORPP))
51087 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51088 IDLAM(LKNT,1)=KFCCHI(IJ)
51089 IDLAM(LKNT,2)=-ITHC
51090 IDLAM(LKNT,3)=0
51091 LKNT=LKNT+1
51092 XLAM(LKNT)=XLAM(LKNT-1)
51093 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51094 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51095 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51096 ELSE
51097
51098 ENDIF
51099 280 CONTINUE
51100
51101C...2-BODY DECAYS TO FERMION SFERMION
51102 DO 290 J=1,16
51103 IF(J.GE.7.AND.J.LE.10) GOTO 290
51104 KF1=KSUSY1+J
51105 KF2=KSUSY2+J
51106 XMSF1=PMAS(PYCOMP(KF1),1)
51107 XMSF2=PMAS(PYCOMP(KF2),1)
51108 XMF=PMAS(J,1)
51109 IF(J.LE.6) THEN
51110 FCOL=3D0
51111 ELSE
51112 FCOL=1D0
51113 ENDIF
51114
51115 EI=KCHG(J,1)/3D0
51116 T3T=SIGN(1D0,EI)
51117 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
51118 IF(MOD(J,2).EQ.0) THEN
51119 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51120 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
51121 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51122 CBR=CAL
51123 ELSE
51124 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51125 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
51126 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51127 CBR=CAL
51128 ENDIF
51129
51130C...D~ D_L
51131 IF(AXMI.GE.XMF+XMSF1) THEN
51132 LKNT=LKNT+1
51133 XMA2=XMSF1**2
51134 XMB2=XMF**2
51135 XL=PYLAMF(XMI2,XMA2,XMB2)
51136 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
51137 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
51138 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51139 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51140 IDLAM(LKNT,1)=KF1
51141 IDLAM(LKNT,2)=-J
51142 IDLAM(LKNT,3)=0
51143 LKNT=LKNT+1
51144 XLAM(LKNT)=XLAM(LKNT-1)
51145 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51146 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51147 IDLAM(LKNT,3)=0
51148 ENDIF
51149
51150C...D~ D_R
51151 IF(AXMI.GE.XMF+XMSF2) THEN
51152 LKNT=LKNT+1
51153 XMA2=XMSF2**2
51154 XMB2=XMF**2
51155 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
51156 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
51157 XL=PYLAMF(XMI2,XMA2,XMB2)
51158 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51159 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51160 IDLAM(LKNT,1)=KF2
51161 IDLAM(LKNT,2)=-J
51162 IDLAM(LKNT,3)=0
51163 LKNT=LKNT+1
51164 XLAM(LKNT)=XLAM(LKNT-1)
51165 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51166 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51167 IDLAM(LKNT,3)=0
51168 ENDIF
51169 290 CONTINUE
51170 300 CONTINUE
51171C...3-BODY DECAY TO Q Q~ GLUINO
51172 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51173 IF(AXMI.GE.XMJ) THEN
51174 RT2I = 1D0/SQRT(2D0)
51175 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
51176 ORPP=DCONJG(OLPP)
51177 AXMJ=ABS(XMJ)
51178 XXC(1)=0D0
51179 XXC(2)=XMJ
51180 XXC(3)=0D0
51181 XXC(4)=XMI
51182 FID=1
51183 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51184 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51185 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
51186 XXC(7)=XXC(5)
51187 XXC(8)=XXC(6)
51188 XXC(9)=1D6
51189 XXC(10)=0D0
51190 EI=KCHG(FID,1)/3D0
51191 T3I=SIGN(1D0,EI+1D-6)/2D0
51192 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51193 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51194 CXC(1)=0D0
51195 CXC(2)=-GLIJ
51196 CXC(3)=0D0
51197 CXC(4)=DCONJG(GLIJ)
51198 CXC(5)=0D0
51199 CXC(6)=GRIJ
51200 CXC(7)=0D0
51201 CXC(8)=-DCONJG(GRIJ)
51202 S12MIN=0D0
51203 S12MAX=(AXMI-AXMJ)**2
51204C...ALL QUARKS BUT T
51205 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51206 LKNT=LKNT+1
51207 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51208 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51209 IDLAM(LKNT,1)=KSUSY1+21
51210 IDLAM(LKNT,2)=1
51211 IDLAM(LKNT,3)=-1
51212 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51213 LKNT=LKNT+1
51214 XLAM(LKNT)=XLAM(LKNT-1)
51215 IDLAM(LKNT,1)=KSUSY1+21
51216 IDLAM(LKNT,2)=3
51217 IDLAM(LKNT,3)=-3
51218 ENDIF
51219 ENDIF
51220 310 CONTINUE
51221 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51222 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51223 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51224 ELSE
51225 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51226 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51227 ENDIF
51228 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
51229 XXC(7)=XXC(5)
51230 XXC(8)=XXC(6)
51231 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51232 LKNT=LKNT+1
51233 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51234 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51235 IDLAM(LKNT,1)=KSUSY1+21
51236 IDLAM(LKNT,2)=5
51237 IDLAM(LKNT,3)=-5
51238 ENDIF
51239C...U-TYPE QUARKS
51240 320 CONTINUE
51241 FID=2
51242 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51243 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51244 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
51245 XXC(7)=XXC(5)
51246 XXC(8)=XXC(6)
51247 EI=KCHG(FID,1)/3D0
51248 T3I=SIGN(1D0,EI+1D-6)/2D0
51249 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51250 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51251 CXC(2)=-GLIJ
51252 CXC(4)=DCONJG(GLIJ)
51253 CXC(6)=GRIJ
51254 CXC(8)=-DCONJG(GRIJ)
51255 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51256 LKNT=LKNT+1
51257 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51258 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51259 IDLAM(LKNT,1)=KSUSY1+21
51260 IDLAM(LKNT,2)=2
51261 IDLAM(LKNT,3)=-2
51262 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51263 LKNT=LKNT+1
51264 XLAM(LKNT)=XLAM(LKNT-1)
51265 IDLAM(LKNT,1)=KSUSY1+21
51266 IDLAM(LKNT,2)=4
51267 IDLAM(LKNT,3)=-4
51268 ENDIF
51269 ENDIF
51270 330 CONTINUE
51271 ENDIF
51272
51273C...R-violating decay modes (SKANDS).
51274 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
51275
51276 340 IKNT=LKNT
51277 XLAM(0)=0D0
51278 DO 350 I=1,IKNT
51279 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51280 XLAM(0)=XLAM(0)+XLAM(I)
51281 350 CONTINUE
51282 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51283
51284 RETURN
51285 END
51286
51287C*********************************************************************
51288
51289C...PYCJDC
51290C...Calculate decay widths for the charginos (admixtures of
51291C...charged Wino and charged Higgsino.
51292
51293C...Input: KCIN = KF code for particle
51294C...Output: XLAM = widths
51295C... IDLAM = KF codes for decay particles
51296C... IKNT = number of decay channels defined
51297C...AUTHOR: STEPHEN MRENNA
51298C...Last change:
51299C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
51300C...when CHIENU .NE. 0
51301
51302 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
51303
51304C...Double precision and integer declarations.
51305 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51306 IMPLICIT INTEGER(I-N)
51307 INTEGER PYK,PYCHGE,PYCOMP
51308C...Parameter statement to help give large particle numbers.
51309 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51310 &KEXCIT=4000000,KDIMEN=5000000)
51311C...Commonblocks.
51312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51314 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51315 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51316 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51317CC &SFMIX(16,4),
51318C COMMON/PYINTS/XXM(20)
51319 COMPLEX*16 CXC
51320 COMMON/PYINTC/XXC(10),CXC(8)
51321 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51322
51323C...Local variables
51324 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51325 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
51326 INTEGER KFIN,KCIN
51327 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51328 &XMZ,XMZ2,AXMJ,AXMI
51329 DOUBLE PRECISION S12MIN,S12MAX
51330 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
51331 DOUBLE PRECISION PYLAMF,XL
51332 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
51333 DOUBLE PRECISION PYX2XH,PYX2XG
51334 DOUBLE PRECISION XLAM(0:400)
51335 INTEGER IDLAM(400,3)
51336 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
51337 INTEGER ITH(3)
51338 INTEGER ITHC
51339 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
51340 DOUBLE PRECISION SR2
51341 DOUBLE PRECISION CBETA,SBETA,TANB
51342
51343 DOUBLE PRECISION PYALEM,PI,PYALPS
51344 DOUBLE PRECISION FCOL
51345 INTEGER KF1,KF2,ISF
51346 INTEGER KFNCHI(4),KFCCHI(2)
51347
51348 DOUBLE PRECISION TEMP
51349 EXTERNAL PYGAUS,PYXXZ6
51350 DOUBLE PRECISION PYGAUS,PYXXZ6
51351 DOUBLE PRECISION PREC
51352 DATA ITH/25,35,36/
51353 DATA ITHC/37/
51354 DATA ETAH/1D0,1D0,-1D0/
51355 DATA SR2/1.4142136D0/
51356 DATA PI/3.141592654D0/
51357 DATA PREC/1D-2/
51358 DATA KFNCHI/1000022,1000023,1000025,1000035/
51359 DATA KFCCHI/1000024,1000037/
51360
51361C...COUNT THE NUMBER OF DECAY MODES
51362 LKNT=0
51363 XMW=PMAS(24,1)
51364 XMW2=XMW**2
51365 XMZ=PMAS(23,1)
51366 XMZ2=XMZ**2
51367 XW=1D0-XMW2/XMZ2
51368 XW1=1D0-XW
51369 TANW = SQRT(XW/XW1)
51370
51371C...1 OR 2 DEPENDING ON CHARGINO TYPE
51372 IX=1
51373 IF(KFIN.EQ.KFCCHI(2)) IX=2
51374 KCIN=PYCOMP(KFIN)
51375
51376 XMI=SMW(IX)
51377 XMI2=XMI**2
51378 AXMI=ABS(XMI)
51379 AEM=PYALEM(XMI2)
51380 AS =PYALPS(XMI2)
51381 C1=AEM/XW
51382 XMI3=ABS(XMI**3)
51383 TANB=RMSS(5)
51384 BETA=ATAN(TANB)
51385 CBETA=COS(BETA)
51386 SBETA=TANB*CBETA
51387 ALFA=RMSS(18)
51388
51389 DO 110 I=1,2
51390 DO 100 J=1,2
51391 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51392 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51393 100 CONTINUE
51394 110 CONTINUE
51395
51396C...GRAVITINO DECAY MODES
51397
51398 IF(IMSS(11).EQ.1) THEN
51399 XMP=RMSS(29)
51400 IDG=39+KSUSY1
51401 XMGR=PMAS(PYCOMP(IDG),1)
51402C SINW=SQRT(XW)
51403C COSW=SQRT(1D0-XW)
51404 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51405 IF(AXMI.GT.XMGR+XMW) THEN
51406 LKNT=LKNT+1
51407 IDLAM(LKNT,1)=IDG
51408 IDLAM(LKNT,2)=24
51409 IDLAM(LKNT,3)=0
51410 XLAM(LKNT)=XFAC*(
51411 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
51412 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
51413 & (1D0-XMW2/XMI2)**4
51414 ENDIF
51415 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
51416 LKNT=LKNT+1
51417 IDLAM(LKNT,1)=IDG
51418 IDLAM(LKNT,2)=37
51419 IDLAM(LKNT,3)=0
51420 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
51421 & (ABS(UMIXC(IX,2))*SBETA)**2))
51422 & *(1D0-PMAS(37,1)**2/XMI2)**4
51423 ENDIF
51424 ENDIF
51425
51426C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51427 IF(IX.EQ.1) GOTO 170
51428 XMJ=SMW(1)
51429 AXMJ=ABS(XMJ)
51430 XMJ2=XMJ**2
51431
51432C...CHI_2+ -> CHI_1+ + Z0
51433 IF(AXMI.GE.AXMJ+XMZ) THEN
51434 LKNT=LKNT+1
51435 IJ=1
51436 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51437 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51438 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51439 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51440 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51441 GLR=DBLE(OLPP*DCONJG(ORPP))
51442 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51443 IDLAM(LKNT,1)=KFCCHI(1)
51444 IDLAM(LKNT,2)=23
51445 IDLAM(LKNT,3)=0
51446
51447C...CHARGED LEPTONS
51448 ELSEIF(AXMI.GE.AXMJ) THEN
51449 S12MIN=0D0
51450 S12MAX=(AXMI-AXMJ)**2
51451 IA=11
51452 JA=12
51453 EI=KCHG(IABS(IA),1)/3D0
51454 T3I=SIGN(1D0,EI+1D-6)/2D0
51455 XXC(1)=0D0
51456 XXC(2)=XMJ
51457 XXC(3)=0D0
51458 XXC(4)=XMI
51459 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51460 XXC(6)=1D6
51461 XXC(9)=PMAS(23,1)
51462 XXC(10)=PMAS(23,2)
51463 IJ=1
51464 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51465 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51466 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51467 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51468 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51469 CXC(2)=DCMPLX(0D0,0D0)
51470 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51471 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51472 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51473 CXC(6)=DCMPLX(0D0,0D0)
51474 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51475 CXC(8)=DCMPLX(0D0,0D0)
51476 IF( XXC(5).LT.AXMI ) THEN
51477 XXC(5)=1D6
51478 ENDIF
51479 XXC(7)=XXC(5)
51480 XXC(8)=XXC(6)
51481 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51482 LKNT=LKNT+1
51483 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51484 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51485 IDLAM(LKNT,1)=KFCCHI(1)
51486 IDLAM(LKNT,2)=11
51487 IDLAM(LKNT,3)=-11
51488 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51489 LKNT=LKNT+1
51490 XLAM(LKNT)=XLAM(LKNT-1)
51491 IDLAM(LKNT,1)=KFCCHI(1)
51492 IDLAM(LKNT,2)=13
51493 IDLAM(LKNT,3)=-13
51494 ENDIF
51495 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51496 LKNT=LKNT+1
51497 XLAM(LKNT)=XLAM(LKNT-1)
51498 IDLAM(LKNT,1)=KFCCHI(1)
51499 IDLAM(LKNT,2)=15
51500 IDLAM(LKNT,3)=-15
51501 ENDIF
51502 ENDIF
51503
51504C...NEUTRINOS
51505 120 CONTINUE
51506 IA=12
51507 JA=11
51508 EI=KCHG(IABS(IA),1)/3D0
51509 T3I=SIGN(1D0,EI+1D-6)/2D0
51510 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51511 XXC(6)=1D6
51512 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51513 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51514 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51515 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51516 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51517 IF( XXC(5).LT.AXMI ) THEN
51518 XXC(5)=1D6
51519 ENDIF
51520 XXC(7)=XXC(5)
51521 XXC(8)=XXC(6)
51522 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
51523 LKNT=LKNT+1
51524 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51525 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51526 IDLAM(LKNT,1)=KFCCHI(1)
51527 IDLAM(LKNT,2)=12
51528 IDLAM(LKNT,3)=-12
51529 LKNT=LKNT+1
51530 XLAM(LKNT)=XLAM(LKNT-1)
51531 IDLAM(LKNT,1)=KFCCHI(1)
51532 IDLAM(LKNT,2)=14
51533 IDLAM(LKNT,3)=-14
51534 ENDIF
51535 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
51536 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51537 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51538 ELSE
51539 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51540 ENDIF
51541 IF( XXC(5).LT.AXMI ) THEN
51542 XXC(5)=1D6
51543 ENDIF
51544 XXC(7)=XXC(5)
51545 LKNT=LKNT+1
51546 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51547 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51548 IDLAM(LKNT,1)=KFCCHI(1)
51549 IDLAM(LKNT,2)=16
51550 IDLAM(LKNT,3)=-16
51551 ENDIF
51552
51553C...D-TYPE QUARKS
51554 130 CONTINUE
51555 IA=1
51556 JA=2
51557 EI=KCHG(IABS(IA),1)/3D0
51558 T3I=SIGN(1D0,EI+1D-6)/2D0
51559 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51560 XXC(6)=1D6
51561 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51562 CXC(2)=DCMPLX(0D0,0D0)
51563 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51564 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51565 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51566 CXC(6)=DCMPLX(0D0,0D0)
51567 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51568 CXC(8)=DCMPLX(0D0,0D0)
51569 IF( XXC(5).LT.AXMI ) THEN
51570 XXC(5)=1D6
51571 ENDIF
51572 XXC(7)=XXC(5)
51573 XXC(8)=XXC(6)
51574 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51575 LKNT=LKNT+1
51576 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51577 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51578 IDLAM(LKNT,1)=KFCCHI(1)
51579 IDLAM(LKNT,2)=1
51580 IDLAM(LKNT,3)=-1
51581 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51582 LKNT=LKNT+1
51583 XLAM(LKNT)=XLAM(LKNT-1)
51584 IDLAM(LKNT,1)=KFCCHI(1)
51585 IDLAM(LKNT,2)=3
51586 IDLAM(LKNT,3)=-3
51587 ENDIF
51588 ENDIF
51589 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51590 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51591 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51592 ELSE
51593 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51594 ENDIF
51595 IF( XXC(5).LT.AXMI ) THEN
51596 XXC(5)=1D6
51597 ENDIF
51598 XXC(7)=XXC(5)
51599 LKNT=LKNT+1
51600 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51601 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51602 IDLAM(LKNT,1)=KFCCHI(1)
51603 IDLAM(LKNT,2)=5
51604 IDLAM(LKNT,3)=-5
51605 ENDIF
51606
51607C...U-TYPE QUARKS
51608 140 CONTINUE
51609 IA=2
51610 JA=1
51611 EI=KCHG(IABS(IA),1)/3D0
51612 T3I=SIGN(1D0,EI+1D-6)/2D0
51613 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51614 XXC(6)=1D6
51615 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51616 CXC(2)=DCMPLX(0D0,0D0)
51617 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51618 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51619 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51620 CXC(6)=DCMPLX(0D0,0D0)
51621 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51622 CXC(8)=DCMPLX(0D0,0D0)
51623 IF( XXC(5).LT.AXMI ) THEN
51624 XXC(5)=1D6
51625 ENDIF
51626 XXC(7)=XXC(5)
51627 XXC(8)=XXC(6)
51628 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51629 LKNT=LKNT+1
51630 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51631 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51632 IDLAM(LKNT,1)=KFCCHI(1)
51633 IDLAM(LKNT,2)=2
51634 IDLAM(LKNT,3)=-2
51635 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51636 LKNT=LKNT+1
51637 XLAM(LKNT)=XLAM(LKNT-1)
51638 IDLAM(LKNT,1)=KFCCHI(1)
51639 IDLAM(LKNT,2)=4
51640 IDLAM(LKNT,3)=-4
51641 ENDIF
51642 ENDIF
51643 150 CONTINUE
51644 ENDIF
51645
51646C...CHI_2+ -> CHI_1+ + H0_K
51647 EH(2)=COS(ALFA)
51648 EH(1)=SIN(ALFA)
51649 EH(3)=-SBETA
51650 DH(2)=-SIN(ALFA)
51651 DH(1)=COS(ALFA)
51652 DH(3)=COS(BETA)
51653 DO 160 IH=1,3
51654 XMH=PMAS(ITH(IH),1)
51655 XMH2=XMH**2
51656C...NO 3-BODY OPTION
51657 IF(AXMI.GE.AXMJ+XMH) THEN
51658 LKNT=LKNT+1
51659 XL=PYLAMF(XMI2,XMJ2,XMH2)
51660 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
51661 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
51662 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
51663 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
51664 XMK=XMJ*ETAH(IH)
51665 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51666 GLR=DBLE(OLPP*DCONJG(ORPP))
51667 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51668 IDLAM(LKNT,1)=KFCCHI(1)
51669 IDLAM(LKNT,2)=ITH(IH)
51670 IDLAM(LKNT,3)=0
51671 ENDIF
51672 160 CONTINUE
51673
51674C...CHI1 JUMPS TO HERE
51675 170 CONTINUE
51676
51677C...CHI+_I -> CHI0_J + W+
51678 DO 220 IJ=1,4
51679 XMJ=SMZ(IJ)
51680 AXMJ=ABS(XMJ)
51681 XMJ2=XMJ**2
51682 IF(AXMI.GE.AXMJ+XMW) THEN
51683 LKNT=LKNT+1
51684 DO 180 I=1,4
51685 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51686 180 CONTINUE
51687 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51688 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
51689 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51690 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
51691 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51692 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51693 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51694 IDLAM(LKNT,1)=KFNCHI(IJ)
51695 IDLAM(LKNT,2)=24
51696 IDLAM(LKNT,3)=0
51697C...LEPTONS
51698 ELSEIF(AXMI.GE.AXMJ) THEN
51699 S12MIN=0D0
51700 S12MAX=(AXMI-AXMJ)**2
51701 DO 190 I=1,4
51702 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51703 190 CONTINUE
51704 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51705 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
51706 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51707 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
51708 CXC(5)=DCMPLX(0D0,0D0)
51709 CXC(7)=DCMPLX(0D0,0D0)
51710 IA=11
51711 JA=12
51712 EI=KCHG(IA,1)/3D0
51713 T3I=SIGN(1D0,EI+1D-6)/2D0
51714 EJ=KCHG(JA,1)/3D0
51715 T3J=SIGN(1D0,EJ+1D-6)/2D0
51716 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51717 & TANW+ZMIXC(IJ,2)*T3J)/SR2
51718 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51719 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
51720 CXC(6)=DCMPLX(0D0,0D0)
51721 CXC(8)=DCMPLX(0D0,0D0)
51722 XXC(1)=0D0
51723 XXC(2)=XMJ
51724 XXC(3)=0D0
51725 XXC(4)=XMI
51726 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51727 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51728 XXC(9)=PMAS(24,1)
51729 XXC(10)=PMAS(24,2)
51730CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51731 IF(XXC(5).LT.AXMI) THEN
51732 XXC(5)=1D6
51733 ELSEIF(XXC(6).LT.AXMI) THEN
51734 XXC(6)=1D6
51735 ENDIF
51736 XXC(7)=XXC(6)
51737 XXC(8)=XXC(5)
51738C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
51739C...--> 1/(16PI)/M**3*(AEM/XW)**2
51740 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51741 LKNT=LKNT+1
51742 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51743 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51744 IDLAM(LKNT,1)=KFNCHI(IJ)
51745 IDLAM(LKNT,2)=-11
51746 IDLAM(LKNT,3)=12
51747C...ONLY DECAY CHI+1 -> E+ NU_E
51748 IF( IMSS(12).NE. 0 ) GOTO 260
51749 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51750 LKNT=LKNT+1
51751 XLAM(LKNT)=XLAM(LKNT-1)
51752 IDLAM(LKNT,1)=KFNCHI(IJ)
51753 IDLAM(LKNT,2)=-13
51754 IDLAM(LKNT,3)=14
51755 ENDIF
51756 ENDIF
51757 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51758 LKNT=LKNT+1
51759 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51760 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51761 ELSE
51762 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51763 ENDIF
51764 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51765 IF(XXC(5).LT.AXMI) THEN
51766 XXC(5)=1D6
51767 ELSEIF(XXC(6).LT.AXMI) THEN
51768 XXC(6)=1D6
51769 ENDIF
51770 XXC(7)=XXC(6)
51771 XXC(8)=XXC(5)
51772 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51773 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51774 IDLAM(LKNT,1)=KFNCHI(IJ)
51775 IDLAM(LKNT,2)=-15
51776 IDLAM(LKNT,3)=16
51777 ENDIF
51778
51779C...NOW, DO THE QUARKS
51780 200 CONTINUE
51781 IA=1
51782 JA=2
51783 EI=KCHG(IA,1)/3D0
51784 T3I=SIGN(1D0,EI+1D-6)/2D0
51785 EJ=KCHG(JA,1)/3D0
51786 T3J=SIGN(1D0,EJ+1D-6)/2D0
51787 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51788 & TANW+ZMIXC(IJ,2)*T3J)
51789 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51790 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
51791 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51792 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51793 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
51794 IF(XXC(5).LT.AXMI) THEN
51795 XXC(5)=1D6
51796 ENDIF
51797 IF(XXC(6).LT.AXMI) THEN
51798 XXC(6)=1D6
51799 ENDIF
51800 XXC(7)=XXC(6)
51801 XXC(8)=XXC(5)
51802 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51803 LKNT=LKNT+1
51804 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51805 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51806 IDLAM(LKNT,1)=KFNCHI(IJ)
51807 IDLAM(LKNT,2)=-1
51808 IDLAM(LKNT,3)=2
51809 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51810 LKNT=LKNT+1
51811 XLAM(LKNT)=XLAM(LKNT-1)
51812 IDLAM(LKNT,1)=KFNCHI(IJ)
51813 IDLAM(LKNT,2)=-3
51814 IDLAM(LKNT,3)=4
51815 ENDIF
51816 ENDIF
51817 210 CONTINUE
51818 ENDIF
51819 220 CONTINUE
51820
51821C...CHI+_I -> CHI0_J + H+
51822 DO 230 IJ=1,4
51823 XMJ=SMZ(IJ)
51824 AXMJ=ABS(XMJ)
51825 XMJ2=XMJ**2
51826 XMHP=PMAS(ITHC,1)
51827 IF(AXMI.GE.AXMJ+XMHP) THEN
51828 LKNT=LKNT+1
51829 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
51830 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
51831 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
51832 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
51833 & UMIXC(IX,2)/SR2)
51834 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51835 GLR=DBLE(OLPP*DCONJG(ORPP))
51836 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51837 IDLAM(LKNT,1)=KFNCHI(IJ)
51838 IDLAM(LKNT,2)=ITHC
51839 IDLAM(LKNT,3)=0
51840 ELSE
51841
51842 ENDIF
51843 230 CONTINUE
51844
51845C...2-BODY DECAYS TO FERMION SFERMION
51846 DO 240 J=1,16
51847 IF(J.GE.7.AND.J.LE.10) GOTO 240
51848 IF(MOD(J,2).EQ.0) THEN
51849 KF1=KSUSY1+J-1
51850 ELSE
51851 KF1=KSUSY1+J+1
51852 ENDIF
51853 KF2=KF1+KSUSY1
51854 XMSF1=PMAS(PYCOMP(KF1),1)
51855 XMSF2=PMAS(PYCOMP(KF2),1)
51856 XMF=PMAS(J,1)
51857 IF(J.LE.6) THEN
51858 FCOL=3D0
51859 ELSE
51860 FCOL=1D0
51861 ENDIF
51862
51863C...U~ D_L
51864 IF(MOD(J,2).EQ.0) THEN
51865 XMFP=PMAS(J-1,1)
51866 CAL=UMIXC(IX,1)
51867 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
51868 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
51869 CBR=0D0
51870 ISF=J-1
51871 ELSE
51872 XMFP=PMAS(J+1,1)
51873 CAL=VMIXC(IX,1)
51874 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
51875 CBR=0D0
51876 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
51877 ISF=J+1
51878 ENDIF
51879
51880C...~U_L D
51881 IF(AXMI.GE.XMF+XMSF1) THEN
51882 LKNT=LKNT+1
51883 XMA2=XMSF1**2
51884 XMB2=XMF**2
51885 XL=PYLAMF(XMI2,XMA2,XMB2)
51886 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
51887 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
51888 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51889 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51890 IDLAM(LKNT,3)=0
51891 IF(MOD(J,2).EQ.0) THEN
51892 IDLAM(LKNT,1)=-KF1
51893 IDLAM(LKNT,2)=J
51894 ELSE
51895 IDLAM(LKNT,1)=KF1
51896 IDLAM(LKNT,2)=-J
51897 ENDIF
51898 ENDIF
51899
51900C...U~ D_R
51901 IF(AXMI.GE.XMF+XMSF2) THEN
51902 LKNT=LKNT+1
51903 XMA2=XMSF2**2
51904 XMB2=XMF**2
51905 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
51906 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
51907 XL=PYLAMF(XMI2,XMA2,XMB2)
51908 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51909 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51910 IDLAM(LKNT,3)=0
51911 IF(MOD(J,2).EQ.0) THEN
51912 IDLAM(LKNT,1)=-KF2
51913 IDLAM(LKNT,2)=J
51914 ELSE
51915 IDLAM(LKNT,1)=KF2
51916 IDLAM(LKNT,2)=-J
51917 ENDIF
51918 ENDIF
51919 240 CONTINUE
51920
51921C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
51922C...A 2-BODY -- 2-BODY CHAIN
51923 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51924 IF(AXMI.GE.XMJ) THEN
51925 AXMJ=ABS(XMJ)
51926 S12MIN=0D0
51927 S12MAX=(AXMI-AXMJ)**2
51928 XXC(1)=0D0
51929 XXC(2)=XMJ
51930 XXC(3)=0D0
51931 XXC(4)=XMI
51932 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51933 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51934 XXC(9)=1D6
51935 XXC(10)=0D0
51936 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51937 ORPP=DCONJG(OLPP)
51938 CXC(1)=DCMPLX(0D0,0D0)
51939 CXC(3)=DCMPLX(0D0,0D0)
51940 CXC(5)=DCMPLX(0D0,0D0)
51941 CXC(7)=DCMPLX(0D0,0D0)
51942 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51943 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51944 CXC(6)=DCMPLX(0D0,0D0)
51945 CXC(8)=DCMPLX(0D0,0D0)
51946 IF(XXC(5).LT.AXMI) THEN
51947 XXC(5)=1D6
51948 ELSEIF(XXC(6).LT.AXMI) THEN
51949 XXC(6)=1D6
51950 ENDIF
51951 XXC(7)=XXC(6)
51952 XXC(8)=XXC(5)
51953 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
51954 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51955 LKNT=LKNT+1
51956 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51957 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51958 IDLAM(LKNT,1)=KSUSY1+21
51959 IDLAM(LKNT,2)=-1
51960 IDLAM(LKNT,3)=2
51961 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51962 LKNT=LKNT+1
51963 XLAM(LKNT)=XLAM(LKNT-1)
51964 IDLAM(LKNT,1)=KSUSY1+21
51965 IDLAM(LKNT,2)=-3
51966 IDLAM(LKNT,3)=4
51967 ENDIF
51968 ENDIF
51969 250 CONTINUE
51970 ENDIF
51971
51972C...R-violating decay modes (SKANDS).
51973 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
51974
51975 260 IKNT=LKNT
51976 XLAM(0)=0D0
51977 DO 270 I=1,IKNT
51978 XLAM(0)=XLAM(0)+XLAM(I)
51979 IF(XLAM(I).LT.0D0) THEN
51980 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
51981 & (IDLAM(I,J),J=1,3)
51982 XLAM(I)=0D0
51983 ENDIF
51984 270 CONTINUE
51985 IF(XLAM(0).EQ.0D0) THEN
51986 XLAM(0)=1D-6
51987 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
51988 WRITE(MSTU(11),*) LKNT
51989 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
51990 ENDIF
51991
51992 RETURN
51993 END
51994
51995C*********************************************************************
51996
51997C...PYXXZ6
51998C...Used in the calculation of inoi -> inoj + f + ~f.
51999
52000 FUNCTION PYXXZ6(X)
52001
52002C...Double precision and integer declarations.
52003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52004 IMPLICIT INTEGER(I-N)
52005 INTEGER PYK,PYCHGE,PYCOMP
52006C...Parameter statement to help give large particle numbers.
52007 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52008 &KEXCIT=4000000,KDIMEN=5000000)
52009C...Commonblocks.
52010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52011C COMMON/PYINTS/XXM(20)
52012 COMPLEX*16 CXC
52013 COMMON/PYINTC/XXC(10),CXC(8)
52014 SAVE /PYDAT1/,/PYINTC/
52015
52016C...Local variables.
52017 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52018 DOUBLE PRECISION PYXXZ6,X
52019 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52020 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52021 DOUBLE PRECISION SIJ
52022 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52023 DOUBLE PRECISION OL2
52024 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52025 INTEGER I
52026
52027C...Statement functions.
52028C...Integral from x to y of (t-a)(b-t) dt.
52029 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
52030C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52031 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
52032 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
52033C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52034 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
52035 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
52036C...Integral from x to y of (t-a)/(b-t) dt.
52037 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
52038C...Integral from x to y of 1/(t-a) dt.
52039 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
52040
52041 XM12=XXC(1)**2
52042 XM22=XXC(2)**2
52043 XM32=XXC(3)**2
52044 S=XXC(4)**2
52045 S13=X
52046
52047 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
52048 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
52049 &( (X-XM22-S)**2 -4D0*XM22*S ) )
52050
52051 S23MIN=(S23AVE-S23DEL)
52052 S23MAX=(S23AVE+S23DEL)
52053
52054 XMSD1=XXC(5)**2
52055 XMSD2=XXC(7)**2
52056 XMSU1=XXC(6)**2
52057 XMSU2=XXC(8)**2
52058
52059 XMV=XXC(9)
52060 XMG=XXC(10)
52061 QLLS=CXC(1)
52062 QLLU=CXC(2)
52063 QLRS=CXC(3)
52064 QLRT=CXC(4)
52065 QRLS=CXC(5)
52066 QRLT=CXC(6)
52067 QRRS=CXC(7)
52068 QRRU=CXC(8)
52069 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
52070 SIJ=2D0*XXC(2)*XXC(4)*S13
52071 IF(XMV.LE.1000D0) THEN
52072 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
52073 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
52074 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
52075 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
52076 IF(XXC(5).LE.10000D0) THEN
52077 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
52078 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
52079 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
52080 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
52081 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
52082 & *(S13-XMV**2)/WPROP2
52083 ELSE
52084 WFL1=0D0
52085 ENDIF
52086
52087 IF(XXC(6).LE.10000D0) THEN
52088 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
52089 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
52090 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
52091 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
52092 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
52093 & *(S13-XMV**2)/WPROP2
52094 ELSE
52095 WFL2=0D0
52096 ENDIF
52097 ELSE
52098 WW=0D0
52099 WFL1=0D0
52100 WFL2=0D0
52101 ENDIF
52102 IF(XXC(5).LE.10000D0) THEN
52103 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
52104 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
52105 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
52106 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
52107 ELSE
52108 WF1=0D0
52109 ENDIF
52110 IF(XXC(6).LE.10000D0) THEN
52111 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
52112 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
52113 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
52114 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
52115 ELSE
52116 WF2=0D0
52117 ENDIF
52118
52119 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
52120
52121 IF(PYXXZ6.LT.0D0) THEN
52122 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
52123 WRITE(MSTU(11),*) (XXC(I),I=1,5)
52124 WRITE(MSTU(11),*) (XXC(I),I=6,10)
52125 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
52126 WRITE(MSTU(11),*) S23MIN,S23MAX
52127 PYXXZ6=0D0
52128 ENDIF
52129
52130 RETURN
52131 END
52132
52133
52134C*********************************************************************
52135
52136C...PYXXGA
52137C...Calculates chi0_i -> chi0_j + gamma.
52138
52139 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
52140
52141C...Double precision and integer declarations.
52142 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52143 IMPLICIT INTEGER(I-N)
52144 INTEGER PYK,PYCHGE,PYCOMP
52145
52146C...Local variables.
52147 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
52148 DOUBLE PRECISION F1,F2
52149
52150 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
52151 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
52152 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
52153 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
52154
52155 RETURN
52156 END
52157
52158C*********************************************************************
52159
52160C...PYX2XG
52161C...Calculates the decay rate for ino -> ino + gauge boson.
52162
52163 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
52164
52165C...Double precision and integer declarations.
52166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52167 IMPLICIT INTEGER(I-N)
52168 INTEGER PYK,PYCHGE,PYCOMP
52169
52170C...Local variables.
52171 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
52172 DOUBLE PRECISION XL,PYLAMF,C1
52173 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52174
52175 XMI2=XM1**2
52176 XMI3=ABS(XM1**3)
52177 XMJ2=XM2**2
52178 XMV2=XM3**2
52179 XL=PYLAMF(XMI2,XMJ2,XMV2)
52180 PYX2XG=C1/8D0/XMI3*SQRT(XL)
52181 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
52182 &12D0*GLR*XM1*XM2*XMV2)
52183
52184 RETURN
52185 END
52186
52187C*********************************************************************
52188
52189C...PYX2XH
52190C...Calculates the decay rate for ino -> ino + H.
52191
52192 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
52193
52194C...Double precision and integer declarations.
52195 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52196 IMPLICIT INTEGER(I-N)
52197 INTEGER PYK,PYCHGE,PYCOMP
52198
52199C...Local variables.
52200 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
52201 DOUBLE PRECISION XL,PYLAMF,C1
52202 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52203
52204 XMI2=XM1**2
52205 XMI3=ABS(XM1**3)
52206 XMJ2=XM2**2
52207 XMV2=XM3**2
52208 XL=PYLAMF(XMI2,XMJ2,XMV2)
52209 PYX2XH=C1/8D0/XMI3*SQRT(XL)
52210 &*(GX2*(XMI2+XMJ2-XMV2)+
52211 &4D0*GLR*XM1*XM2)
52212
52213 RETURN
52214 END
52215
52216C*********************************************************************
52217
52218C...PYHEXT
52219C...Calculates the non-standard decay modes of the Higgs boson.
52220C...
52221C...Author: Stephen Mrenna
52222C...Last Update: April 2001
52223C......Allow complex values for Z,U, and V
52224
52225 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
52226
52227C...Double precision and integer declarations.
52228 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52229 IMPLICIT INTEGER(I-N)
52230 INTEGER PYK,PYCHGE,PYCOMP
52231C...Parameter statement to help give large particle numbers.
52232 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52233 &KEXCIT=4000000,KDIMEN=5000000)
52234C...Commonblocks.
52235 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52236 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52237 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52238 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52239 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52240 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52241 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
52242
52243C...Local variables.
52244 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52245 COMPLEX*16 QIJ,RIJ,F21K,F12K
52246 INTEGER KFIN
52247 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
52248 DOUBLE PRECISION XMI2,XMI3,XMJ2
52249 DOUBLE PRECISION PYLAMF,XL,CF,EI
52250 INTEGER IDU,IFL
52251 DOUBLE PRECISION TANW,XW,AEM,C1,AS
52252 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
52253 DOUBLE PRECISION XLAM(0:400)
52254 INTEGER IDLAM(400,3)
52255 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
52256 INTEGER ITH(4)
52257 INTEGER KFNCHI(4),KFCCHI(2)
52258 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
52259 DOUBLE PRECISION SR2
52260 DOUBLE PRECISION BETA,ALFA
52261 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
52262 DOUBLE PRECISION PYALEM
52263 DOUBLE PRECISION AL,AR,ALR
52264 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
52265 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
52266 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
52267 DATA ITH/25,35,36,37/
52268 DATA ETAH/1D0,1D0,-1D0/
52269 DATA SR2/1.4142136D0/
52270 DATA KFNCHI/1000022,1000023,1000025,1000035/
52271 DATA KFCCHI/1000024,1000037/
52272
52273C...COUNT THE NUMBER OF DECAY MODES
52274 LKNT=IKNT
52275
52276 XMW=PMAS(24,1)
52277 XMW2=XMW**2
52278 XMZ=PMAS(23,1)
52279 XW=PARU(102)
52280 TANW = SQRT(XW/(1D0-XW))
52281 CW=SQRT(1D0-XW)
52282
52283C...1 - 4 DEPENDING ON Higgs species.
52284 IH=1
52285 IF(KFIN.EQ.ITH(2)) IH=2
52286 IF(KFIN.EQ.ITH(3)) IH=3
52287 IF(KFIN.EQ.ITH(4)) IH=4
52288
52289 XMI=PMAS(KFIN,1)
52290 XMI2=XMI**2
52291 AXMI=ABS(XMI)
52292 AEM=PYALEM(XMI2)
52293 C1=AEM/XW
52294 XMI3=ABS(XMI**3)
52295
52296 TANB=RMSS(5)
52297 BETA=ATAN(TANB)
52298 CBETA=COS(BETA)
52299 SBETA=TANB*CBETA
52300 ALFA=RMSS(18)
52301 COSA=COS(ALFA)
52302 SINA=SIN(ALFA)
52303 ATRIT=RMSS(16)
52304 ATRIB=RMSS(15)
52305 ATRIL=RMSS(17)
52306 XMUZ=-RMSS(4)
52307
52308 DO 110 I=1,4
52309 DO 100 J=1,4
52310 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52311 100 CONTINUE
52312 110 CONTINUE
52313 DO 130 I=1,2
52314 DO 120 J=1,2
52315 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52316 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52317 120 CONTINUE
52318 130 CONTINUE
52319
52320
52321 IF(IH.EQ.4) GOTO 220
52322
52323C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52324C...H0_K -> CHI0_I + CHI0_J
52325 EH(2)=SINA
52326 EH(1)=COSA
52327 EH(3)=CBETA
52328 DH(2)=COSA
52329 DH(1)=-SINA
52330 DH(3)=SBETA
52331 DO 150 IJ=1,4
52332 XMJ=SMZ(IJ)
52333 AXMJ=ABS(XMJ)
52334 DO 140 IK=1,IJ
52335 XMK=SMZ(IK)
52336 AXMK=ABS(XMK)
52337 IF(AXMI.GE.AXMJ+AXMK) THEN
52338 LKNT=LKNT+1
52339 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
52340 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
52341 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
52342 & ZMIXC(IJ,3)*ZMIXC(IK,1))
52343 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
52344 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
52345 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
52346 & ZMIXC(IJ,4)*ZMIXC(IK,1))
52347 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
52348 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
52349C...SIGN OF MASSES I,J
52350 XML=XMK*ETAH(IH)
52351 GX2=ABS(F12K)**2+ABS(F21K)**2
52352 GLR=DBLE(F12K*DCONJG(F21K))
52353 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52354 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
52355 IDLAM(LKNT,1)=KFNCHI(IJ)
52356 IDLAM(LKNT,2)=KFNCHI(IK)
52357 IDLAM(LKNT,3)=0
52358 ENDIF
52359 140 CONTINUE
52360 150 CONTINUE
52361
52362C...H0_K -> CHI+_I CHI-_J
52363 DO 170 IJ=1,2
52364 XMJ=SMW(IJ)
52365 AXMJ=ABS(XMJ)
52366 DO 160 IK=1,2
52367 XMK=SMW(IK)
52368 AXMK=ABS(XMK)
52369 IF(AXMI.GE.AXMJ+AXMK) THEN
52370 LKNT=LKNT+1
52371 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
52372 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
52373 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
52374 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
52375 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52376 GLR=DBLE(OLPP*DCONJG(ORPP))
52377 XML=XMK*ETAH(IH)
52378 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52379 IDLAM(LKNT,1)=KFCCHI(IJ)
52380 IDLAM(LKNT,2)=-KFCCHI(IK)
52381 IDLAM(LKNT,3)=0
52382 ENDIF
52383 160 CONTINUE
52384 170 CONTINUE
52385
52386C...HIGGS TO SFERMION SFERMION
52387 DO 200 IFL=1,16
52388 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
52389 IJ=KSUSY1+IFL
52390 XMJL=PMAS(PYCOMP(IJ),1)
52391 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
52392 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
52393 XMJ=XMJL
52394 XMJ2=XMJ**2
52395 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52396 XMF=PMAS(IFL,1)
52397 EI=KCHG(IFL,1)/3D0
52398 IDU=2-MOD(IFL,2)
52399
52400 IF(IH.EQ.1) THEN
52401 IF(IDU.EQ.1) THEN
52402 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
52403 & XMF**2/XMW*SINA/CBETA
52404 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
52405 & XMF**2/XMW*SINA/CBETA
52406 IF(IFL.EQ.5) THEN
52407 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52408 & ATRIB*SINA)
52409 ELSEIF(IFL.EQ.15) THEN
52410 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52411 & ATRIL*SINA)
52412 ELSE
52413 GHLR=0D0
52414 ENDIF
52415 ELSE
52416 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
52417 & XMF**2/XMW*COSA/SBETA
52418 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
52419 & XMF**2/XMW*COSA/SBETA
52420 IF(IFL.EQ.6) THEN
52421 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
52422 & ATRIT*COSA)
52423 ELSE
52424 GHLR=0D0
52425 ENDIF
52426 ENDIF
52427
52428 ELSEIF(IH.EQ.2) THEN
52429 IF(IDU.EQ.1) THEN
52430 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
52431 & XMF**2/XMW*COSA/CBETA
52432 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52433 & XMF**2/XMW*COSA/CBETA
52434 IF(IFL.EQ.5) THEN
52435 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52436 & ATRIB*COSA)
52437 ELSEIF(IFL.EQ.15) THEN
52438 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52439 & ATRIL*COSA)
52440 ELSE
52441 GHLR=0D0
52442 ENDIF
52443 ELSE
52444 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
52445 & XMF**2/XMW*SINA/SBETA
52446 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52447 & XMF**2/XMW*SINA/SBETA
52448 IF(IFL.EQ.6) THEN
52449 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
52450 & ATRIT*SINA)
52451 ELSE
52452 GHLR=0D0
52453 ENDIF
52454 ENDIF
52455
52456 ELSEIF(IH.EQ.3) THEN
52457 GHLL=0D0
52458 GHRR=0D0
52459 GHLR=0D0
52460 IF(IDU.EQ.1) THEN
52461 IF(IFL.EQ.5) THEN
52462 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
52463 ELSEIF(IFL.EQ.15) THEN
52464 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
52465 ENDIF
52466 ELSE
52467 IF(IFL.EQ.6) THEN
52468 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
52469 ENDIF
52470 ENDIF
52471 ENDIF
52472 IF(IH.EQ.3) GOTO 180
52473
52474 AL=SFMIX(IFL,1)**2
52475 AR=SFMIX(IFL,2)**2
52476 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
52477 IF(IFL.LE.6) THEN
52478 CF=3D0
52479 ELSE
52480 CF=1D0
52481 ENDIF
52482
52483 IF(AXMI.GE.2D0*XMJ) THEN
52484 LKNT=LKNT+1
52485 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52486 & (GHLL*AL+GHRR*AR
52487 & +2D0*GHLR*ALR)**2
52488 IDLAM(LKNT,1)=IJ
52489 IDLAM(LKNT,2)=-IJ
52490 IDLAM(LKNT,3)=0
52491 ENDIF
52492
52493 IF(AXMI.GE.2D0*XMJR) THEN
52494 LKNT=LKNT+1
52495 AL=SFMIX(IFL,3)**2
52496 AR=SFMIX(IFL,4)**2
52497 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
52498 XMJ=XMJR
52499 XMJ2=XMJ**2
52500 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52501 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52502 & (GHLL*AL+GHRR*AR
52503 & +2D0*GHLR*ALR)**2
52504 IDLAM(LKNT,1)=IJ+KSUSY1
52505 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52506 IDLAM(LKNT,3)=0
52507 ENDIF
52508 180 CONTINUE
52509
52510 IF(AXMI.GE.XMJL+XMJR) THEN
52511 LKNT=LKNT+1
52512 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
52513 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
52514 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
52515 XMJ=XMJR
52516 XMJ2=XMJ**2
52517 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
52518 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52519 & (GHLL*AL+GHRR*AR)**2
52520 IDLAM(LKNT,1)=IJ
52521 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52522 IDLAM(LKNT,3)=0
52523 LKNT=LKNT+1
52524 IDLAM(LKNT,1)=-IJ
52525 IDLAM(LKNT,2)=IJ+KSUSY1
52526 IDLAM(LKNT,3)=0
52527 XLAM(LKNT)=XLAM(LKNT-1)
52528 ENDIF
52529 ENDIF
52530 190 CONTINUE
52531 200 CONTINUE
52532 210 CONTINUE
52533
52534 GOTO 270
52535 220 CONTINUE
52536
52537C...H+ -> CHI+_I + CHI0_J
52538 DO 240 IJ=1,4
52539 XMJ=SMZ(IJ)
52540 AXMJ=ABS(XMJ)
52541 XMJ2=XMJ**2
52542 DO 230 IK=1,2
52543 XMK=SMW(IK)
52544 AXMK=ABS(XMK)
52545 IF(AXMI.GE.AXMJ+AXMK) THEN
52546 LKNT=LKNT+1
52547 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
52548 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
52549 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
52550 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
52551 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52552 GLR=DBLE(OLPP*DCONJG(ORPP))
52553 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
52554 IDLAM(LKNT,1)=KFNCHI(IJ)
52555 IDLAM(LKNT,2)=KFCCHI(IK)
52556 IDLAM(LKNT,3)=0
52557 ENDIF
52558 230 CONTINUE
52559 240 CONTINUE
52560
52561 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
52562 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
52563 AL=0D0
52564 AR=0D0
52565 CF=3D0
52566
52567C...H+ -> T_1 B_1~
52568 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52569 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52570 IF(XMI.GE.XM1+XM2) THEN
52571 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52572 LKNT=LKNT+1
52573 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52574 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
52575 IDLAM(LKNT,1)=KSUSY1+6
52576 IDLAM(LKNT,2)=-(KSUSY1+5)
52577 IDLAM(LKNT,3)=0
52578 ENDIF
52579
52580C...H+ -> T_2 B_1~
52581 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52582 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52583 IF(XMI.GE.XM1+XM2) THEN
52584 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52585 LKNT=LKNT+1
52586 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52587 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
52588 IDLAM(LKNT,1)=KSUSY2+6
52589 IDLAM(LKNT,2)=-(KSUSY1+5)
52590 IDLAM(LKNT,3)=0
52591 ENDIF
52592
52593C...H+ -> T_1 B_2~
52594 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52595 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52596 IF(XMI.GE.XM1+XM2) THEN
52597 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52598 LKNT=LKNT+1
52599 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52600 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
52601 IDLAM(LKNT,1)=KSUSY1+6
52602 IDLAM(LKNT,2)=-(KSUSY2+5)
52603 IDLAM(LKNT,3)=0
52604 ENDIF
52605
52606C...H+ -> T_2 B_2~
52607 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52608 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52609 IF(XMI.GE.XM1+XM2) THEN
52610 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52611 LKNT=LKNT+1
52612 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52613 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
52614 IDLAM(LKNT,1)=KSUSY2+6
52615 IDLAM(LKNT,2)=-(KSUSY2+5)
52616 IDLAM(LKNT,3)=0
52617 ENDIF
52618
52619C...H+ -> UL DL~
52620 GL=-XMW/SR2*SIN(2D0*BETA)
52621 DO 250 IJ=1,3,2
52622 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52623 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52624 IF(XMI.GE.XM1+XM2) THEN
52625 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52626 LKNT=LKNT+1
52627 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52628 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52629 IDLAM(LKNT,2)=KSUSY1+IJ+1
52630 IDLAM(LKNT,3)=0
52631 ENDIF
52632 250 CONTINUE
52633
52634C...H+ -> EL~ NUL
52635 CF=1D0
52636 DO 260 IJ=11,13,2
52637 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52638 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52639 IF(XMI.GE.XM1+XM2) THEN
52640 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52641 LKNT=LKNT+1
52642 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52643 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52644 IDLAM(LKNT,2)=KSUSY1+IJ+1
52645 IDLAM(LKNT,3)=0
52646 ENDIF
52647 260 CONTINUE
52648
52649C...H+ -> TAU1 NUTAUL
52650 XM1=PMAS(PYCOMP(KSUSY1+15),1)
52651 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52652 IF(XMI.GE.XM1+XM2) THEN
52653 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52654 LKNT=LKNT+1
52655 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
52656 IDLAM(LKNT,1)=-(KSUSY1+15)
52657 IDLAM(LKNT,2)= KSUSY1+16
52658 IDLAM(LKNT,3)=0
52659 ENDIF
52660
52661C...H+ -> TAU2 NUTAUL
52662 XM1=PMAS(PYCOMP(KSUSY2+15),1)
52663 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52664 IF(XMI.GE.XM1+XM2) THEN
52665 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52666 LKNT=LKNT+1
52667 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
52668 IDLAM(LKNT,1)=-(KSUSY2+15)
52669 IDLAM(LKNT,2)= KSUSY1+16
52670 IDLAM(LKNT,3)=0
52671 ENDIF
52672
52673 270 CONTINUE
52674 IKNT=LKNT
52675 XLAM(0)=0D0
52676 DO 280 I=1,IKNT
52677 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
52678 XLAM(0)=XLAM(0)+XLAM(I)
52679 280 CONTINUE
52680 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52681
52682 RETURN
52683 END
52684
52685C*********************************************************************
52686
52687C...PYH2XX
52688C...Calculates the decay rate for a Higgs to an ino pair.
52689
52690 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
52691
52692C...Double precision and integer declarations.
52693 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52694 IMPLICIT INTEGER(I-N)
52695 INTEGER PYK,PYCHGE,PYCOMP
52696C...Commonblocks.
52697 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52698 SAVE /PYDAT1/
52699
52700C...Local variables.
52701 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
52702 DOUBLE PRECISION XL,PYLAMF,C1
52703 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
52704
52705 XMI2=XM1**2
52706 XMI3=ABS(XM1**3)
52707 XMJ2=XM2**2
52708 XMK2=XM3**2
52709 XL=PYLAMF(XMI2,XMJ2,XMK2)
52710 PYH2XX=C1/4D0/XMI3*SQRT(XL)
52711 &*(GX2*(XMI2-XMJ2-XMK2)-
52712 &4D0*GLR*XM3*XM2)
52713 IF(PYH2XX.LT.0D0) PYH2XX=0D0
52714
52715 RETURN
52716 END
52717
52718C*********************************************************************
52719
52720C...PYGAUS
52721C...Integration by adaptive Gaussian quadrature.
52722C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52723
52724 FUNCTION PYGAUS(F, A, B, EPS)
52725
52726C...Double precision and integer declarations.
52727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52728 IMPLICIT INTEGER(I-N)
52729 INTEGER PYK,PYCHGE,PYCOMP
52730
52731C...Local declarations.
52732 EXTERNAL F
52733 DOUBLE PRECISION F,W(12), X(12)
52734 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52735 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52736 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52737 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52738 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52739 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52740 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52741 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52742 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52743 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52744 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52745 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52746
52747C...The Gaussian quadrature algorithm.
52748 H = 0D0
52749 IF(B .EQ. A) GOTO 140
52750 CONST = 5D-3 / ABS(B-A)
52751 BB = A
52752 100 CONTINUE
52753 AA = BB
52754 BB = B
52755 110 CONTINUE
52756 C1 = 0.5D0*(BB+AA)
52757 C2 = 0.5D0*(BB-AA)
52758 S8 = 0D0
52759 DO 120 I = 1, 4
52760 U = C2*X(I)
52761 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52762 120 CONTINUE
52763 S16 = 0D0
52764 DO 130 I = 5, 12
52765 U = C2*X(I)
52766 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52767 130 CONTINUE
52768 S16 = C2*S16
52769 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52770 H = H + S16
52771 IF(BB .NE. B) GOTO 100
52772 ELSE
52773 BB = C1
52774 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52775 H = 0D0
52776 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
52777 GOTO 140
52778 ENDIF
52779 140 CONTINUE
52780 PYGAUS = H
52781
52782 RETURN
52783 END
52784
52785C*********************************************************************
52786
52787C...PYGAU2
52788C...Integration by adaptive Gaussian quadrature.
52789C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52790C...Carbon copy of PYGAUS, but avoids having to use it recursively.
52791
52792 FUNCTION PYGAU2(F, A, B, EPS)
52793
52794C...Double precision and integer declarations.
52795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52796 IMPLICIT INTEGER(I-N)
52797 INTEGER PYK,PYCHGE,PYCOMP
52798
52799C...Local declarations.
52800 EXTERNAL F
52801 DOUBLE PRECISION F,W(12), X(12)
52802 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52803 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52804 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52805 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52806 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52807 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52808 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52809 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52810 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52811 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52812 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52813 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52814
52815C...The Gaussian quadrature algorithm.
52816 H = 0D0
52817 IF(B .EQ. A) GOTO 140
52818 CONST = 5D-3 / ABS(B-A)
52819 BB = A
52820 100 CONTINUE
52821 AA = BB
52822 BB = B
52823 110 CONTINUE
52824 C1 = 0.5D0*(BB+AA)
52825 C2 = 0.5D0*(BB-AA)
52826 S8 = 0D0
52827 DO 120 I = 1, 4
52828 U = C2*X(I)
52829 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52830 120 CONTINUE
52831 S16 = 0D0
52832 DO 130 I = 5, 12
52833 U = C2*X(I)
52834 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52835 130 CONTINUE
52836 S16 = C2*S16
52837 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52838 H = H + S16
52839 IF(BB .NE. B) GOTO 100
52840 ELSE
52841 BB = C1
52842 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52843 H = 0D0
52844 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
52845 GOTO 140
52846 ENDIF
52847 140 CONTINUE
52848 PYGAU2 = H
52849
52850 RETURN
52851 END
52852
52853C*********************************************************************
52854
52855C...PYSIMP
52856C...Simpson formula for an integral.
52857
52858 FUNCTION PYSIMP(Y,X0,X1,N)
52859
52860C...Double precision and integer declarations.
52861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52862 IMPLICIT INTEGER(I-N)
52863 INTEGER PYK,PYCHGE,PYCOMP
52864
52865C...Local variables.
52866 DOUBLE PRECISION Y,X0,X1,H,S
52867 DIMENSION Y(0:N)
52868
52869 S=0D0
52870 H=(X1-X0)/N
52871 DO 100 I=0,N-2,2
52872 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
52873 100 CONTINUE
52874 PYSIMP=S*H/3D0
52875
52876 RETURN
52877 END
52878
52879C*********************************************************************
52880
52881C...PYLAMF
52882C...The standard lambda function.
52883
52884 FUNCTION PYLAMF(X,Y,Z)
52885
52886C...Double precision and integer declarations.
52887 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52888 IMPLICIT INTEGER(I-N)
52889 INTEGER PYK,PYCHGE,PYCOMP
52890
52891C...Local variables.
52892 DOUBLE PRECISION PYLAMF,X,Y,Z
52893
52894 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
52895 IF(PYLAMF.LT.0D0) PYLAMF=0D0
52896
52897 RETURN
52898 END
52899
52900C*********************************************************************
52901
52902C...PYTBDY
52903C...Generates 3-body decays of gauginos.
52904
52905 SUBROUTINE PYTBDY(IDIN)
52906
52907C...Double precision and integer declarations.
52908 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52909 IMPLICIT INTEGER(I-N)
52910 INTEGER PYK,PYCHGE,PYCOMP
52911C...Parameter statement to help give large particle numbers.
52912 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52913 &KEXCIT=4000000,KDIMEN=5000000)
52914C...Commonblocks.
52915 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52917 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52918C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52919C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52920 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52921 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52922C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
52923 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
52924
52925C...Local variables.
52926 DOUBLE PRECISION XM(5)
52927 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
52928 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
52929 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
52930 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
52931 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
52932 DOUBLE PRECISION CPHI1,SPHI1
52933 DOUBLE PRECISION S23DEL,EPS
52934 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
52935 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
52936 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
52937 INTEGER INOID(4)
52938 DATA INOID/22,23,25,35/
52939 DATA EPS/1D-6/
52940
52941 ID=IDIN
52942 ISKIP=1
52943 XM(1)=P(N+1,5)
52944 XM(2)=P(N+2,5)
52945 XM(3)=P(N+3,5)
52946 XM(5)=P(ID,5)
52947
52948C...GENERATE S12
52949 S12MIN=(XM(1)+XM(2))**2
52950 S12MAX=(XM(5)-XM(3))**2
52951 YJACO1=S12MAX-S12MIN
52952
52953C...Initialize some parameters
52954 XW=PARU(102)
52955 XW1=1D0-XW
52956 TANW=SQRT(XW/XW1)
52957 IZID1=0
52958 IWID1=0
52959 IZID2=0
52960 IWID2=0
52961
52962 IA=K(N+2,2)
52963 JA=K(N+3,2)
52964
52965C...Mrenna: check that we are indeed decaying a SUSY particle
52966 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
52967
52968 ELSE
52969 DO 100 I1=1,4
52970 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
52971 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
52972 100 CONTINUE
52973 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
52974 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
52975 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
52976 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
52977 ZM12=XM(5)**2
52978 ZM22=XM(1)**2
52979 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
52980 T3I=SIGN(1D0,EI+1D-6)/2D0
52981 ENDIF
52982
52983 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
52984 ISKIP=0
52985 ELSEIF(IZID1*IZID2.NE.0) THEN
52986 SQMZ=PMAS(23,1)**2
52987 GMMZ=PMAS(23,1)*PMAS(23,2)
52988 DO 110 I=1,4
52989 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
52990 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
52991 110 CONTINUE
52992 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
52993 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
52994 ORPP=DCONJG(OLPP)
52995 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
52996 XLR2=XLL2
52997 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
52998 XRL2=XRR2
52999 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53000 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53001 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53002 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53003 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53004 QLLU=-GLIJ
53005 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53006 QLRT=DCONJG(GLIJ)
53007 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53008 QRLT=GRIJ
53009 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53010 QRRU=-DCONJG(GRIJ)
53011 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53012 IF(IZID1.NE.0) THEN
53013 XM1M2=SMZ(IZID1)*SMW(IWID2)
53014 IZID1=IWID2
53015 IZID2=IZID1
53016 ELSE
53017 XM1M2=SMZ(IZID2)*SMW(IWID1)
53018 IZID1=IWID1
53019 ENDIF
53020 RT2I = 1D0/SQRT(2D0)
53021 SQMZ=PMAS(24,1)**2
53022 GMMZ=PMAS(24,1)*PMAS(24,2)
53023 DO 120 I=1,2
53024 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53025 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53026 120 CONTINUE
53027 DO 130 I=1,4
53028 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53029 130 CONTINUE
53030 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
53031 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
53032 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
53033 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
53034 EJ=KCHG(IABS(JA),1)/3D0
53035 T3J=SIGN(1D0,EJ+1D-6)/2D0
53036 QRLS=DCMPLX(0D0,0D0)
53037 QRLT=QRLS
53038 QRRS=QRLS
53039 QRRU=QRLS
53040 XRR2=1D6**2
53041 XRL2=XRR2
53042 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
53043 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53044 IF(MOD(IA,2).EQ.0) THEN
53045 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
53046 & TANW+ZMIXC(IZID2,2)*T3I)
53047 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53048 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
53049 ELSE
53050 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
53051 & TANW+ZMIXC(IZID2,2)*T3J)
53052 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53053 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
53054 ENDIF
53055 ELSEIF(IWID1*IWID2.NE.0) THEN
53056 IZID1=IWID1
53057 IZID2=IWID2
53058 XM1M2=SMW(IWID1)*SMW(IWID2)
53059 SQMZ=PMAS(23,1)**2
53060 GMMZ=PMAS(23,1)*PMAS(23,2)
53061 DO 140 I=1,2
53062 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53063 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53064 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
53065 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
53066 140 CONTINUE
53067 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
53068 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
53069 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
53070 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
53071 QRLS=-DCMPLX(EI/XW1)*ORPP
53072 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53073 QRRS=-DCMPLX(EI/XW1)*OLPP
53074 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53075 IF(MOD(IA,2).EQ.0) THEN
53076 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
53077 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
53078 ELSE
53079 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
53080 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
53081 ENDIF
53082 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
53083 &THEN
53084 ISKIP=0
53085 ELSE
53086 ISKIP=0
53087 ENDIF
53088
53089 IF(ISKIP.NE.0) THEN
53090 WTMAX=0D0
53091 DO 160 KT=1,100
53092 S12=S12MIN+YJACO1*(KT-1)/99
53093 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53094 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53095 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53096 & -(2D0*XM(1)*XM(2))**2
53097 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53098 & -(2D0*XM(3)*XM(5))**2
53099 S23DF1=S23DF1*EPS
53100 S23DF2=S23DF2*EPS
53101 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53102 S23DEL=S23DEL/EPS
53103 S23MIN=S23AVE-S23DEL
53104 S23MAX=S23AVE+S23DEL
53105 YJACO2=S23MAX-S23MIN
53106 TH=S12
53107 DO 150 KS=1,100
53108 S23=S23MIN+YJACO2*(KS-1)/99
53109 SH=S23
53110 UH=ZM12+ZM22-SH-TH
53111 WU2 = (UH-ZM12)*(UH-ZM22)
53112 WT2 = (TH-ZM12)*(TH-ZM22)
53113 WS2 = XM1M2*SH
53114 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53115 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53116 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53117 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53118 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53119 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53120 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53121 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
53122 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53123 IF(WT0.GT.WTMAX) WTMAX=WT0
53124 150 CONTINUE
53125 160 CONTINUE
53126
53127 WTMAX=WTMAX*1.05D0
53128 ENDIF
53129
53130C...FIND S12*
53131 AX=S12MIN
53132 CX=S12MAX
53133 BX=S12MIN+0.5D0*YJACO1
53134 X0=AX
53135 X3=CX
53136 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
53137 X1=BX
53138 X2=BX+C*(CX-BX)
53139 ELSE
53140 X2=BX
53141 X1=BX-C*(BX-AX)
53142 ENDIF
53143
53144C...SOLVE FOR F1 AND F2
53145 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53146 &-(2D0*XM(1)*XM(2))**2
53147 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53148 &-(2D0*XM(3)*XM(5))**2
53149 S23DF1=S23DF1*EPS
53150 S23DF2=S23DF2*EPS
53151 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53152 F1=-2D0*S23DEL/EPS
53153 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53154 &-(2D0*XM(1)*XM(2))**2
53155 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53156 &-(2D0*XM(3)*XM(5))**2
53157 S23DF1=S23DF1*EPS
53158 S23DF2=S23DF2*EPS
53159 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53160 F2=-2D0*S23DEL/EPS
53161
53162 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
53163C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
53164 IF(F2.LE.F1)THEN
53165 X0=X1
53166 X1=X2
53167 X2=R*X1+C*X3
53168 F1=F2
53169 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53170 & -(2D0*XM(1)*XM(2))**2
53171 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53172 & -(2D0*XM(3)*XM(5))**2
53173 S23DF1=S23DF1*EPS
53174 S23DF2=S23DF2*EPS
53175 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53176 F2=-2D0*S23DEL/EPS
53177 ELSE
53178 X3=X2
53179 X2=X1
53180 X1=R*X2+C*X0
53181 F2=F1
53182 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53183 & -(2D0*XM(1)*XM(2))**2
53184 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53185 & -(2D0*XM(3)*XM(5))**2
53186 S23DF1=S23DF1*EPS
53187 S23DF2=S23DF2*EPS
53188 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53189 F1=-2D0*S23DEL/EPS
53190 ENDIF
53191 GOTO 170
53192 ENDIF
53193C...WE WANT THE MAXIMUM, NOT THE MINIMUM
53194 IF(F1.LT.F2)THEN
53195 GOLDEN=-F1
53196 XMIN=X1
53197 ELSE
53198 GOLDEN=-F2
53199 XMIN=X2
53200 ENDIF
53201
53202 IKNT=0
53203 180 S12=S12MIN+PYR(0)*YJACO1
53204 IKNT=IKNT+1
53205C...GENERATE S23
53206 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53207 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53208 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53209 &-(2D0*XM(1)*XM(2))**2
53210 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53211 &-(2D0*XM(3)*XM(5))**2
53212 S23DF1=S23DF1*EPS
53213 S23DF2=S23DF2*EPS
53214 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53215 S23DEL=S23DEL/EPS
53216 S23MIN=S23AVE-S23DEL
53217 S23MAX=S23AVE+S23DEL
53218 YJACO2=S23MAX-S23MIN
53219 S23=S23MIN+PYR(0)*YJACO2
53220
53221C...CHECK THE SAMPLING
53222 IF(IKNT.GT.100) THEN
53223 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
53224 GOTO 190
53225 ENDIF
53226 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
53227
53228 IF(ISKIP.EQ.0) GOTO 190
53229
53230 SH=S23
53231 TH=S12
53232 UH=ZM12+ZM22-SH-TH
53233
53234 WU2 = (UH-ZM12)*(UH-ZM22)
53235 WT2 = (TH-ZM12)*(TH-ZM22)
53236 WS2 = XM1M2*SH
53237 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53238 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53239
53240 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53241 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53242 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53243 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53244c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
53245c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
53246c &/DCMPLX(TH-XML2)
53247c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
53248c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
53249c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
53250 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53251 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
53252 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53253
53254 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
53255 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
53256
53257 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
53258 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
53259 D2=XM(5)-D1-D3
53260 P1=SQRT(D1*D1-XM(1)**2)
53261 P2=SQRT(D2*D2-XM(2)**2)
53262 P3=SQRT(D3*D3-XM(3)**2)
53263 CTHE1=2D0*PYR(0)-1D0
53264 ANG1=2D0*PYR(0)*PARU(1)
53265 CPHI1=COS(ANG1)
53266 SPHI1=SIN(ANG1)
53267 ARG=1D0-CTHE1**2
53268 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53269 STHE1=SQRT(ARG)
53270 P(N+1,1)=P1*STHE1*CPHI1
53271 P(N+1,2)=P1*STHE1*SPHI1
53272 P(N+1,3)=P1*CTHE1
53273 P(N+1,4)=D1
53274
53275C...GET CPHI3
53276 ANG3=2D0*PYR(0)*PARU(1)
53277 CPHI3=COS(ANG3)
53278 SPHI3=SIN(ANG3)
53279 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
53280 ARG=1D0-CTHE3**2
53281 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53282 STHE3=SQRT(ARG)
53283 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
53284 &+P3*STHE3*SPHI3*SPHI1
53285 &+P3*CTHE3*STHE1*CPHI1
53286 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
53287 &-P3*STHE3*SPHI3*CPHI1
53288 &+P3*CTHE3*STHE1*SPHI1
53289 P(N+3,3)=P3*STHE3*CPHI3*STHE1
53290 &+P3*CTHE3*CTHE1
53291 P(N+3,4)=D3
53292
53293 DO 200 I=1,3
53294 P(N+2,I)=-P(N+1,I)-P(N+3,I)
53295 200 CONTINUE
53296 P(N+2,4)=D2
53297
53298 RETURN
53299 END
53300
53301
53302C*********************************************************************
53303
53304C...PYTECM
53305C...Finds the s-hat dependent eigenvalues of the inverse propagator
53306C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
53307C...phase space generation. Extended to include techni-a meson, and
53308C...to return the width.
53309
53310 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
53311
53312C...Double precision and integer declarations.
53313 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53314 IMPLICIT INTEGER(I-N)
53315 INTEGER PYK,PYCHGE,PYCOMP
53316C...Parameter statement to help give large particle numbers.
53317 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53318 &KEXCIT=4000000,KDIMEN=5000000)
53319C...Commonblocks.
53320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53321 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53322 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53323 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53324 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
53325
53326C...Local variables.
53327 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
53328 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
53329 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
53330 INTEGER i,j,ierr
53331
53332 SH=SMIN
53333 SHR=SQRT(SH)
53334 AEM=PYALEM(SH)
53335
53336 SINW=MIN(SQRT(PARU(102)),1D0)
53337 COSW=SQRT(1D0-SINW**2)
53338 TANW=SINW/COSW
53339 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
53340 QUPD=2D0*RTCM(2)-1D0
53341
53342 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
53343 FAR=SQRT(AEM/ALPRHT)
53344 FAO=FAR*QUPD
53345 FZR=FAR*CT2W
53346 FZO=-FAO*TANW
53347 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
53348 FWR=FAR/(2D0*SINW)
53349 FWX=-FWR/RTCM(47)
53350
53351 DO 110 I=1,5
53352 DO 100 J=1,5
53353 AT(I,J)=0D0
53354 100 CONTINUE
53355 110 CONTINUE
53356
53357C...NC
53358 IF(IOPT.EQ.1) THEN
53359 AR(1,1) = SH
53360 AR(2,2) = SH-PMAS(23,1)**2
53361 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
53362 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
53363 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
53364 AR(1,2) = 0D0
53365 AR(2,1) = 0D0
53366 AR(1,3) = SH*FAR
53367 AR(3,1) = AR(1,3)
53368 AR(1,4) = SH*FAO
53369 AR(4,1) = AR(1,4)
53370 AR(2,3) = SH*FZR
53371 AR(3,2) = AR(2,3)
53372 AR(2,4) = SH*FZO
53373 AR(4,2) = AR(2,4)
53374 AR(3,4) = 0D0
53375 AR(4,3) = 0D0
53376 AR(2,5) = SH*FZX
53377 AR(5,2) = AR(2,5)
53378 AR(1,5) = 0D0
53379 AR(5,1) = AR(1,5)
53380 AR(3,5) = 0D0
53381 AR(5,3) = AR(3,5)
53382 AR(4,5) = 0D0
53383 AR(5,4) = AR(4,5)
53384 CALL PYWIDT(23,SH,WDTP,WDTE)
53385 AT(2,2) = WDTP(0)*SHR
53386 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
53387 AT(3,3) = WDTP(0)*SHR
53388 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
53389 AT(4,4) = WDTP(0)*SHR
53390 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
53391 AT(5,5) = WDTP(0)*SHR
53392 IDIM=5
53393C...CC
53394 ELSE
53395 AR(1,1) = SH-PMAS(24,1)**2
53396 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
53397 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
53398 AR(1,2) = SH*FWR
53399 AR(2,1) = AR(1,2)
53400 AR(1,3) = SH*FWX
53401 AR(3,1) = AR(1,3)
53402 AR(2,3) = 0D0
53403 AR(3,2) = 0D0
53404 CALL PYWIDT(24,SH,WDTP,WDTE)
53405 AT(1,1) = WDTP(0)*SHR
53406 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
53407 AT(2,2) = WDTP(0)*SHR
53408 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
53409 AT(3,3) = WDTP(0)*SHR
53410 IDIM=3
53411 ENDIF
53412 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
53413
53414 IMIN=1
53415 SXMN=1D20
53416 DO 120 I=1,IDIM
53417 WX(I)=SQRT(ABS(SH-WR(I)))
53418 WR(I)=ABS(WR(I))
53419 IF(WR(I).LT.SXMN) THEN
53420 SXMN=WR(I)
53421 IMIN=I
53422 ENDIF
53423 120 CONTINUE
53424 SMOU=WX(IMIN)**2
53425 WIDO=WI(IMIN)/SHR
53426
53427 RETURN
53428 END
53429
53430C*********************************************************************
53431
53432C...PYEIGC
53433C...Finds eigenvalues of a general complex matrix
53434C
53435C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
53436C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
53437C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
53438C OF A COMPLEX GENERAL MATRIX.
53439C
53440C ON INPUT
53441C
53442C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
53443C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53444C DIMENSION STATEMENT.
53445C
53446C N IS THE ORDER OF THE MATRIX A=(AR,AI).
53447C
53448C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53449C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
53450C
53451C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
53452C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
53453C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
53454C
53455C ON OUTPUT
53456C
53457C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53458C RESPECTIVELY, OF THE EIGENVALUES.
53459C
53460C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53461C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
53462C
53463C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
53464C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
53465C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
53466C
53467C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
53468C
53469C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53470C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53471C
53472C THIS VERSION DATED AUGUST 1983.
53473C
53474
53475 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
53476
53477 INTEGER N,NM,IS1,IS2,IERR,MATZ
53478 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53479 X FV1(5),FV2(5),FV3(5)
53480 IF (N .LE. NM) GOTO 100
53481 IERR = 10 * N
53482 GOTO 120
53483C
53484 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
53485 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
53486 IF (MATZ .NE. 0) GOTO 110
53487C .......... FIND EIGENVALUES ONLY ..........
53488 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
53489 GOTO 120
53490C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
53491 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
53492 IF (IERR .NE. 0) GOTO 120
53493 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
53494 120 RETURN
53495 END
53496
53497C*********************************************************************
53498
53499C...PYCMQR
53500C...Auxiliary to PYEICG.
53501C
53502C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53503C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
53504C AND WILKINSON.
53505C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
53506C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53507C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53508C
53509C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
53510C UPPER HESSENBERG MATRIX BY THE QR METHOD.
53511C
53512C ON INPUT
53513C
53514C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53515C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53516C DIMENSION STATEMENT.
53517C
53518C N IS THE ORDER OF THE MATRIX.
53519C
53520C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53521C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53522C SET LOW=1, IGH=N.
53523C
53524C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53525C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53526C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
53527C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
53528C THE REDUCTION BY CORTH, IF PERFORMED.
53529C
53530C ON OUTPUT
53531C
53532C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
53533C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
53534C CALLING COMQR IF SUBSEQUENT CALCULATION OF
53535C EIGENVECTORS IS TO BE PERFORMED.
53536C
53537C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53538C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53539C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53540C FOR INDICES IERR+1,...,N.
53541C
53542C IERR IS SET TO
53543C ZERO FOR NORMAL RETURN,
53544C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53545C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53546C
53547C CALLS PYCDIV FOR COMPLEX DIVISION.
53548C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53549C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53550C
53551C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53552C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53553C
53554C THIS VERSION DATED AUGUST 1983.
53555C
53556
53557 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
53558
53559 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
53560 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
53561 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53562 X PYTHAG
53563
53564 IERR = 0
53565 IF (LOW .EQ. IGH) GOTO 130
53566C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53567 L = LOW + 1
53568C
53569 DO 120 I = L, IGH
53570 LL = MIN0(I+1,IGH)
53571 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
53572 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53573 YR = HR(I,I-1) / NORM
53574 YI = HI(I,I-1) / NORM
53575 HR(I,I-1) = NORM
53576 HI(I,I-1) = 0.0D0
53577C
53578 DO 100 J = I, IGH
53579 SI = YR * HI(I,J) - YI * HR(I,J)
53580 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53581 HI(I,J) = SI
53582 100 CONTINUE
53583C
53584 DO 110 J = LOW, LL
53585 SI = YR * HI(J,I) + YI * HR(J,I)
53586 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53587 HI(J,I) = SI
53588 110 CONTINUE
53589C
53590 120 CONTINUE
53591C .......... STORE ROOTS ISOLATED BY CBAL ..........
53592 130 DO 140 I = 1, N
53593 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53594 WR(I) = HR(I,I)
53595 WI(I) = HI(I,I)
53596 140 CONTINUE
53597C
53598 EN = IGH
53599 TR = 0.0D0
53600 TI = 0.0D0
53601 ITN = 30*N
53602C .......... SEARCH FOR NEXT EIGENVALUE ..........
53603 150 IF (EN .LT. LOW) GOTO 320
53604 ITS = 0
53605 ENM1 = EN - 1
53606C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53607C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
53608 160 DO 170 LL = LOW, EN
53609 L = EN + LOW - LL
53610 IF (L .EQ. LOW) GOTO 180
53611 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53612 X + DABS(HR(L,L)) + DABS(HI(L,L))
53613 TST2 = TST1 + DABS(HR(L,L-1))
53614 IF (TST2 .EQ. TST1) GOTO 180
53615 170 CONTINUE
53616C .......... FORM SHIFT ..........
53617 180 IF (L .EQ. EN) GOTO 300
53618 IF (ITN .EQ. 0) GOTO 310
53619 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
53620 SR = HR(EN,EN)
53621 SI = HI(EN,EN)
53622 XR = HR(ENM1,EN) * HR(EN,ENM1)
53623 XI = HI(ENM1,EN) * HR(EN,ENM1)
53624 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
53625 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53626 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53627 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53628 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
53629 ZZR = -ZZR
53630 ZZI = -ZZI
53631 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53632 SR = SR - XR
53633 SI = SI - XI
53634 GOTO 210
53635C .......... FORM EXCEPTIONAL SHIFT ..........
53636 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53637 SI = 0.0D0
53638C
53639 210 DO 220 I = LOW, EN
53640 HR(I,I) = HR(I,I) - SR
53641 HI(I,I) = HI(I,I) - SI
53642 220 CONTINUE
53643C
53644 TR = TR + SR
53645 TI = TI + SI
53646 ITS = ITS + 1
53647 ITN = ITN - 1
53648C .......... REDUCE TO TRIANGLE (ROWS) ..........
53649 LP1 = L + 1
53650C
53651 DO 240 I = LP1, EN
53652 SR = HR(I,I-1)
53653 HR(I,I-1) = 0.0D0
53654 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53655 XR = HR(I-1,I-1) / NORM
53656 WR(I-1) = XR
53657 XI = HI(I-1,I-1) / NORM
53658 WI(I-1) = XI
53659 HR(I-1,I-1) = NORM
53660 HI(I-1,I-1) = 0.0D0
53661 HI(I,I-1) = SR / NORM
53662C
53663 DO 230 J = I, EN
53664 YR = HR(I-1,J)
53665 YI = HI(I-1,J)
53666 ZZR = HR(I,J)
53667 ZZI = HI(I,J)
53668 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53669 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53670 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53671 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53672 230 CONTINUE
53673C
53674 240 CONTINUE
53675C
53676 SI = HI(EN,EN)
53677 IF (SI .EQ. 0.0D0) GOTO 250
53678 NORM = PYTHAG(HR(EN,EN),SI)
53679 SR = HR(EN,EN) / NORM
53680 SI = SI / NORM
53681 HR(EN,EN) = NORM
53682 HI(EN,EN) = 0.0D0
53683C .......... INVERSE OPERATION (COLUMNS) ..........
53684 250 DO 280 J = LP1, EN
53685 XR = WR(J-1)
53686 XI = WI(J-1)
53687C
53688 DO 270 I = L, J
53689 YR = HR(I,J-1)
53690 YI = 0.0D0
53691 ZZR = HR(I,J)
53692 ZZI = HI(I,J)
53693 IF (I .EQ. J) GOTO 260
53694 YI = HI(I,J-1)
53695 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
53696 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
53697 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
53698 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
53699 270 CONTINUE
53700C
53701 280 CONTINUE
53702C
53703 IF (SI .EQ. 0.0D0) GOTO 160
53704C
53705 DO 290 I = L, EN
53706 YR = HR(I,EN)
53707 YI = HI(I,EN)
53708 HR(I,EN) = SR * YR - SI * YI
53709 HI(I,EN) = SR * YI + SI * YR
53710 290 CONTINUE
53711C
53712 GOTO 160
53713C .......... A ROOT FOUND ..........
53714 300 WR(EN) = HR(EN,EN) + TR
53715 WI(EN) = HI(EN,EN) + TI
53716 EN = ENM1
53717 GOTO 150
53718C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
53719C CONVERGED AFTER 30*N ITERATIONS ..........
53720 310 IERR = EN
53721 320 RETURN
53722 END
53723
53724C*********************************************************************
53725
53726C...PYCMQ2
53727C...Auxiliary to PYEICG.
53728C
53729C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53730C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
53731C AND WILKINSON.
53732C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
53733C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53734C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53735C
53736C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
53737C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
53738C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
53739C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
53740C THIS GENERAL MATRIX TO HESSENBERG FORM.
53741C
53742C ON INPUT
53743C
53744C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53745C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53746C DIMENSION STATEMENT.
53747C
53748C N IS THE ORDER OF THE MATRIX.
53749C
53750C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53751C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53752C SET LOW=1, IGH=N.
53753C
53754C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
53755C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
53756C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
53757C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
53758C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
53759C
53760C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53761C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53762C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
53763C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
53764C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
53765C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
53766C ARBITRARY.
53767C
53768C ON OUTPUT
53769C
53770C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
53771C HAVE BEEN DESTROYED.
53772C
53773C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53774C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53775C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53776C FOR INDICES IERR+1,...,N.
53777C
53778C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53779C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
53780C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
53781C THE EIGENVECTORS HAS BEEN FOUND.
53782C
53783C IERR IS SET TO
53784C ZERO FOR NORMAL RETURN,
53785C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53786C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53787C
53788C CALLS PYCDIV FOR COMPLEX DIVISION.
53789C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53790C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53791C
53792C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53793C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53794C
53795C THIS VERSION DATED OCTOBER 1989.
53796C
53797C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
53798C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
53799C
53800
53801 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
53802
53803 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
53804 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
53805 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53806 X ORTR(5),ORTI(5)
53807 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53808 X PYTHAG
53809
53810 IERR = 0
53811C .......... INITIALIZE EIGENVECTOR MATRIX ..........
53812 DO 110 J = 1, N
53813C
53814 DO 100 I = 1, N
53815 ZR(I,J) = 0.0D0
53816 ZI(I,J) = 0.0D0
53817 100 CONTINUE
53818 ZR(J,J) = 1.0D0
53819 110 CONTINUE
53820C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
53821C FROM THE INFORMATION LEFT BY CORTH ..........
53822 IEND = IGH - LOW - 1
53823 IF (IEND.LT.0) GOTO 220
53824 IF (IEND.EQ.0) GOTO 170
53825C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
53826 DO 160 II = 1, IEND
53827 I = IGH - II
53828 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
53829 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
53830C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
53831 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
53832 IP1 = I + 1
53833C
53834 DO 120 K = IP1, IGH
53835 ORTR(K) = HR(K,I-1)
53836 ORTI(K) = HI(K,I-1)
53837 120 CONTINUE
53838C
53839 DO 150 J = I, IGH
53840 SR = 0.0D0
53841 SI = 0.0D0
53842C
53843 DO 130 K = I, IGH
53844 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
53845 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
53846 130 CONTINUE
53847C
53848 SR = SR / NORM
53849 SI = SI / NORM
53850C
53851 DO 140 K = I, IGH
53852 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
53853 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
53854 140 CONTINUE
53855C
53856 150 CONTINUE
53857C
53858 160 CONTINUE
53859C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53860 170 L = LOW + 1
53861C
53862 DO 210 I = L, IGH
53863 LL = MIN0(I+1,IGH)
53864 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
53865 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53866 YR = HR(I,I-1) / NORM
53867 YI = HI(I,I-1) / NORM
53868 HR(I,I-1) = NORM
53869 HI(I,I-1) = 0.0D0
53870C
53871 DO 180 J = I, N
53872 SI = YR * HI(I,J) - YI * HR(I,J)
53873 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53874 HI(I,J) = SI
53875 180 CONTINUE
53876C
53877 DO 190 J = 1, LL
53878 SI = YR * HI(J,I) + YI * HR(J,I)
53879 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53880 HI(J,I) = SI
53881 190 CONTINUE
53882C
53883 DO 200 J = LOW, IGH
53884 SI = YR * ZI(J,I) + YI * ZR(J,I)
53885 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
53886 ZI(J,I) = SI
53887 200 CONTINUE
53888C
53889 210 CONTINUE
53890C .......... STORE ROOTS ISOLATED BY CBAL ..........
53891 220 DO 230 I = 1, N
53892 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
53893 WR(I) = HR(I,I)
53894 WI(I) = HI(I,I)
53895 230 CONTINUE
53896C
53897 EN = IGH
53898 TR = 0.0D0
53899 TI = 0.0D0
53900 ITN = 30*N
53901C .......... SEARCH FOR NEXT EIGENVALUE ..........
53902 240 IF (EN .LT. LOW) GOTO 430
53903 ITS = 0
53904 ENM1 = EN - 1
53905C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53906C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
53907 250 DO 260 LL = LOW, EN
53908 L = EN + LOW - LL
53909 IF (L .EQ. LOW) GOTO 270
53910 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53911 X + DABS(HR(L,L)) + DABS(HI(L,L))
53912 TST2 = TST1 + DABS(HR(L,L-1))
53913 IF (TST2 .EQ. TST1) GOTO 270
53914 260 CONTINUE
53915C .......... FORM SHIFT ..........
53916 270 IF (L .EQ. EN) GOTO 420
53917 IF (ITN .EQ. 0) GOTO 550
53918 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
53919 SR = HR(EN,EN)
53920 SI = HI(EN,EN)
53921 XR = HR(ENM1,EN) * HR(EN,ENM1)
53922 XI = HI(ENM1,EN) * HR(EN,ENM1)
53923 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
53924 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53925 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53926 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53927 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
53928 ZZR = -ZZR
53929 ZZI = -ZZI
53930 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53931 SR = SR - XR
53932 SI = SI - XI
53933 GOTO 300
53934C .......... FORM EXCEPTIONAL SHIFT ..........
53935 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53936 SI = 0.0D0
53937C
53938 300 DO 310 I = LOW, EN
53939 HR(I,I) = HR(I,I) - SR
53940 HI(I,I) = HI(I,I) - SI
53941 310 CONTINUE
53942C
53943 TR = TR + SR
53944 TI = TI + SI
53945 ITS = ITS + 1
53946 ITN = ITN - 1
53947C .......... REDUCE TO TRIANGLE (ROWS) ..........
53948 LP1 = L + 1
53949C
53950 DO 330 I = LP1, EN
53951 SR = HR(I,I-1)
53952 HR(I,I-1) = 0.0D0
53953 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53954 XR = HR(I-1,I-1) / NORM
53955 WR(I-1) = XR
53956 XI = HI(I-1,I-1) / NORM
53957 WI(I-1) = XI
53958 HR(I-1,I-1) = NORM
53959 HI(I-1,I-1) = 0.0D0
53960 HI(I,I-1) = SR / NORM
53961C
53962 DO 320 J = I, N
53963 YR = HR(I-1,J)
53964 YI = HI(I-1,J)
53965 ZZR = HR(I,J)
53966 ZZI = HI(I,J)
53967 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53968 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53969 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53970 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53971 320 CONTINUE
53972C
53973 330 CONTINUE
53974C
53975 SI = HI(EN,EN)
53976 IF (SI .EQ. 0.0D0) GOTO 350
53977 NORM = PYTHAG(HR(EN,EN),SI)
53978 SR = HR(EN,EN) / NORM
53979 SI = SI / NORM
53980 HR(EN,EN) = NORM
53981 HI(EN,EN) = 0.0D0
53982 IF (EN .EQ. N) GOTO 350
53983 IP1 = EN + 1
53984C
53985 DO 340 J = IP1, N
53986 YR = HR(EN,J)
53987 YI = HI(EN,J)
53988 HR(EN,J) = SR * YR + SI * YI
53989 HI(EN,J) = SR * YI - SI * YR
53990 340 CONTINUE
53991C .......... INVERSE OPERATION (COLUMNS) ..........
53992 350 DO 390 J = LP1, EN
53993 XR = WR(J-1)
53994 XI = WI(J-1)
53995C
53996 DO 370 I = 1, J
53997 YR = HR(I,J-1)
53998 YI = 0.0D0
53999 ZZR = HR(I,J)
54000 ZZI = HI(I,J)
54001 IF (I .EQ. J) GOTO 360
54002 YI = HI(I,J-1)
54003 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54004 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54005 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54006 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54007 370 CONTINUE
54008C
54009 DO 380 I = LOW, IGH
54010 YR = ZR(I,J-1)
54011 YI = ZI(I,J-1)
54012 ZZR = ZR(I,J)
54013 ZZI = ZI(I,J)
54014 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54015 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54016 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54017 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54018 380 CONTINUE
54019C
54020 390 CONTINUE
54021C
54022 IF (SI .EQ. 0.0D0) GOTO 250
54023C
54024 DO 400 I = 1, EN
54025 YR = HR(I,EN)
54026 YI = HI(I,EN)
54027 HR(I,EN) = SR * YR - SI * YI
54028 HI(I,EN) = SR * YI + SI * YR
54029 400 CONTINUE
54030C
54031 DO 410 I = LOW, IGH
54032 YR = ZR(I,EN)
54033 YI = ZI(I,EN)
54034 ZR(I,EN) = SR * YR - SI * YI
54035 ZI(I,EN) = SR * YI + SI * YR
54036 410 CONTINUE
54037C
54038 GOTO 250
54039C .......... A ROOT FOUND ..........
54040 420 HR(EN,EN) = HR(EN,EN) + TR
54041 WR(EN) = HR(EN,EN)
54042 HI(EN,EN) = HI(EN,EN) + TI
54043 WI(EN) = HI(EN,EN)
54044 EN = ENM1
54045 GOTO 240
54046C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
54047C VECTORS OF UPPER TRIANGULAR FORM ..........
54048 430 NORM = 0.0D0
54049C
54050 DO 440 I = 1, N
54051C
54052 DO 440 J = I, N
54053 TR = DABS(HR(I,J)) + DABS(HI(I,J))
54054 IF (TR .GT. NORM) NORM = TR
54055 440 CONTINUE
54056C
54057 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
54058C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
54059 DO 500 NN = 2, N
54060 EN = N + 2 - NN
54061 XR = WR(EN)
54062 XI = WI(EN)
54063 HR(EN,EN) = 1.0D0
54064 HI(EN,EN) = 0.0D0
54065 ENM1 = EN - 1
54066C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
54067 DO 490 II = 1, ENM1
54068 I = EN - II
54069 ZZR = 0.0D0
54070 ZZI = 0.0D0
54071 IP1 = I + 1
54072C
54073 DO 450 J = IP1, EN
54074 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
54075 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
54076 450 CONTINUE
54077C
54078 YR = XR - WR(I)
54079 YI = XI - WI(I)
54080 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
54081 TST1 = NORM
54082 YR = TST1
54083 460 YR = 0.01D0 * YR
54084 TST2 = NORM + YR
54085 IF (TST2 .GT. TST1) GOTO 460
54086 470 CONTINUE
54087 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
54088C .......... OVERFLOW CONTROL ..........
54089 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
54090 IF (TR .EQ. 0.0D0) GOTO 490
54091 TST1 = TR
54092 TST2 = TST1 + 1.0D0/TST1
54093 IF (TST2 .GT. TST1) GOTO 490
54094 DO 480 J = I, EN
54095 HR(J,EN) = HR(J,EN)/TR
54096 HI(J,EN) = HI(J,EN)/TR
54097 480 CONTINUE
54098C
54099 490 CONTINUE
54100C
54101 500 CONTINUE
54102C .......... END BACKSUBSTITUTION ..........
54103C .......... VECTORS OF ISOLATED ROOTS ..........
54104 DO 520 I = 1, N
54105 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
54106C
54107 DO 510 J = I, N
54108 ZR(I,J) = HR(I,J)
54109 ZI(I,J) = HI(I,J)
54110 510 CONTINUE
54111C
54112 520 CONTINUE
54113C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
54114C VECTORS OF ORIGINAL FULL MATRIX.
54115C FOR J=N STEP -1 UNTIL LOW DO -- ..........
54116 DO 540 JJ = LOW, N
54117 J = N + LOW - JJ
54118 M = MIN0(J,IGH)
54119C
54120 DO 540 I = LOW, IGH
54121 ZZR = 0.0D0
54122 ZZI = 0.0D0
54123C
54124 DO 530 K = LOW, M
54125 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
54126 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
54127 530 CONTINUE
54128C
54129 ZR(I,J) = ZZR
54130 ZI(I,J) = ZZI
54131 540 CONTINUE
54132C
54133 GOTO 560
54134C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
54135C CONVERGED AFTER 30*N ITERATIONS ..........
54136 550 IERR = EN
54137 560 RETURN
54138 END
54139
54140C*********************************************************************
54141
54142C...PYCDIV
54143C...Auxiliary to PYCMQR
54144C
54145C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
54146C
54147
54148 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
54149
54150 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
54151 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
54152
54153 S = DABS(BR) + DABS(BI)
54154 ARS = AR/S
54155 AIS = AI/S
54156 BRS = BR/S
54157 BIS = BI/S
54158 S = BRS**2 + BIS**2
54159 CR = (ARS*BRS + AIS*BIS)/S
54160 CI = (AIS*BRS - ARS*BIS)/S
54161 RETURN
54162 END
54163
54164C*********************************************************************
54165
54166C...PYCSRT
54167C...Auxiliary to PYCMQR
54168C
54169C (YR,YI) = COMPLEX DSQRT(XR,XI)
54170C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
54171C
54172
54173 SUBROUTINE PYCSRT(XR,XI,YR,YI)
54174
54175 DOUBLE PRECISION XR,XI,YR,YI
54176 DOUBLE PRECISION S,TR,TI,PYTHAG
54177
54178 TR = XR
54179 TI = XI
54180 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
54181 IF (TR .GE. 0.0D0) YR = S
54182 IF (TI .LT. 0.0D0) S = -S
54183 IF (TR .LE. 0.0D0) YI = S
54184 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
54185 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
54186 RETURN
54187 END
54188
54189 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
54190 DOUBLE PRECISION A,B
54191C
54192C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
54193C
54194 DOUBLE PRECISION P,R,S,T,U
54195 P = DMAX1(DABS(A),DABS(B))
54196 IF (P .EQ. 0.0D0) GOTO 110
54197 R = (DMIN1(DABS(A),DABS(B))/P)**2
54198 100 CONTINUE
54199 T = 4.0D0 + R
54200 IF (T .EQ. 4.0D0) GOTO 110
54201 S = R/T
54202 U = 1.0D0 + 2.0D0*S
54203 P = U*P
54204 R = (S/U)**2 * R
54205 GOTO 100
54206 110 PYTHAG = P
54207 RETURN
54208 END
54209
54210C*********************************************************************
54211
54212C...PYCBAL
54213C...Auxiliary to PYEICG
54214C
54215C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54216C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
54217C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54218C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54219C
54220C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
54221C EIGENVALUES WHENEVER POSSIBLE.
54222C
54223C ON INPUT
54224C
54225C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54226C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54227C DIMENSION STATEMENT.
54228C
54229C N IS THE ORDER OF THE MATRIX.
54230C
54231C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54232C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
54233C
54234C ON OUTPUT
54235C
54236C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54237C RESPECTIVELY, OF THE BALANCED MATRIX.
54238C
54239C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
54240C ARE EQUAL TO ZERO IF
54241C (1) I IS GREATER THAN J AND
54242C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
54243C
54244C SCALE CONTAINS INFORMATION DETERMINING THE
54245C PERMUTATIONS AND SCALING FACTORS USED.
54246C
54247C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
54248C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
54249C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
54250C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
54251C SCALE(J) = P(J), FOR J = 1,...,LOW-1
54252C = D(J,J) J = LOW,...,IGH
54253C = P(J) J = IGH+1,...,N.
54254C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
54255C THEN 1 TO LOW-1.
54256C
54257C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
54258C
54259C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
54260C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
54261C K,L HAVE BEEN REVERSED.)
54262C
54263C ARITHMETIC IS REAL THROUGHOUT.
54264C
54265C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54266C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54267C
54268C THIS VERSION DATED AUGUST 1983.
54269C
54270
54271 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
54272
54273 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
54274 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
54275 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
54276 LOGICAL NOCONV
54277
54278 RADIX = 16.0D0
54279C
54280 B2 = RADIX * RADIX
54281 K = 1
54282 L = N
54283 GOTO 150
54284C .......... IN-LINE PROCEDURE FOR ROW AND
54285C COLUMN EXCHANGE ..........
54286 100 SCALE(M) = J
54287 IF (J .EQ. M) GOTO 130
54288C
54289 DO 110 I = 1, L
54290 F = AR(I,J)
54291 AR(I,J) = AR(I,M)
54292 AR(I,M) = F
54293 F = AI(I,J)
54294 AI(I,J) = AI(I,M)
54295 AI(I,M) = F
54296 110 CONTINUE
54297C
54298 DO 120 I = K, N
54299 F = AR(J,I)
54300 AR(J,I) = AR(M,I)
54301 AR(M,I) = F
54302 F = AI(J,I)
54303 AI(J,I) = AI(M,I)
54304 AI(M,I) = F
54305 120 CONTINUE
54306C
54307 130 IF(IEXC.EQ.1) GOTO 140
54308 IF(IEXC.EQ.2) GOTO 180
54309C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
54310C AND PUSH THEM DOWN ..........
54311 140 IF (L .EQ. 1) GOTO 320
54312 L = L - 1
54313C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
54314 150 DO 170 JJ = 1, L
54315 J = L + 1 - JJ
54316C
54317 DO 160 I = 1, L
54318 IF (I .EQ. J) GOTO 160
54319 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
54320 160 CONTINUE
54321C
54322 M = L
54323 IEXC = 1
54324 GOTO 100
54325 170 CONTINUE
54326C
54327 GOTO 190
54328C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
54329C AND PUSH THEM LEFT ..........
54330 180 K = K + 1
54331C
54332 190 DO 210 J = K, L
54333C
54334 DO 200 I = K, L
54335 IF (I .EQ. J) GOTO 200
54336 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
54337 200 CONTINUE
54338C
54339 M = K
54340 IEXC = 2
54341 GOTO 100
54342 210 CONTINUE
54343C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
54344 DO 220 I = K, L
54345 220 SCALE(I) = 1.0D0
54346C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
54347 230 NOCONV = .FALSE.
54348C
54349 DO 310 I = K, L
54350 C = 0.0D0
54351 R = 0.0D0
54352C
54353 DO 240 J = K, L
54354 IF (J .EQ. I) GOTO 240
54355 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
54356 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
54357 240 CONTINUE
54358C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
54359 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
54360 G = R / RADIX
54361 F = 1.0D0
54362 S = C + R
54363 250 IF (C .GE. G) GOTO 260
54364 F = F * RADIX
54365 C = C * B2
54366 GOTO 250
54367 260 G = R * RADIX
54368 270 IF (C .LT. G) GOTO 280
54369 F = F / RADIX
54370 C = C / B2
54371 GOTO 270
54372C .......... NOW BALANCE ..........
54373 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
54374 G = 1.0D0 / F
54375 SCALE(I) = SCALE(I) * F
54376 NOCONV = .TRUE.
54377C
54378 DO 290 J = K, N
54379 AR(I,J) = AR(I,J) * G
54380 AI(I,J) = AI(I,J) * G
54381 290 CONTINUE
54382C
54383 DO 300 J = 1, L
54384 AR(J,I) = AR(J,I) * F
54385 AI(J,I) = AI(J,I) * F
54386 300 CONTINUE
54387C
54388 310 CONTINUE
54389C
54390 IF (NOCONV) GOTO 230
54391C
54392 320 LOW = K
54393 IGH = L
54394 RETURN
54395 END
54396
54397C*********************************************************************
54398
54399C...PYCBA2
54400C...Auxiliary to PYEICG.
54401C
54402C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54403C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
54404C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54405C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54406C
54407C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
54408C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
54409C BALANCED MATRIX DETERMINED BY CBAL.
54410C
54411C ON INPUT
54412C
54413C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54414C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54415C DIMENSION STATEMENT.
54416C
54417C N IS THE ORDER OF THE MATRIX.
54418C
54419C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
54420C
54421C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
54422C AND SCALING FACTORS USED BY CBAL.
54423C
54424C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
54425C
54426C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54427C RESPECTIVELY, OF THE EIGENVECTORS TO BE
54428C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
54429C
54430C ON OUTPUT
54431C
54432C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54433C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
54434C IN THEIR FIRST M COLUMNS.
54435C
54436C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54437C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54438C
54439C THIS VERSION DATED AUGUST 1983.
54440C
54441
54442 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
54443
54444 INTEGER I,J,K,M,N,II,NM,IGH,LOW
54445 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
54446 DOUBLE PRECISION S
54447
54448 IF (M .EQ. 0) GOTO 150
54449 IF (IGH .EQ. LOW) GOTO 120
54450C
54451 DO 110 I = LOW, IGH
54452 S = SCALE(I)
54453C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
54454C IF THE FOREGOING STATEMENT IS REPLACED BY
54455C S=1.0D0/SCALE(I). ..........
54456 DO 100 J = 1, M
54457 ZR(I,J) = ZR(I,J) * S
54458 ZI(I,J) = ZI(I,J) * S
54459 100 CONTINUE
54460C
54461 110 CONTINUE
54462C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
54463C IGH+1 STEP 1 UNTIL N DO -- ..........
54464 120 DO 140 II = 1, N
54465 I = II
54466 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
54467 IF (I .LT. LOW) I = LOW - II
54468 K = SCALE(I)
54469 IF (K .EQ. I) GOTO 140
54470C
54471 DO 130 J = 1, M
54472 S = ZR(I,J)
54473 ZR(I,J) = ZR(K,J)
54474 ZR(K,J) = S
54475 S = ZI(I,J)
54476 ZI(I,J) = ZI(K,J)
54477 ZI(K,J) = S
54478 130 CONTINUE
54479C
54480 140 CONTINUE
54481C
54482 150 RETURN
54483 END
54484
54485C*********************************************************************
54486
54487C...PYCRTH
54488C...Auxiliary to PYEICG.
54489C
54490C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
54491C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
54492C BY MARTIN AND WILKINSON.
54493C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
54494C
54495C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
54496C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
54497C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
54498C UNITARY SIMILARITY TRANSFORMATIONS.
54499C
54500C ON INPUT
54501C
54502C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54503C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54504C DIMENSION STATEMENT.
54505C
54506C N IS THE ORDER OF THE MATRIX.
54507C
54508C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
54509C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
54510C SET LOW=1, IGH=N.
54511C
54512C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54513C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
54514C
54515C ON OUTPUT
54516C
54517C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54518C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
54519C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
54520C IS STORED IN THE REMAINING TRIANGLES UNDER THE
54521C HESSENBERG MATRIX.
54522C
54523C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
54524C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
54525C
54526C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
54527C
54528C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54529C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54530C
54531C THIS VERSION DATED AUGUST 1983.
54532C
54533
54534 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
54535
54536 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
54537 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
54538 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
54539
54540 LA = IGH - 1
54541 KP1 = LOW + 1
54542 IF (LA .LT. KP1) GOTO 210
54543C
54544 DO 200 M = KP1, LA
54545 H = 0.0D0
54546 ORTR(M) = 0.0D0
54547 ORTI(M) = 0.0D0
54548 SCALE = 0.0D0
54549C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
54550 DO 100 I = M, IGH
54551 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
54552C
54553 IF (SCALE .EQ. 0.0D0) GOTO 200
54554 MP = M + IGH
54555C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54556 DO 110 II = M, IGH
54557 I = MP - II
54558 ORTR(I) = AR(I,M-1) / SCALE
54559 ORTI(I) = AI(I,M-1) / SCALE
54560 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
54561 110 CONTINUE
54562C
54563 G = DSQRT(H)
54564 F = PYTHAG(ORTR(M),ORTI(M))
54565 IF (F .EQ. 0.0D0) GOTO 120
54566 H = H + F * G
54567 G = G / F
54568 ORTR(M) = (1.0D0 + G) * ORTR(M)
54569 ORTI(M) = (1.0D0 + G) * ORTI(M)
54570 GOTO 130
54571C
54572 120 ORTR(M) = G
54573 AR(M,M-1) = SCALE
54574C .......... FORM (I-(U*UT)/H) * A ..........
54575 130 DO 160 J = M, N
54576 FR = 0.0D0
54577 FI = 0.0D0
54578C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54579 DO 140 II = M, IGH
54580 I = MP - II
54581 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
54582 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
54583 140 CONTINUE
54584C
54585 FR = FR / H
54586 FI = FI / H
54587C
54588 DO 150 I = M, IGH
54589 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
54590 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
54591 150 CONTINUE
54592C
54593 160 CONTINUE
54594C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
54595 DO 190 I = 1, IGH
54596 FR = 0.0D0
54597 FI = 0.0D0
54598C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
54599 DO 170 JJ = M, IGH
54600 J = MP - JJ
54601 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
54602 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
54603 170 CONTINUE
54604C
54605 FR = FR / H
54606 FI = FI / H
54607C
54608 DO 180 J = M, IGH
54609 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
54610 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
54611 180 CONTINUE
54612C
54613 190 CONTINUE
54614C
54615 ORTR(M) = SCALE * ORTR(M)
54616 ORTI(M) = SCALE * ORTI(M)
54617 AR(M,M-1) = -G * AR(M,M-1)
54618 AI(M,M-1) = -G * AI(M,M-1)
54619 200 CONTINUE
54620C
54621 210 RETURN
54622 END
54623
54624C*********************************************************************
54625
54626C...PYLDCM
54627C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54628C...processes.
54629
54630 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
54631 IMPLICIT NONE
54632 INTEGER N,NP,INDX(N)
54633 REAL*8 D,TINY
54634 COMPLEX*16 A(NP,NP)
54635 PARAMETER (TINY=1.0D-20)
54636 INTEGER I,IMAX,J,K
54637 REAL*8 AAMAX,VV(6),DUM
54638 COMPLEX*16 SUM,DUMC
54639
54640 D=1D0
54641 DO 110 I=1,N
54642 AAMAX=0D0
54643 DO 100 J=1,N
54644 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
54645 100 CONTINUE
54646 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
54647 VV(I)=1D0/AAMAX
54648 110 CONTINUE
54649 DO 180 J=1,N
54650 DO 130 I=1,J-1
54651 SUM=A(I,J)
54652 DO 120 K=1,I-1
54653 SUM=SUM-A(I,K)*A(K,J)
54654 120 CONTINUE
54655 A(I,J)=SUM
54656 130 CONTINUE
54657 AAMAX=0D0
54658 DO 150 I=J,N
54659 SUM=A(I,J)
54660 DO 140 K=1,J-1
54661 SUM=SUM-A(I,K)*A(K,J)
54662 140 CONTINUE
54663 A(I,J)=SUM
54664 DUM=VV(I)*ABS(SUM)
54665 IF (DUM.GE.AAMAX) THEN
54666 IMAX=I
54667 AAMAX=DUM
54668 ENDIF
54669 150 CONTINUE
54670 IF (J.NE.IMAX)THEN
54671 DO 160 K=1,N
54672 DUMC=A(IMAX,K)
54673 A(IMAX,K)=A(J,K)
54674 A(J,K)=DUMC
54675 160 CONTINUE
54676 D=-D
54677 VV(IMAX)=VV(J)
54678 ENDIF
54679 INDX(J)=IMAX
54680 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
54681 IF(J.NE.N)THEN
54682 DO 170 I=J+1,N
54683 A(I,J)=A(I,J)/A(J,J)
54684 170 CONTINUE
54685 ENDIF
54686 180 CONTINUE
54687
54688 RETURN
54689 END
54690
54691C*********************************************************************
54692
54693C...PYBKSB
54694C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54695C...processes.
54696
54697 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
54698 IMPLICIT NONE
54699 INTEGER N,NP,INDX(N)
54700 COMPLEX*16 A(NP,NP),B(N)
54701 INTEGER I,II,J,LL
54702 COMPLEX*16 SUM
54703
54704 II=0
54705 DO 110 I=1,N
54706 LL=INDX(I)
54707 SUM=B(LL)
54708 B(LL)=B(I)
54709 IF (II.NE.0)THEN
54710 DO 100 J=II,I-1
54711 SUM=SUM-A(I,J)*B(J)
54712 100 CONTINUE
54713 ELSE IF (ABS(SUM).NE.0D0) THEN
54714 II=I
54715 ENDIF
54716 B(I)=SUM
54717 110 CONTINUE
54718 DO 130 I=N,1,-1
54719 SUM=B(I)
54720 DO 120 J=I+1,N
54721 SUM=SUM-A(I,J)*B(J)
54722 120 CONTINUE
54723 B(I)=SUM/A(I,I)
54724 130 CONTINUE
54725 RETURN
54726 END
54727
54728C***********************************************************************
54729
54730C...PYWIDX
54731C...Calculates full and partial widths of resonances.
54732C....copy of PYWIDT, used for techniparticle widths
54733
54734 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
54735
54736C...Double precision and integer declarations.
54737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54738 IMPLICIT INTEGER(I-N)
54739 INTEGER PYK,PYCHGE,PYCOMP
54740C...Parameter statement to help give large particle numbers.
54741 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54742 &KEXCIT=4000000,KDIMEN=5000000)
54743C...Commonblocks.
54744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54745 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54746 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54747 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54748 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54749 COMMON/PYINT1/MINT(400),VINT(400)
54750 COMMON/PYINT4/MWID(500),WIDS(500,5)
54751 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54752 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54753 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
54754 &/PYINT4/,/PYMSSM/,/PYTCSM/
54755C...Local arrays and saved variables.
54756 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
54757 &WID2SV(3,2)
54758 SAVE MOFSV,WIDWSV,WID2SV
54759 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
54760
54761C...Compressed code and sign; mass.
54762 KFLA=IABS(KFLR)
54763 KFLS=ISIGN(1,KFLR)
54764 KC=PYCOMP(KFLA)
54765 SHR=SQRT(SH)
54766 PMR=PMAS(KC,1)
54767
54768C...Reset width information.
54769 DO I=0,400
54770 WDTP(I)=0D0
54771 ENDDO
54772
54773C...Common electroweak and strong constants.
54774 XW=PARU(102)
54775 XWV=XW
54776 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
54777 XW1=1D0-XW
54778 AEM=PYALEM(SH)
54779 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
54780 AS=PYALPS(SH)
54781 RADC=1D0+AS/PARU(1)
54782
54783 IF(KFLA.EQ.23) THEN
54784C...Z0:
54785 XWC=1D0/(16D0*XW*XW1)
54786 FAC=(AEM*XWC/3D0)*SHR
54787 120 CONTINUE
54788 DO 130 I=1,MDCY(KC,3)
54789 IDC=I+MDCY(KC,2)-1
54790 IF(MDME(IDC,1).LT.0) GOTO 130
54791 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54792 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54793 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
54794 IF(I.LE.8) THEN
54795C...Z0 -> q + qbar
54796 EF=KCHG(I,1)/3D0
54797 AF=SIGN(1D0,EF+0.1D0)
54798 VF=AF-4D0*EF*XWV
54799 FCOF=3D0*RADC
54800 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
54801 ELSEIF(I.LE.16) THEN
54802C...Z0 -> l+ + l-, nu + nubar
54803 EF=KCHG(I+2,1)/3D0
54804 AF=SIGN(1D0,EF+0.1D0)
54805 VF=AF-4D0*EF*XWV
54806 FCOF=1D0
54807 ENDIF
54808 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
54809 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
54810 & BE34
54811 WDTP(0)=WDTP(0)+WDTP(I)
54812 130 CONTINUE
54813
54814
54815 ELSEIF(KFLA.EQ.24) THEN
54816C...W+/-:
54817 FAC=(AEM/(24D0*XW))*SHR
54818 DO 140 I=1,MDCY(KC,3)
54819 IDC=I+MDCY(KC,2)-1
54820 IF(MDME(IDC,1).LT.0) GOTO 140
54821 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54822 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54823 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
54824 WID2=1D0
54825 IF(I.LE.16) THEN
54826C...W+/- -> q + qbar'
54827 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
54828 ELSEIF(I.LE.20) THEN
54829C...W+/- -> l+/- + nu
54830 FCOF=1D0
54831 ENDIF
54832 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
54833 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
54834 WDTP(0)=WDTP(0)+WDTP(I)
54835 140 CONTINUE
54836
54837C.....V8 -> quark anti-quark
54838 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
54839 FAC=AS/6D0*SHR
54840 TANT3=RTCM(21)
54841 IF(ITCM(2).EQ.0) THEN
54842 IMDL=1
54843 ELSEIF(ITCM(2).EQ.1) THEN
54844 IMDL=2
54845 ENDIF
54846 DO 150 I=1,MDCY(KC,3)
54847 IDC=I+MDCY(KC,2)-1
54848 IF(MDME(IDC,1).LT.0) GOTO 150
54849 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
54850 RM1=PM1**2/SH
54851 IF(RM1.GT.0.25D0) GOTO 150
54852 WID2=1D0
54853 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
54854 FMIX=1D0/TANT3**2
54855 ELSE
54856 FMIX=TANT3**2
54857 ENDIF
54858 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
54859 IF(I.EQ.6) WID2=WIDS(6,1)
54860 WDTP(0)=WDTP(0)+WDTP(I)
54861 150 CONTINUE
54862 ENDIF
54863
54864 RETURN
54865 END
54866
54867C*********************************************************************
54868
54869C...PYRVSF
54870C...Calculates R-violating decays of sfermions.
54871C...P. Z. Skands
54872
54873 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
54874
54875C...Double precision and integer declarations.
54876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54877 IMPLICIT INTEGER(I-N)
54878C...Parameter statement to help give large particle numbers.
54879 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54880 &KEXCIT=4000000,KDIMEN=5000000)
54881C...Commonblocks.
54882 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54883 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54884 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54885 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54886 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54887C...Local variables.
54888 DOUBLE PRECISION XLAM(0:400)
54889 INTEGER IDLAM(400,3), PYCOMP
54890 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
54891
54892C...IS R-VIOLATION ON ?
54893 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54894C...Mass eigenstate counter
54895 ICNT=INT(KFIN/KSUSY1)
54896C...SM KF code of SUSY particle
54897 KFSM=KFIN-ICNT*KSUSY1
54898C...Squared Sparticle Mass
54899 SM=PMAS(PYCOMP(KFIN),1)**2
54900C... Squared mass of top quark
54901 SMT=PMAS(PYCOMP(6),1)**2
54902C...IS L-VIOLATION ON ?
54903 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
54904C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
54905 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
54906 & THEN
54907 K=INT((KFSM-9)/2)
54908 DO 110 I=1,3
54909 DO 100 J=1,3
54910 IF(I.NE.J) THEN
54911C...~e,~mu,~tau -> nu_I + lepton-_J
54912 LKNT = LKNT+1
54913 IDLAM(LKNT,1)= 12 +2*(I-1)
54914 IDLAM(LKNT,2)= 11 +2*(J-1)
54915 IDLAM(LKNT,3)= 0
54916 XLAM(LKNT)=0D0
54917 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54918 IF (IMSS(51).NE.0) XLAM(LKNT) =
54919 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54920C...KINEMATICS CHECK
54921 IF (XLAM(LKNT).EQ.0D0) THEN
54922 LKNT=LKNT-1
54923 ENDIF
54924 ENDIF
54925 100 CONTINUE
54926 110 CONTINUE
54927C...~e,~mu,~tau -> nu_Ibar + lepton-_K
54928 J=INT((KFSM-9)/2)
54929 DO 130 I=1,3
54930 IF(I.NE.J) THEN
54931 DO 120 K=1,3
54932 LKNT = LKNT+1
54933 IDLAM(LKNT,1)=-12 -2*(I-1)
54934 IDLAM(LKNT,2)= 11 +2*(K-1)
54935 IDLAM(LKNT,3)= 0
54936 XLAM(LKNT)=0D0
54937 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54938 IF (IMSS(51).NE.0) XLAM(LKNT) =
54939 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54940C...KINEMATICS CHECK
54941 IF (XLAM(LKNT).EQ.0D0) THEN
54942 LKNT=LKNT-1
54943 ENDIF
54944 120 CONTINUE
54945 ENDIF
54946 130 CONTINUE
54947C...~e,~mu,~tau -> u_Jbar + d_K
54948 I=INT((KFSM-9)/2)
54949 DO 150 J=1,3
54950 DO 140 K=1,3
54951 LKNT = LKNT+1
54952 IDLAM(LKNT,1)=-2 -2*(J-1)
54953 IDLAM(LKNT,2)= 1 +2*(K-1)
54954 IDLAM(LKNT,3)= 0
54955 XLAM(LKNT)=0
54956 IF (IMSS(52).NE.0) THEN
54957C...Use massive top quark
54958 IF (IDLAM(LKNT,1).EQ.-6) THEN
54959 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
54960 & * (SM-SMT)
54961 XLAM(LKNT) =
54962 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54963C...If no top quark, all decay products massless
54964 ELSE
54965 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54966 XLAM(LKNT) =
54967 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54968 ENDIF
54969C...KINEMATICS CHECK
54970 IF (XLAM(LKNT).EQ.0D0) THEN
54971 LKNT=LKNT-1
54972 ENDIF
54973 ENDIF
54974 140 CONTINUE
54975 150 CONTINUE
54976 ENDIF
54977C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
54978C...No right-handed neutrinos
54979 IF(ICNT.EQ.1) THEN
54980 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
54981 J=INT((KFSM-10)/2)
54982 DO 170 I=1,3
54983 DO 160 K=1,3
54984 IF (I.NE.J) THEN
54985C...~nu_J -> lepton+_I + lepton-_K
54986 LKNT = LKNT+1
54987 IDLAM(LKNT,1)=-11 -2*(I-1)
54988 IDLAM(LKNT,2)= 11 +2*(K-1)
54989 IDLAM(LKNT,3)= 0
54990 XLAM(LKNT)=0D0
54991 RM2=RVLAM(I,J,K)**2 * SM
54992 IF (IMSS(51).NE.0) XLAM(LKNT) =
54993 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54994C...KINEMATICS CHECK
54995 IF (XLAM(LKNT).EQ.0D0) THEN
54996 LKNT=LKNT-1
54997 ENDIF
54998 ENDIF
54999 160 CONTINUE
55000 170 CONTINUE
55001C...~nu_I -> dbar_J + d_K
55002 I=INT((KFSM-10)/2)
55003 DO 190 J=1,3
55004 DO 180 K=1,3
55005 LKNT = LKNT+1
55006 IDLAM(LKNT,1)=-1 -2*(J-1)
55007 IDLAM(LKNT,2)= 1 +2*(K-1)
55008 IDLAM(LKNT,3)= 0
55009 XLAM(LKNT)=0D0
55010 RM2=3*RVLAMP(I,J,K)**2 * SM
55011 IF (IMSS(52).NE.0) XLAM(LKNT) =
55012 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55013C...KINEMATICS CHECK
55014 IF (XLAM(LKNT).EQ.0D0) THEN
55015 LKNT=LKNT-1
55016 ENDIF
55017 180 CONTINUE
55018 190 CONTINUE
55019 ENDIF
55020 ENDIF
55021C * SDOWN -> NU(BAR) + D and LEPTON- + U
55022 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55023 J=INT((KFSM+1)/2)
55024 DO 210 I=1,3
55025 DO 200 K=1,3
55026C...~d_J -> nu_Ibar + d_K
55027 LKNT = LKNT+1
55028 IDLAM(LKNT,1)=-12 -2*(I-1)
55029 IDLAM(LKNT,2)= 1 +2*(K-1)
55030 IDLAM(LKNT,3)= 0
55031 XLAM(LKNT)=0D0
55032 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55033 IF (IMSS(52).NE.0) XLAM(LKNT) =
55034 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55035C...KINEMATICS CHECK
55036 IF (XLAM(LKNT).EQ.0D0) THEN
55037 LKNT=LKNT-1
55038 ENDIF
55039 200 CONTINUE
55040 210 CONTINUE
55041 K=INT((KFSM+1)/2)
55042 DO 240 I=1,3
55043 DO 230 J=1,3
55044C...~d_K -> nu_I + d_J
55045 LKNT = LKNT+1
55046 IDLAM(LKNT,1)= 12 +2*(I-1)
55047 IDLAM(LKNT,2)= 1 +2*(J-1)
55048 IDLAM(LKNT,3)= 0
55049 XLAM(LKNT)=0D0
55050 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55051 IF (IMSS(52).NE.0) XLAM(LKNT) =
55052 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55053C...KINEMATICS CHECK
55054 IF (XLAM(LKNT).EQ.0D0) THEN
55055 LKNT=LKNT-1
55056 ENDIF
55057C...~d_K -> lepton_I- + u_J
55058 220 LKNT = LKNT+1
55059 IDLAM(LKNT,1)= 11 +2*(I-1)
55060 IDLAM(LKNT,2)= 2 +2*(J-1)
55061 IDLAM(LKNT,3)= 0
55062 XLAM(LKNT)=0D0
55063 IF (IMSS(52).NE.0) THEN
55064C...Use massive top quark
55065 IF (IDLAM(LKNT,2).EQ.6) THEN
55066 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
55067 XLAM(LKNT) =
55068 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
55069C...If no top quark, all decay products massless
55070 ELSE
55071 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55072 XLAM(LKNT) =
55073 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55074 ENDIF
55075C...KINEMATICS CHECK
55076 IF (XLAM(LKNT).EQ.0D0) THEN
55077 LKNT=LKNT-1
55078 ENDIF
55079 ENDIF
55080 230 CONTINUE
55081 240 CONTINUE
55082 ENDIF
55083C * SUP -> LEPTON+ + D
55084 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55085 J=NINT(KFSM/2.)
55086 DO 260 I=1,3
55087 DO 250 K=1,3
55088C...~u_J -> lepton_I+ + d_K
55089 LKNT = LKNT+1
55090 IDLAM(LKNT,1)=-11 -2*(I-1)
55091 IDLAM(LKNT,2)= 1 +2*(K-1)
55092 IDLAM(LKNT,3)= 0
55093 XLAM(LKNT)=0D0
55094 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55095 IF (IMSS(52).NE.0) XLAM(LKNT) =
55096 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55097C...KINEMATICS CHECK
55098 IF (XLAM(LKNT).EQ.0D0) THEN
55099 LKNT=LKNT-1
55100 ENDIF
55101 250 CONTINUE
55102 260 CONTINUE
55103 ENDIF
55104 ENDIF
55105C...BARYON NUMBER VIOLATING DECAYS
55106 IF (IMSS(53).GE.1) THEN
55107C * SUP -> DBAR + DBAR
55108 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55109 I = KFSM/2
55110 DO 280 J=1,3
55111 DO 270 K=1,3
55112C...~u_I -> dbar_J + dbar_K
55113 IF (J.LT.K) THEN
55114C...(anti-) symmetry J <-> K.
55115 LKNT = LKNT + 1
55116 IDLAM(LKNT,1) = -1 -2*(J-1)
55117 IDLAM(LKNT,2) = -1 -2*(K-1)
55118 IDLAM(LKNT,3) = 0
55119 XLAM(LKNT) = 0D0
55120 RM2 = 2.*(RVLAMB(I,J,K)**2)
55121 & * SFMIX(KFSM,2*ICNT)**2 * SM
55122 XLAM(LKNT) =
55123 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55124C...KINEMATICS CHECK
55125 IF (XLAM(LKNT).EQ.0D0) THEN
55126 LKNT = LKNT-1
55127 ENDIF
55128 ENDIF
55129 270 CONTINUE
55130 280 CONTINUE
55131 ENDIF
55132C * SDOWN -> UBAR + DBAR
55133 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55134 K=(KFSM+1)/2
55135 DO 300 I=1,3
55136 DO 290 J=1,3
55137C...LAMB coupling antisymmetric in J and K.
55138 IF (J.NE.K) THEN
55139C...~d_K -> ubar_I + dbar_K
55140 LKNT = LKNT + 1
55141 IDLAM(LKNT,1)= -2 -2*(I-1)
55142 IDLAM(LKNT,2)= -1 -2*(J-1)
55143 IDLAM(LKNT,3)= 0
55144 XLAM(LKNT)=0D0
55145C...Use massive top quark
55146 IF (IDLAM(LKNT,1).EQ.-6) THEN
55147 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
55148 & )
55149 XLAM(LKNT) =
55150 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
55151C...If no top quark, all decay products massless
55152 ELSE
55153 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55154 XLAM(LKNT) =
55155 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55156 ENDIF
55157C...KINEMATICS CHECK
55158 IF (XLAM(LKNT).EQ.0D0) THEN
55159 LKNT=LKNT-1
55160 ENDIF
55161 ENDIF
55162 290 CONTINUE
55163 300 CONTINUE
55164 ENDIF
55165 ENDIF
55166 ENDIF
55167
55168 RETURN
55169 END
55170
55171C*********************************************************************
55172
55173C...PYRVNE
55174C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
55175C...P. Z. Skands
55176
55177 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
55178
55179C...Double precision and integer declarations.
55180 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55181 IMPLICIT INTEGER(I-N)
55182C...Parameter statement to help give large particle numbers.
55183 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55184 &KEXCIT=4000000,KDIMEN=5000000)
55185C...Commonblocks.
55186 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55187 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55188 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55189 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55190 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55191 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55192C...Local variables.
55193 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55194 & ,DCMASS,KFR(3)
55195 DOUBLE PRECISION XLAM(0:400)
55196 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
55197 INTEGER IDLAM(400,3), PYCOMP
55198 LOGICAL DCMASS
55199 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
55200
55201C...R-VIOLATING DECAYS
55202 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55203 KFSM=KFIN-KSUSY1
55204 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
55205C...WHICH NEUTRALINO ?
55206 NCHI=1
55207 IF (KFSM.EQ.23) NCHI=2
55208 IF (KFSM.EQ.25) NCHI=3
55209 IF (KFSM.EQ.35) NCHI=4
55210C...SIGN OF MASS (Opposite convention as HERWIG)
55211 ISM = 1
55212 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
55213
55214C...Useful parameters for the calculation of the A and B constants.
55215 WMASS = PMAS(PYCOMP(24),1)
55216 ECHG = 2*SQRT(PARU(103)*PARU(1))
55217 COSB=1/(SQRT(1+RMSS(5)**2))
55218 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
55219 COSW=SQRT(1-PARU(102))
55220 SINW=SQRT(PARU(102))
55221 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
55222C...Run quark masses to neutralino mass squared (for Higgs-type
55223C...couplings)
55224 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
55225 DO 100 I=1,6
55226 RMQ(I)=PYMRUN(I,SQMCHI)
55227 100 CONTINUE
55228C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
55229 DO 110 NCHJ=1,4
55230 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
55231 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
55232 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
55233 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
55234 110 CONTINUE
55235 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
55236 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
55237 C2=ECHG*ZPMIX(NCHI,1)
55238 C3=GW*ZPMIX(NCHI,2)/COSW
55239 EU=2D0/3D0
55240 ED=-1D0/3D0
55241C... AB(x,y,z):
55242C x=1-2 : Select A or B constant (1:A ; 2:B)
55243C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55244C 11-16:e,nu_e,mu,...)
55245C z=1-2 : Mass eigenstate number
55246C...CALCULATE COUPLINGS
55247 DO 120 I = 11,15,2
55248 CMS=PMAS(PYCOMP(I),1)
55249C...Intermediate sleptons
55250 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
55251 & *(C2-C3*SINW**2))
55252 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
55253 & *(C2-C3*SINW**2))
55254 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
55255 & **2))
55256 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
55257 & **2))
55258C...Inermediate sneutrinos
55259 AB(1,I+1,1)=0D0
55260 AB(2,I+1,1)=5D-1*C3
55261 AB(1,I+1,2)=0D0
55262 AB(2,I+1,2)=0D0
55263C...Inermediate sdown
55264 J=I-10
55265 CMS=RMQ(J)
55266 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
55267 & *ED*(C2-C3*SINW**2))
55268 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
55269 & *ED*(C2-C3*SINW**2))
55270 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
55271 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55272 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
55273 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55274C...Inermediate sup
55275 J=J+1
55276 CMS=RMQ(J)
55277 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
55278 & *EU*(C2-C3*SINW**2))
55279 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
55280 & *EU*(C2-C3*SINW**2))
55281 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
55282 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55283 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
55284 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55285 120 CONTINUE
55286
55287 IF (IMSS(51).GE.1) THEN
55288C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
55289C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
55290C...STEP IN I,J,K USING SINGLE COUNTER
55291 DO 130 ISC=0,26
55292C...LAMBDA COUPLING ASYM IN I,J
55293 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55294 LKNT = LKNT+1
55295 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55296 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55297 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55298 XLAM(LKNT) = 0D0
55299C...Set coupling, and decay product masses on/off
55300 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55301 & ,MOD(ISC,3)+1)**2
55302 DCMASS=.FALSE.
55303 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
55304 & DCMASS = .TRUE.
55305C...Resonance KF codes (1=I,2=J,3=K)
55306 KFR(1)=-IDLAM(LKNT,1)
55307 KFR(2)=-IDLAM(LKNT,2)
55308 KFR(3)=-IDLAM(LKNT,3)
55309C...Calculate width.
55310 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55311 & IDLAM(LKNT,3),XLAM(LKNT))
55312 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55313C...Charge conjugate mode.
55314 LKNT=LKNT+1
55315 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55316 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55317 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55318 XLAM(LKNT)=XLAM(LKNT-1)
55319C...KINEMATICS CHECK
55320 IF (XLAM(LKNT).EQ.0D0) THEN
55321 LKNT=LKNT-2
55322 ENDIF
55323 ENDIF
55324 130 CONTINUE
55325 ENDIF
55326
55327 IF (IMSS(52).GE.1) THEN
55328C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
55329C * CHI0 -> NUBAR_I + DBAR_J + D_K
55330 DO 140 ISC=0,26
55331 LKNT = LKNT+1
55332 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55333 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55334 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55335 XLAM(LKNT) = 0D0
55336C...Set coupling, and decay product masses on/off
55337 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55338 & ,MOD(ISC,3)+1)**2
55339 DCMASS=.FALSE.
55340 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
55341 & DCMASS = .TRUE.
55342C...Resonance KF codes (1=I,2=J,3=K)
55343 KFR(1)=-IDLAM(LKNT,1)
55344 KFR(2)=-IDLAM(LKNT,2)
55345 KFR(3)=-IDLAM(LKNT,3)
55346C...Calculate width.
55347 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55348 & ,XLAM(LKNT))
55349 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55350C...Charge conjugate mode.
55351 LKNT=LKNT+1
55352 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55353 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55354 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55355 XLAM(LKNT)=XLAM(LKNT-1)
55356C...KINEMATICS CHECK
55357 IF (XLAM(LKNT).EQ.0D0) THEN
55358 LKNT=LKNT-2
55359 ENDIF
55360
55361C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
55362 LKNT = LKNT+1
55363 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55364 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55365 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55366 XLAM(LKNT) = 0D0
55367C...Set coupling, and decay product masses on/off
55368 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55369 & ,MOD(ISC,3)+1)**2
55370 DCMASS=.FALSE.
55371 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
55372 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55373C...Resonance KF codes (1=I,2=J,3=K)
55374 KFR(1)=-IDLAM(LKNT,1)
55375 KFR(2)=-IDLAM(LKNT,2)
55376 KFR(3)=-IDLAM(LKNT,3)
55377C...Calculate width.
55378 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55379 & ,XLAM(LKNT))
55380 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55381C...Charge conjugate mode.
55382 LKNT=LKNT+1
55383 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55384 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55385 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55386 XLAM(LKNT)=XLAM(LKNT-1)
55387C...KINEMATICS CHECK
55388 IF (XLAM(LKNT).EQ.0D0) THEN
55389 LKNT=LKNT-2
55390 ENDIF
55391 140 CONTINUE
55392 ENDIF
55393
55394 IF (IMSS(53).GE.1) THEN
55395C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
55396C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
55397 DO 150 ISC=0,26
55398C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
55399 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
55400 LKNT = LKNT+1
55401 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
55402 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55403 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55404 XLAM(LKNT) = 0D0
55405C...Set coupling, and decay product masses on/off
55406 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
55407 & +1,MOD(ISC,3)+1)**2
55408 DCMASS=.FALSE.
55409 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
55410 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
55411C...Resonance KF codes (1=I,2=J,3=K)
55412 KFR(1) = IDLAM(LKNT,1)
55413 KFR(2) = IDLAM(LKNT,2)
55414 KFR(3) = IDLAM(LKNT,3)
55415C...Calculate width.
55416 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55417 & IDLAM(LKNT,3),XLAM(LKNT))
55418 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55419C...Charge conjugate mode.
55420 LKNT=LKNT+1
55421 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55422 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55423 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55424 XLAM(LKNT)=XLAM(LKNT-1)
55425C...KINEMATICS CHECK
55426 IF (XLAM(LKNT).EQ.0D0) THEN
55427 LKNT=LKNT-2
55428 ENDIF
55429 ENDIF
55430 150 CONTINUE
55431 ENDIF
55432 ENDIF
55433 ENDIF
55434
55435 RETURN
55436 END
55437
55438C*********************************************************************
55439
55440C...PYRVCH
55441C...Calculates R-violating chargino decay widths.
55442C...P. Z. Skands
55443
55444 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
55445
55446C...Double precision and integer declarations.
55447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55448 IMPLICIT INTEGER(I-N)
55449C...Parameter statement to help give large particle numbers.
55450 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55451 &KEXCIT=4000000,KDIMEN=5000000)
55452C...Commonblocks.
55453 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55454 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55455 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55456 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55457 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55458 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55459C...Local variables.
55460 DOUBLE PRECISION XLAM(0:400)
55461 INTEGER IDLAM(400,3), PYCOMP
55462C...Information from main routine to PYRVGW
55463 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55464 & ,DCMASS,KFR(3)
55465C...Auxiliary variables needed for BV (RV Gauge STOre)
55466 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55467 & ,RVLJKI,RVLJIK
55468C...Running quark masses
55469 DOUBLE PRECISION RMQ(6)
55470C...Decay product masses on/off
55471 LOGICAL DCMASS
55472 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55473 & /RVGSTO/
55474
55475
55476C...IF R-VIOLATION ON.
55477 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55478 KFSM=KFIN-KSUSY1
55479 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
55480C...WHICH CHARGINO ?
55481 NCHI = 1
55482 IF (KFSM.EQ.37) NCHI = 2
55483
55484C...Useful parameters for calculating the A and B constants.
55485C...SIGN OF MASS (Opposite convention as HERWIG)
55486 ISM = 1
55487 IF (SMW(NCHI).LT.0D0) ISM = -1
55488 WMASS = PMAS(PYCOMP(24),1)
55489 COSB = 1/(SQRT(1+RMSS(5)**2))
55490 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
55491 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
55492 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
55493 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
55494 C2 = UMIX(NCHI,1)
55495 C3 = VMIX(NCHI,1)
55496C...Running masses at Q^2=MCHI^2.
55497 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
55498 DO 100 I=1,6
55499 RMQ(I)=PYMRUN(I,SQMCHI)
55500 100 CONTINUE
55501
55502C... AB(x,y,z) coefficients:
55503C x=1-2 : A or B coefficient (1:A ; 2:B)
55504C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55505C 11-16:e,nu_e,mu,...)
55506C z=1-2 : Mass eigenstate number
55507 DO 110 I = 11,15,2
55508C...Intermediate sleptons
55509 AB(1,I,1) = 0D0
55510 AB(1,I,2) = 0D0
55511 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
55512 & SFMIX(I,1)*C2
55513 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
55514 & SFMIX(I,3)*C2
55515C...Intermediate sneutrinos
55516 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
55517 AB(1,I+1,2) = 0D0
55518 AB(2,I+1,1) = ISM*C3
55519 AB(2,I+1,2) = 0D0
55520C...Intermediate sdown
55521 J=I-10
55522 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
55523 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
55524 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
55525 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
55526C...Intermediate sup
55527 J=J+1
55528 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
55529 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
55530 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
55531 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
55532 110 CONTINUE
55533
55534C...LLE TYPE R-VIOLATION
55535 IF (IMSS(51).GE.1) THEN
55536C...LOOP OVER DECAY MODES
55537 DO 140 ISC=0,26
55538
55539C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
55540 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55541 LKNT = LKNT+1
55542 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
55543 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
55544 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
55545 XLAM(LKNT) = 0D0
55546C...Set coupling, and decay product masses on/off
55547 RVLAMC = GW2 * 5D-1 *
55548 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
55549 & **2
55550 DCMASS=.FALSE.
55551 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
55552C...Resonance KF codes (1=I,2=J,3=K).
55553 KFR(1) = 0
55554 KFR(2) = 0
55555 KFR(3) = -IDLAM(LKNT,3)+1
55556C...Calculate width.
55557 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55558 & IDLAM(LKNT,3),XLAM(LKNT))
55559 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55560C...KINEMATICS CHECK
55561 IF (XLAM(LKNT).EQ.0D0) THEN
55562 LKNT=LKNT-1
55563 ENDIF
55564
55565C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
55566 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
55567 LKNT = LKNT+1
55568 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55569 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
55570 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
55571 XLAM(LKNT) = 0D0
55572C...Set coupling, and decay product masses on/off
55573 RVLAMC = GW2 * 5D-1 *
55574 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55575C...I,J SYMMETRY => FACTOR 2
55576 RVLAMC=2*RVLAMC
55577 DCMASS=.FALSE.
55578 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
55579C...Resonance KF codes (1=I,2=J,3=K)
55580 KFR(1)=IDLAM(LKNT,1)-1
55581 KFR(2)=IDLAM(LKNT,2)-1
55582 KFR(3)=0
55583C...Calculate width.
55584 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55585 & IDLAM(LKNT,3),XLAM(LKNT))
55586 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55587C...KINEMATICS CHECK
55588 IF (XLAM(LKNT).EQ.0D0) THEN
55589 LKNT=LKNT-1
55590 ENDIF
55591 130 ENDIF
55592
55593C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
55594 LKNT = LKNT+1
55595 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55596 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55597 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55598 XLAM(LKNT) = 0D0
55599C...Set coupling, and decay product masses on/off
55600 RVLAMC = GW2 * 5D-1 *
55601 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55602C...I,J SYMMETRY => FACTOR 2
55603 RVLAMC=2*RVLAMC
55604 DCMASS=.FALSE.
55605 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
55606 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
55607C...Resonance KF codes (1=I,2=J,3=K)
55608 KFR(1) =-IDLAM(LKNT,1)+1
55609 KFR(2) =-IDLAM(LKNT,2)+1
55610 KFR(3) = 0
55611C...Calculate width.
55612 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55613 & IDLAM(LKNT,3),XLAM(LKNT))
55614 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55615C...KINEMATICS CHECK
55616 IF (XLAM(LKNT).EQ.0D0) THEN
55617 LKNT=LKNT-1
55618 ENDIF
55619 ENDIF
55620 140 CONTINUE
55621 ENDIF
55622
55623C...LQD TYPE R-VIOLATION
55624 IF (IMSS(52).GE.1) THEN
55625C...LOOP OVER DECAY MODES
55626 DO 180 ISC=0,26
55627
55628C...CHI+ -> NUBAR_I + DBAR_J + U_K
55629 LKNT = LKNT+1
55630 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55631 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55632 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55633 XLAM(LKNT) = 0D0
55634C...Set coupling, and decay product masses on/off
55635 RVLAMC = 3. * GW2 * 5D-1 *
55636 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55637 DCMASS=.FALSE.
55638 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
55639 & DCMASS = .TRUE.
55640C...Resonance KF codes (1=I,2=J,3=K)
55641 KFR(1)=0
55642 KFR(2)=0
55643 KFR(3)=-IDLAM(LKNT,3)+1
55644C...Calculate width.
55645 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55646 & ,XLAM(LKNT))
55647 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55648C...KINEMATICS CHECK
55649 IF (XLAM(LKNT).EQ.0D0) THEN
55650 LKNT=LKNT-1
55651 ENDIF
55652
55653C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
55654 150 LKNT = LKNT+1
55655 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55656 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55657 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55658 XLAM(LKNT) = 0D0
55659C...Set coupling, and decay product masses on/off
55660 RVLAMC = 3. * GW2 * 5D-1 *
55661 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55662 DCMASS=.FALSE.
55663 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
55664 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
55665C...Resonance KF codes (1=I,2=J,3=K)
55666 KFR(1)=0
55667 KFR(2)=0
55668 KFR(3)=-IDLAM(LKNT,3)+1
55669C...Calculate width.
55670 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55671 & ,XLAM(LKNT))
55672 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55673C...KINEMATICS CHECK
55674 IF (XLAM(LKNT).EQ.0D0) THEN
55675 LKNT=LKNT-1
55676 ENDIF
55677
55678C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
55679 160 LKNT = LKNT+1
55680 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55681 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55682 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55683 XLAM(LKNT) = 0D0
55684C...Set coupling, and decay product masses on/off
55685 RVLAMC = 3. * GW2 * 5D-1 *
55686 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55687 DCMASS = .FALSE.
55688 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
55689 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
55690C...Resonance KF codes (1=I,2=J,3=K)
55691 KFR(1)=-IDLAM(LKNT,1)+1
55692 KFR(2)=-IDLAM(LKNT,2)+1
55693 KFR(3)=0
55694C...Calculate width.
55695 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55696 & ,XLAM(LKNT))
55697 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55698C...KINEMATICS CHECK
55699 IF (XLAM(LKNT).EQ.0D0) THEN
55700 LKNT=LKNT-1
55701 ENDIF
55702
55703C * CHI+ -> NU_I + U_J + DBAR_K.
55704 170 LKNT = LKNT+1
55705 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55706 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55707 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55708 XLAM(LKNT) = 0D0
55709C...Set coupling, and decay product masses on/off
55710 DCMASS = .FALSE.
55711 RVLAMC = 3. * GW2 * 5D-1 *
55712 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55713 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
55714 & DCMASS = .TRUE.
55715C...Resonance KF codes (1=I,2=J,3=K)
55716 KFR(1)=IDLAM(LKNT,1)-1
55717 KFR(2)=IDLAM(LKNT,2)-1
55718 KFR(3)=0
55719C...Calculate width.
55720 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55721 & ,XLAM(LKNT))
55722 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55723C...KINEMATICS CHECK
55724 IF (XLAM(LKNT).EQ.0D0) THEN
55725 LKNT=LKNT-1
55726 ENDIF
55727
55728 180 CONTINUE
55729 ENDIF
55730
55731C...UDD TYPE R-VIOLATION
55732C...These decays need special treatment since more than one BV coupling
55733C...contributes (with interference). Consider e.g. (symbolically)
55734C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
55735C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
55736C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
55737C...The problem is that a single call to PYRVGW would evaluate all
55738C...these terms and sum them, but without the different couplings. The
55739C...way out is to call PYRVGW three times, once for the first line, once
55740C...for the second line, and then once for all the lines (it is
55741C...impossible to get just the last line out) without multiplying by
55742C...couplings. The last line is then obtained as the result of the third
55743C...call minus the results of the two first calls. Each term is then
55744C...multiplied by its respective coupling before the whole thing is
55745C...summed up in XLAM.
55746C...Note that with three interfering resonances, this procedure becomes
55747C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
55748
55749 IF (IMSS(53).GE.1) THEN
55750C...LOOP OVER DECAY MODES
55751 DO 190 ISC=1,25
55752
55753C...CHI+ -> U_I + U_J + D_K
55754C...Decay mode I<->J symmetric.
55755 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
55756 LKNT = LKNT+1
55757 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
55758 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55759 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55760 XLAM(LKNT) = 0D0
55761C...Set coupling, and decay product masses on/off
55762 RVLAMC= 6. * GW2 * 5D-1
55763 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
55764 & +1)
55765 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55766 & +1)
55767 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
55768 & * RVLAMC
55769 DCMASS=.FALSE.
55770 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
55771 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
55772C...Resonance KF codes (1=I,2=J,3=K)
55773 KFR(1) = -IDLAM(LKNT,1)+1
55774 KFR(2) = 0
55775 KFR(3) = 0
55776C...Calculate width.
55777 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55778 & IDLAM(LKNT,3),XRESI)
55779C...Resonance KF codes (1=I,2=J,3=K)
55780 KFR(1) = 0
55781 KFR(2) = -IDLAM(LKNT,2)+1
55782 KFR(3) = 0
55783C...Calculate width.
55784 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55785 & IDLAM(LKNT,3),XRESJ)
55786C...Resonance KF codes (1=I,2=J,3=K)
55787 KFR(1) = -IDLAM(LKNT,1)+1
55788 KFR(2) = -IDLAM(LKNT,2)+1
55789 KFR(3) = 0
55790C...Calculate width.
55791 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55792 & IDLAM(LKNT,3),XRESIJ)
55793 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
55794 XRESIJ = XRESIJ-XRESI-XRESJ
55795 ELSE
55796 XRESIJ = 0D0
55797 ENDIF
55798C...CALCULATE TOTAL WIDTH
55799 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
55800 & + RVLJIK*RVLIJK * XRESIJ
55801 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55802C...KINEMATICS CHECK
55803 IF (XLAM(LKNT).EQ.0D0) THEN
55804 LKNT=LKNT-1
55805 ENDIF
55806 ENDIF
55807C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
55808C...Symmetry I<->J<->K.
55809 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
55810 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
55811 LKNT = LKNT+1
55812 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
55813 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55814 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55815 XLAM(LKNT) = 0D0
55816C...Set coupling, and decay product masses on/off
55817 RVLAMC = 6. * GW2 * 5D-1
55818 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55819 & +1)
55820 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
55821 & +1)
55822 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
55823 & +1)
55824 DCMASS = .FALSE.
55825 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
55826 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
55827C...Collect symmetry factors
55828 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
55829 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
55830 & RVLAMC = 5D-1 * RVLAMC
55831C...Resonance KF codes (1=I,2=J,3=K)
55832 KFR(1) = IDLAM(LKNT,1)-1
55833 KFR(2) = 0
55834 KFR(3) = 0
55835C...Calculate width.
55836 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55837 & IDLAM(LKNT,3),XRESI)
55838C...Resonance KF codes (1=I,2=J,3=K)
55839 KFR(1) = 0
55840 KFR(2) = IDLAM(LKNT,2)-1
55841 KFR(3) = 0
55842C...Calculate width.
55843 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55844 & IDLAM(LKNT,3),XRESJ)
55845C...Resonance KF codes (1=I,2=J,3=K)
55846 KFR(1) = 0
55847 KFR(2) = 0
55848 KFR(3) = IDLAM(LKNT,3)-1
55849C...Calculate width.
55850 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55851 & IDLAM(LKNT,3),XRESK)
55852C...Resonance KF codes (1=I,2=J,3=K)
55853 KFR(1) = IDLAM(LKNT,1)-1
55854 KFR(2) = IDLAM(LKNT,2)-1
55855 KFR(3) = 0
55856C...Calculate width.
55857 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55858 & IDLAM(LKNT,3),XRESIJ)
55859 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
55860 XRESIJ = XRESI+XRESJ-XRESIJ
55861 ELSE
55862 XRESIJ = 0D0
55863 ENDIF
55864C...Resonance KF codes (1=I,2=J,3=K)
55865 KFR(1) = 0
55866 KFR(2) = IDLAM(LKNT,2)-1
55867 KFR(3) = IDLAM(LKNT,3)-1
55868C...Calculate width.
55869 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55870 & IDLAM(LKNT,3),XRESJK)
55871 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
55872 XRESJK = XRESJ+XRESK-XRESJK
55873 ELSE
55874 XRESJK = 0D0
55875 ENDIF
55876C...Resonance KF codes (1=I,2=J,3=K)
55877 KFR(1) = IDLAM(LKNT,1)-1
55878 KFR(2) = 0
55879 KFR(3) = IDLAM(LKNT,3)-1
55880C...Calculate width.
55881 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55882 & IDLAM(LKNT,3),XRESIK)
55883 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
55884 XRESIK = XRESI+XRESK-XRESIK
55885 ELSE
55886 XRESIK = 0D0
55887 ENDIF
55888C...CALCULATE TOTAL WIDTH
55889 XLAM(LKNT) =
55890 & RVLIJK**2 * XRESI
55891 & + RVLJKI**2 * XRESJ
55892 & + RVLKIJ**2 * XRESK
55893 & + RVLIJK*RVLJKI * XRESIJ
55894 & + RVLIJK*RVLKIJ * XRESIK
55895 & + RVLJKI*RVLKIJ * XRESJK
55896 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
55897C...KINEMATICS CHECK
55898 IF (XLAM(LKNT).EQ.0D0) THEN
55899 LKNT=LKNT-1
55900 ENDIF
55901 ENDIF
55902 190 CONTINUE
55903 ENDIF
55904 ENDIF
55905 ENDIF
55906
55907 RETURN
55908 END
55909
55910C*********************************************************************
55911
55912C...PYRVGL
55913C...Calculates R-violating gluino decay widths.
55914C...See BV part of PYRVCH for comments about the way the BV decay width
55915C...is calculated. Same comments apply here.
55916C...P. Z. Skands
55917
55918 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
55919
55920C...Double precision and integer declarations.
55921 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55922 IMPLICIT INTEGER(I-N)
55923C...Parameter statement to help give large particle numbers.
55924 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55925 &KEXCIT=4000000,KDIMEN=5000000)
55926C...Commonblocks.
55927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55929 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55930 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55931 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55932 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55933C...Local variables.
55934 DOUBLE PRECISION XLAM(0:400)
55935 INTEGER IDLAM(400,3), PYCOMP
55936C...Information from main routine to PYRVGW
55937 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55938 & ,DCMASS,KFR(3)
55939C...Auxiliary variables needed for BV (RV Gauge STOre)
55940 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55941 & ,RVLJKI,RVLJIK
55942C...Running quark masses
55943 DOUBLE PRECISION RMQ(6)
55944C...Decay product masses on/off
55945 LOGICAL DCMASS
55946 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55947 & /RVGSTO/
55948
55949C...IF LQD OR UDD TYPE R-VIOLATION ON.
55950 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
55951 KFSM=KFIN-KSUSY1
55952
55953C... AB(x,y,z):
55954C x=1-2 : Select A or B coupling (1:A ; 2:B)
55955C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55956C 11-16:e,nu_e,mu,... not used here)
55957C z=1-2 : Mass eigenstate number
55958 DO 100 I = 1,6
55959C...A Couplings
55960 AB(1,I,1) = SFMIX(I,2)
55961 AB(1,I,2) = SFMIX(I,4)
55962C...B Couplings
55963 AB(2,I,1) = -SFMIX(I,1)
55964 AB(2,I,2) = -SFMIX(I,3)
55965 100 CONTINUE
55966 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
55967C...LQD DECAYS.
55968 IF (IMSS(52).GE.1) THEN
55969C...STEP IN I,J,K USING SINGLE COUNTER
55970 DO 120 ISC=0,26
55971C * GLUINO -> NUBAR_I + DBAR_J + D_K.
55972 LKNT = LKNT+1
55973 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55974 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55975 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55976 XLAM(LKNT)=0D0
55977C...Set coupling, and decay product masses on/off
55978 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55979 & * 5D-1 * GSTR2
55980 DCMASS = .FALSE.
55981 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55982C...Resonance KF codes (1=I,2=J,3=K)
55983 KFR(1) = 0
55984 KFR(2) = -IDLAM(LKNT,2)
55985 KFR(3) = -IDLAM(LKNT,3)
55986C...Calculate width.
55987 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55988 & ,XLAM(LKNT))
55989C...Normalize
55990 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55991C...Charge conjugate mode.
55992 110 LKNT = LKNT+1
55993 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
55994 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
55995 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
55996 XLAM(LKNT) = XLAM(LKNT-1)
55997C...KINEMATICS CHECK
55998 IF (XLAM(LKNT).EQ.0D0) THEN
55999 LKNT=LKNT-2
56000 ENDIF
56001
56002C * GLUINO -> LEPTON+_I + UBAR_J + D_K
56003 LKNT = LKNT+1
56004 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
56005 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
56006 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
56007 XLAM(LKNT)=0D0
56008C...Set coupling, and decay product masses on/off
56009 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56010 & **2* 5D-1 * GSTR2
56011 DCMASS = .FALSE.
56012 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
56013 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
56014C...Resonance KF codes (1=I,2=J,3=K)
56015 KFR(1) = 0
56016 KFR(2) = -IDLAM(LKNT,2)
56017 KFR(3) = -IDLAM(LKNT,3)
56018C...Calculate width.
56019 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56020 & ,XLAM(LKNT))
56021 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56022C...Charge conjugate mode.
56023 LKNT=LKNT+1
56024 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
56025 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
56026 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
56027 XLAM(LKNT) = XLAM(LKNT-1)
56028C...KINEMATICS CHECK
56029 IF (XLAM(LKNT).EQ.0D0) THEN
56030 LKNT=LKNT-2
56031 ENDIF
56032
56033 120 CONTINUE
56034 ENDIF
56035
56036C...UDD DECAYS.
56037 IF (IMSS(53).GE.1) THEN
56038C...STEP IN I,J,K USING SINGLE COUNTER
56039 DO 130 ISC=0,26
56040C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
56041 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
56042 LKNT = LKNT+1
56043 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
56044 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
56045 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
56046 XLAM(LKNT)=0D0
56047C...Set coupling, and decay product masses on/off. A factor of 2 for
56048C...(N_C-1) has been used to cancel a factor 0.5.
56049 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56050 & **2 * GSTR2
56051 DCMASS = .FALSE.
56052 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
56053 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
56054C...Resonance KF codes (1=I,2=J,3=K)
56055 KFR(1) = IDLAM(LKNT,1)
56056 KFR(2) = 0
56057 KFR(3) = 0
56058C...Calculate width.
56059 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56060 & ,XRESI)
56061C...Resonance KF codes (1=I,2=J,3=K)
56062 KFR(1) = 0
56063 KFR(2) = IDLAM(LKNT,2)
56064 KFR(3) = 0
56065C...Calculate width.
56066 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56067 & ,XRESJ)
56068C...Resonance KF codes (1=I,2=J,3=K)
56069 KFR(1) = 0
56070 KFR(2) = 0
56071 KFR(3) = IDLAM(LKNT,3)
56072C...Calculate width.
56073 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56074 & ,XRESK)
56075C...Resonance KF codes (1=I,2=J,3=K)
56076 KFR(1) = IDLAM(LKNT,1)
56077 KFR(2) = IDLAM(LKNT,2)
56078 KFR(3) = 0
56079C...Calculate width.
56080 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56081 & ,XRESIJ)
56082C...Calculate interference function. (Factor -1/2 to make up for factor
56083C...-2 in PYRVGW.
56084 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
56085 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
56086 ELSE
56087 XRESIJ = 0D0
56088 ENDIF
56089C...Resonance KF codes (1=I,2=J,3=K)
56090 KFR(1) = 0
56091 KFR(2) = IDLAM(LKNT,2)
56092 KFR(3) = IDLAM(LKNT,3)
56093C...Calculate width.
56094 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56095 & ,XRESJK)
56096 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
56097 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
56098 ELSE
56099 XRESJK = 0D0
56100 ENDIF
56101C...Resonance KF codes (1=I,2=J,3=K)
56102 KFR(1) = IDLAM(LKNT,1)
56103 KFR(2) = 0
56104 KFR(3) = IDLAM(LKNT,3)
56105C...Calculate width.
56106 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56107 & ,XRESIK)
56108 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
56109 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
56110 ELSE
56111 XRESIK = 0D0
56112 ENDIF
56113C...Calculate total width (factor 1/2 from 1/(N_C-1))
56114 XLAM(LKNT) = XRESI + XRESJ + XRESK
56115 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
56116C...Normalize
56117 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56118C...Charge conjugate mode.
56119 LKNT = LKNT+1
56120 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56121 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56122 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56123 XLAM(LKNT) = XLAM(LKNT-1)
56124C...KINEMATICS CHECK
56125 IF (XLAM(LKNT).EQ.0D0) THEN
56126 LKNT=LKNT-2
56127 ENDIF
56128 ENDIF
56129 130 CONTINUE
56130 ENDIF
56131 ENDIF
56132 RETURN
56133 END
56134
56135C*********************************************************************
56136
56137C...PYRVSB
56138C...Auxiliary function to PYRVSF for calculating R-Violating
56139C...sfermion widths. Though the decay products are most often treated
56140C...as massless in the calculation, the kinematical boundary of phase
56141C...space is tested using the true masses.
56142C...MODE = 1: All decay products massive
56143C...MODE = 2: Decay product 1 massless
56144C...MODE = 3: Decay product 2 massless
56145C...MODE = 4: All decay products massless
56146
56147 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
56148
56149 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56150 IMPLICIT INTEGER (I-N)
56151 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56152 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56153 SAVE /PYDAT1/,/PYDAT2/
56154 DOUBLE PRECISION SM(3)
56155 INTEGER PYCOMP, KC(3)
56156 KC(1)=PYCOMP(KFIN)
56157 KC(2)=PYCOMP(ID1)
56158 KC(3)=PYCOMP(ID2)
56159 SM(1)=PMAS(KC(1),1)**2
56160 SM(2)=PMAS(KC(2),1)**2
56161 SM(3)=PMAS(KC(3),1)**2
56162C...Kinematics check
56163 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
56164 PYRVSB=0D0
56165 RETURN
56166 ENDIF
56167C...CM momenta squared
56168 IF (MODE.EQ.1) THEN
56169 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
56170 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
56171 ELSE IF (MODE.EQ.2) THEN
56172 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
56173 ELSE IF (MODE.EQ.3) THEN
56174 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
56175 ELSE
56176 P2CM=SM(1)/4.
56177 ENDIF
56178C...Calculate Width
56179 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
56180 RETURN
56181 END
56182
56183C*********************************************************************
56184
56185C...PYRVGW
56186C...Generalized Matrix Element for R-Violating 3-body widths.
56187C...P. Z. Skands
56188 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
56189
56190 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56191 IMPLICIT INTEGER (I-N)
56192 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56193 &KEXCIT=4000000,KDIMEN=5000000)
56194 PARAMETER (EPS=1D-4)
56195 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56196 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56197 & ,DCMASS,KFR(3)
56198 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56199 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56200 DOUBLE PRECISION XLIM(3,3)
56201 INTEGER KC(0:3), PYCOMP
56202 LOGICAL DCMASS, DCHECK(6)
56203 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
56204
56205 XLAM = 0D0
56206
56207 KC(0) = PYCOMP(KFIN)
56208 KC(1) = PYCOMP(ID1)
56209 KC(2) = PYCOMP(ID2)
56210 KC(3) = PYCOMP(ID3)
56211 RMS(0) = PMAS(KC(0),1)
56212 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
56213 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
56214 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
56215C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
56216 XLIM(1,1)=(RMS(1)+RMS(2))**2
56217 XLIM(1,2)=(RMS(0)-RMS(3))**2
56218 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
56219 XLIM(2,1)=(RMS(2)+RMS(3))**2
56220 XLIM(2,2)=(RMS(0)-RMS(1))**2
56221 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
56222 XLIM(3,1)=(RMS(1)+RMS(3))**2
56223 XLIM(3,2)=(RMS(0)-RMS(2))**2
56224 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
56225C...Check Phase Space
56226 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
56227 RETURN
56228 ENDIF
56229
56230C...INITIALIZE RESONANCE INFORMATION
56231 DO 110 JRES = 1,3
56232 DO 100 IMASS = 1,2
56233 IRES = 2*(JRES-1)+IMASS
56234 INTRES(IRES,1) = 0
56235 DCHECK(IRES) =.FALSE.
56236C...NO RIGHT-HANDED NEUTRINOS
56237 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
56238 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
56239 & .KFR(JRES).EQ.0) GOTO 100
56240 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
56241 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
56242 INTRES(IRES,1) = IABS(KFR(JRES))
56243 INTRES(IRES,2) = IMASS
56244 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
56245 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
56246 100 CONTINUE
56247 110 CONTINUE
56248
56249C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
56250
56251C...RESONANCE CONTRIBUTIONS
56252C...(Only sum contributions where the resonance is off shell).
56253C...Store whether diagram on/off in DCHECK.
56254C...LOOP OVER MASS STATES
56255 DO 120 J=1,2
56256 IDR=J
56257 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56258 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
56259 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56260 DCHECK(IDR) =.TRUE.
56261 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
56262 ENDIF
56263
56264 IDR=J+2
56265 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56266 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56267 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56268 DCHECK(IDR) =.TRUE.
56269 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
56270 ENDIF
56271
56272 IDR=J+4
56273 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56274 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56275 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56276 DCHECK(IDR) =.TRUE.
56277 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
56278 ENDIF
56279 120 CONTINUE
56280C... L-R INTERFERENCES
56281C... (Only add contributions where both contributing diagrams
56282C... are non-resonant).
56283 IDR=1
56284 IF (DCHECK(1).AND.DCHECK(2)) THEN
56285C...Bug corrected 11/12 2001. Skands.
56286 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
56287 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
56288 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
56289 ENDIF
56290
56291 IDR=3
56292 IF (DCHECK(3).AND.DCHECK(4)) THEN
56293 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
56294 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
56295 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
56296 ENDIF
56297
56298 IDR=5
56299 IF (DCHECK(5).AND.DCHECK(6)) THEN
56300 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
56301 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
56302 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
56303 ENDIF
56304C... TRUE INTERFERENCES
56305C... (Only add contributions where both contributing diagrams
56306C... are non-resonant).
56307 PREF=-2D0
56308 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
56309 DO 140 IKR1 = 1,2
56310 DO 130 IKR2 = 1,2
56311 IDR = IKR1+2
56312 IDR2 = IKR2
56313 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56314 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
56315 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56316 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56317 ENDIF
56318
56319 IDR = IKR1+4
56320 IDR2 = IKR2
56321 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56322 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
56323 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56324 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56325 ENDIF
56326
56327 IDR = IKR1+4
56328 IDR2 = IKR2+2
56329 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56330 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
56331 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56332 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56333 ENDIF
56334 130 CONTINUE
56335 140 CONTINUE
56336
56337 RETURN
56338 END
56339
56340C*********************************************************************
56341
56342C...PYRVI1
56343C...Function to integrate resonance contributions
56344
56345 FUNCTION PYRVI1(ID1,ID2,ID3)
56346
56347 IMPLICIT NONE
56348 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
56349 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56350 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56351 LOGICAL MFLAG,DCMASS
56352 EXTERNAL PYRVG1,PYGAUS
56353 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56354 & ,DCMASS,KFR(3)
56355 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56356 SAVE/PYRVNV/,/PYRVPM/
56357C...Initialize mass and width information
56358 PYRVI1 = 0D0
56359 RM(0) = RMS(0)
56360 RM(1) = RMS(ID1)
56361 RM(2) = RMS(ID2)
56362 RM(3) = RMS(ID3)
56363 RESM(1)= RES(IDR,1)
56364 RESW(1)= RES(IDR,2)
56365C...A->B and B->A for antisparticles
56366 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56367 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56368C...Integration boundaries and mass flag
56369 LO = (RM(1)+RM(2))**2
56370 HI = (RM(0)-RM(3))**2
56371 MFLAG = DCMASS
56372 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
56373 RETURN
56374 END
56375
56376C*********************************************************************
56377
56378C...PYRVI2
56379C...Function to integrate L-R interference contributions
56380
56381 FUNCTION PYRVI2(ID1,ID2,ID3)
56382
56383 IMPLICIT NONE
56384 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
56385 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56386 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56387 LOGICAL MFLAG,DCMASS
56388 EXTERNAL PYRVG2,PYGAUS
56389 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56390 & ,DCMASS,KFR(3)
56391 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56392 SAVE/PYRVNV/,/PYRVPM/
56393C...Initialize mass and width information
56394 PYRVI2 = 0D0
56395 RM(0) = RMS(0)
56396 RM(1) = RMS(ID1)
56397 RM(2) = RMS(ID2)
56398 RM(3) = RMS(ID3)
56399 RESM(1)= RES(IDR,1)
56400 RESW(1)= RES(IDR,2)
56401 RESM(2)= RES(IDR+1,1)
56402 RESW(2)= RES(IDR+1,2)
56403C...A->B and B->A for antisparticles
56404 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56405 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56406 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56407 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56408C...Boundaries and mass flag
56409 LO = (RM(1)+RM(2))**2
56410 HI = (RM(0)-RM(3))**2
56411 MFLAG = DCMASS
56412 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
56413 RETURN
56414 END
56415
56416C*********************************************************************
56417
56418C...PYRVI3
56419C...Function to integrate true interference contributions
56420
56421 FUNCTION PYRVI3(ID1,ID2,ID3)
56422
56423 IMPLICIT NONE
56424 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
56425 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56426 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56427 LOGICAL MFLAG,DCMASS
56428 EXTERNAL PYRVG3,PYGAUS
56429 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56430 & ,DCMASS,KFR(3)
56431 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56432 SAVE/PYRVNV/,/PYRVPM/
56433C...Initialize mass and width information
56434 PYRVI3 = 0D0
56435 RM(0) = RMS(0)
56436 RM(1) = RMS(ID1)
56437 RM(2) = RMS(ID2)
56438 RM(3) = RMS(ID3)
56439 RESM(1)= RES(IDR,1)
56440 RESW(1)= RES(IDR,2)
56441 RESM(2)= RES(IDR2,1)
56442 RESW(2)= RES(IDR2,2)
56443C...A -> B and B -> A for antisparticles
56444 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56445 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56446 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56447 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56448C...Boundaries and mass flag
56449 LO = (RM(1)+RM(2))**2
56450 HI = (RM(0)-RM(3))**2
56451 MFLAG = DCMASS
56452 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
56453 RETURN
56454 END
56455
56456C*********************************************************************
56457
56458C...PYRVG1
56459C...Integrand for resonance contributions
56460
56461 FUNCTION PYRVG1(X)
56462
56463 IMPLICIT NONE
56464 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56465 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
56466 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
56467 LOGICAL MFLAG
56468 SAVE/PYRVPM/
56469 RVR = PYRVR(X,RESM(1),RESW(1))
56470 C1 = 2D0*SQRT(MAX(0D0,X))
56471 IF (.NOT.MFLAG) THEN
56472 E2 = X/C1
56473 E3 = (RM(0)**2-X)/C1
56474 DELTAY = 4D0*E2*E3
56475 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
56476 ELSE
56477 E2 = (X-RM(1)**2+RM(2)**2)/C1
56478 E3 = (RM(0)**2-X-RM(3)**2)/C1
56479 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56480 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56481 DELTAY = 4D0*SR1*SR2
56482 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
56483 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
56484 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
56485 ENDIF
56486 RETURN
56487 END
56488
56489C*********************************************************************
56490
56491C...PYRVG2
56492C...Integrand for L-R interference contributions
56493
56494 FUNCTION PYRVG2(X)
56495
56496 IMPLICIT NONE
56497 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56498 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
56499 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
56500 LOGICAL MFLAG
56501 SAVE/PYRVPM/
56502 C1 = 2D0*SQRT(MAX(0D0,X))
56503 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
56504 IF (.NOT.MFLAG) THEN
56505 E2 = X/C1
56506 E3 = (RM(0)**2-X)/C1
56507 DELTAY = 4D0*E2*E3
56508 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
56509 ELSE
56510 E2 = (X-RM(1)**2+RM(2)**2)/C1
56511 E3 = (RM(0)**2-X-RM(3)**2)/C1
56512 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56513 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56514 DELTAY = 4D0*SR1*SR2
56515 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
56516 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
56517 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
56518 ENDIF
56519 RETURN
56520 END
56521
56522C*********************************************************************
56523
56524C...PYRVG3
56525C...Function to do Y integration over true interference contributions
56526
56527 FUNCTION PYRVG3(X)
56528
56529 IMPLICIT NONE
56530 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56531C...Second Dalitz variable for PYRVG4
56532 COMMON/PYG2DX/X1
56533 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
56534 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
56535 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
56536 LOGICAL MFLAG
56537 EXTERNAL PYGAU2,PYRVG4
56538 SAVE/PYRVPM/,/PYG2DX/
56539 PYRVG3=0D0
56540 C1=2D0*SQRT(MAX(1D-9,X))
56541 X1=X
56542 IF (.NOT.MFLAG) THEN
56543 E2 = X/C1
56544 E3 = (RM(0)**2-X)/C1
56545 YMIN = 0D0
56546 YMAX = 4D0*E2*E3
56547 ELSE
56548 E2 = (X-RM(1)**2+RM(2)**2)/C1
56549 E3 = (RM(0)**2-X-RM(3)**2)/C1
56550 SQ1 = (E2+E3)**2
56551 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56552 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56553 YMIN = SQ1-(SR1+SR2)**2
56554 YMAX = SQ1-(SR1-SR2)**2
56555 ENDIF
56556 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
56557 RETURN
56558 END
56559
56560C*********************************************************************
56561
56562C...PYRVG4
56563C...Integrand for true intereference contributions
56564
56565 FUNCTION PYRVG4(Y)
56566
56567 IMPLICIT NONE
56568 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56569 COMMON/PYG2DX/X
56570 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
56571 LOGICAL MFLAG
56572 SAVE /PYRVPM/,/PYG2DX/
56573 PYRVG4=0D0
56574 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
56575 IF (.NOT.MFLAG) THEN
56576 PYRVG4 = RVS*B(1)*B(2)*X*Y
56577 ELSE
56578 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
56579 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
56580 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
56581 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
56582 ENDIF
56583 RETURN
56584 END
56585
56586C*********************************************************************
56587
56588C...PYRVR
56589C...Breit-Wigner for resonance contributions
56590
56591 FUNCTION PYRVR(Mab2,RM,RW)
56592
56593 IMPLICIT NONE
56594 DOUBLE PRECISION Mab2,RM,RW,PYRVR
56595 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
56596 RETURN
56597 END
56598
56599C*********************************************************************
56600
56601C...PYRVS
56602C...Interference function
56603
56604 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
56605
56606 IMPLICIT NONE
56607 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
56608 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
56609 & +W1*W2*M1*M2)
56610 RETURN
56611 END
56612
56613C*********************************************************************
56614
56615C...PY1ENT
56616C...Stores one parton/particle in commonblock PYJETS.
56617
56618 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
56619
56620C...Double precision and integer declarations.
56621 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56622 IMPLICIT INTEGER(I-N)
56623 INTEGER PYK,PYCHGE,PYCOMP
56624C...Commonblocks.
56625 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56626 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56627 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56628 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56629
56630C...Standard checks.
56631 MSTU(28)=0
56632 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56633 IPA=MAX(1,IABS(IP))
56634 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
56635 &'(PY1ENT:) writing outside PYJETS memory')
56636 KC=PYCOMP(KF)
56637 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
56638
56639C...Find mass. Reset K, P and V vectors.
56640 PM=0D0
56641 IF(MSTU(10).EQ.1) PM=P(IPA,5)
56642 IF(MSTU(10).GE.2) PM=PYMASS(KF)
56643 DO 100 J=1,5
56644 K(IPA,J)=0
56645 P(IPA,J)=0D0
56646 V(IPA,J)=0D0
56647 100 CONTINUE
56648
56649C...Store parton/particle in K and P vectors.
56650 K(IPA,1)=1
56651 IF(IP.LT.0) K(IPA,1)=2
56652 K(IPA,2)=KF
56653 P(IPA,5)=PM
56654 P(IPA,4)=MAX(PE,PM)
56655 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
56656 P(IPA,1)=PA*SIN(THE)*COS(PHI)
56657 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
56658 P(IPA,3)=PA*COS(THE)
56659
56660C...Set N. Optionally fragment/decay.
56661 N=IPA
56662 IF(IP.EQ.0) CALL PYEXEC
56663
56664 RETURN
56665 END
56666
56667C*********************************************************************
56668
56669C...PY2ENT
56670C...Stores two partons/particles in their CM frame,
56671C...with the first along the +z axis.
56672
56673 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
56674
56675C...Double precision and integer declarations.
56676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56677 IMPLICIT INTEGER(I-N)
56678 INTEGER PYK,PYCHGE,PYCOMP
56679C...Commonblocks.
56680 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56682 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56683 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56684
56685C...Standard checks.
56686 MSTU(28)=0
56687 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56688 IPA=MAX(1,IABS(IP))
56689 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
56690 &'(PY2ENT:) writing outside PYJETS memory')
56691 KC1=PYCOMP(KF1)
56692 KC2=PYCOMP(KF2)
56693 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
56694 &'(PY2ENT:) unknown flavour code')
56695
56696C...Find masses. Reset K, P and V vectors.
56697 PM1=0D0
56698 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56699 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56700 PM2=0D0
56701 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56702 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56703 DO 110 I=IPA,IPA+1
56704 DO 100 J=1,5
56705 K(I,J)=0
56706 P(I,J)=0D0
56707 V(I,J)=0D0
56708 100 CONTINUE
56709 110 CONTINUE
56710
56711C...Check flavours.
56712 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56713 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56714 IF(MSTU(19).EQ.1) THEN
56715 MSTU(19)=0
56716 ELSE
56717 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
56718 & '(PY2ENT:) unphysical flavour combination')
56719 ENDIF
56720 K(IPA,2)=KF1
56721 K(IPA+1,2)=KF2
56722
56723C...Store partons/particles in K vectors for normal case.
56724 IF(IP.GE.0) THEN
56725 K(IPA,1)=1
56726 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
56727 K(IPA+1,1)=1
56728
56729C...Store partons in K vectors for parton shower evolution.
56730 ELSE
56731 K(IPA,1)=3
56732 K(IPA+1,1)=3
56733 K(IPA,4)=MSTU(5)*(IPA+1)
56734 K(IPA,5)=K(IPA,4)
56735 K(IPA+1,4)=MSTU(5)*IPA
56736 K(IPA+1,5)=K(IPA+1,4)
56737 ENDIF
56738
56739C...Check kinematics and store partons/particles in P vectors.
56740 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
56741 &'(PY2ENT:) energy smaller than sum of masses')
56742 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
56743 &(2D0*PECM)
56744 P(IPA,3)=PA
56745 P(IPA,4)=SQRT(PM1**2+PA**2)
56746 P(IPA,5)=PM1
56747 P(IPA+1,3)=-PA
56748 P(IPA+1,4)=SQRT(PM2**2+PA**2)
56749 P(IPA+1,5)=PM2
56750
56751C...Set N. Optionally fragment/decay.
56752 N=IPA+1
56753 IF(IP.EQ.0) CALL PYEXEC
56754
56755 RETURN
56756 END
56757
56758C*********************************************************************
56759
56760C...PY3ENT
56761C...Stores three partons or particles in their CM frame,
56762C...with the first along the +z axis and the third in the (x,z)
56763C...plane with x > 0.
56764
56765 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
56766
56767C...Double precision and integer declarations.
56768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56769 IMPLICIT INTEGER(I-N)
56770 INTEGER PYK,PYCHGE,PYCOMP
56771C...Commonblocks.
56772 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56773 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56774 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56775 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56776
56777C...Standard checks.
56778 MSTU(28)=0
56779 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56780 IPA=MAX(1,IABS(IP))
56781 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
56782 &'(PY3ENT:) writing outside PYJETS memory')
56783 KC1=PYCOMP(KF1)
56784 KC2=PYCOMP(KF2)
56785 KC3=PYCOMP(KF3)
56786 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
56787 &'(PY3ENT:) unknown flavour code')
56788
56789C...Find masses. Reset K, P and V vectors.
56790 PM1=0D0
56791 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56792 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56793 PM2=0D0
56794 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56795 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56796 PM3=0D0
56797 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56798 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56799 DO 110 I=IPA,IPA+2
56800 DO 100 J=1,5
56801 K(I,J)=0
56802 P(I,J)=0D0
56803 V(I,J)=0D0
56804 100 CONTINUE
56805 110 CONTINUE
56806
56807C...Check flavours.
56808 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56809 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56810 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56811 IF(MSTU(19).EQ.1) THEN
56812 MSTU(19)=0
56813 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
56814 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
56815 & KQ1+KQ3.EQ.4)) THEN
56816 ELSE
56817 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
56818 ENDIF
56819 K(IPA,2)=KF1
56820 K(IPA+1,2)=KF2
56821 K(IPA+2,2)=KF3
56822
56823C...Store partons/particles in K vectors for normal case.
56824 IF(IP.GE.0) THEN
56825 K(IPA,1)=1
56826 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
56827 K(IPA+1,1)=1
56828 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
56829 K(IPA+2,1)=1
56830
56831C...Store partons in K vectors for parton shower evolution.
56832 ELSE
56833 K(IPA,1)=3
56834 K(IPA+1,1)=3
56835 K(IPA+2,1)=3
56836 KCS=4
56837 IF(KQ1.EQ.-1) KCS=5
56838 K(IPA,KCS)=MSTU(5)*(IPA+1)
56839 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
56840 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56841 K(IPA+1,9-KCS)=MSTU(5)*IPA
56842 K(IPA+2,KCS)=MSTU(5)*IPA
56843 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56844 ENDIF
56845
56846C...Check kinematics.
56847 MKERR=0
56848 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
56849 &0.5D0*X3*PECM.LE.PM3) MKERR=1
56850 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
56851 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
56852 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
56853 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
56854 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
56855 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
56856 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
56857 IF(MKERR.NE.0) CALL PYERRM(13,
56858 &'(PY3ENT:) unphysical kinematical variable setup')
56859
56860C...Store partons/particles in P vectors.
56861 P(IPA,3)=PA1
56862 P(IPA,4)=SQRT(PA1**2+PM1**2)
56863 P(IPA,5)=PM1
56864 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
56865 P(IPA+2,3)=PA3*CTHE3
56866 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
56867 P(IPA+2,5)=PM3
56868 P(IPA+1,1)=-P(IPA+2,1)
56869 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
56870 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
56871 P(IPA+1,5)=PM2
56872
56873C...Set N. Optionally fragment/decay.
56874 N=IPA+2
56875 IF(IP.EQ.0) CALL PYEXEC
56876
56877 RETURN
56878 END
56879
56880C*********************************************************************
56881
56882C...PY4ENT
56883C...Stores four partons or particles in their CM frame, with
56884C...the first along the +z axis, the last in the xz plane with x > 0
56885C...and the second having y < 0 and y > 0 with equal probability.
56886
56887 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
56888
56889C...Double precision and integer declarations.
56890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56891 IMPLICIT INTEGER(I-N)
56892 INTEGER PYK,PYCHGE,PYCOMP
56893C...Commonblocks.
56894 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56896 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56897 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56898
56899C...Standard checks.
56900 MSTU(28)=0
56901 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56902 IPA=MAX(1,IABS(IP))
56903 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
56904 &'(PY4ENT:) writing outside PYJETS momory')
56905 KC1=PYCOMP(KF1)
56906 KC2=PYCOMP(KF2)
56907 KC3=PYCOMP(KF3)
56908 KC4=PYCOMP(KF4)
56909 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
56910 &'(PY4ENT:) unknown flavour code')
56911
56912C...Find masses. Reset K, P and V vectors.
56913 PM1=0D0
56914 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56915 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56916 PM2=0D0
56917 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56918 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56919 PM3=0D0
56920 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56921 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56922 PM4=0D0
56923 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
56924 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
56925 DO 110 I=IPA,IPA+3
56926 DO 100 J=1,5
56927 K(I,J)=0
56928 P(I,J)=0D0
56929 V(I,J)=0D0
56930 100 CONTINUE
56931 110 CONTINUE
56932
56933C...Check flavours.
56934 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56935 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56936 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56937 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
56938 IF(MSTU(19).EQ.1) THEN
56939 MSTU(19)=0
56940 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
56941 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
56942 & KQ1+KQ4.EQ.4)) THEN
56943 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
56944 & THEN
56945 ELSE
56946 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
56947 ENDIF
56948 K(IPA,2)=KF1
56949 K(IPA+1,2)=KF2
56950 K(IPA+2,2)=KF3
56951 K(IPA+3,2)=KF4
56952
56953C...Store partons/particles in K vectors for normal case.
56954 IF(IP.GE.0) THEN
56955 K(IPA,1)=1
56956 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
56957 K(IPA+1,1)=1
56958 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
56959 & K(IPA+1,1)=2
56960 K(IPA+2,1)=1
56961 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
56962 K(IPA+3,1)=1
56963
56964C...Store partons for parton shower evolution from q-g-g-qbar or
56965C...g-g-g-g event.
56966 ELSEIF(KQ1+KQ2.NE.0) THEN
56967 K(IPA,1)=3
56968 K(IPA+1,1)=3
56969 K(IPA+2,1)=3
56970 K(IPA+3,1)=3
56971 KCS=4
56972 IF(KQ1.EQ.-1) KCS=5
56973 K(IPA,KCS)=MSTU(5)*(IPA+1)
56974 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
56975 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56976 K(IPA+1,9-KCS)=MSTU(5)*IPA
56977 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
56978 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56979 K(IPA+3,KCS)=MSTU(5)*IPA
56980 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
56981
56982C...Store partons for parton shower evolution from q-qbar-q-qbar event.
56983 ELSE
56984 K(IPA,1)=3
56985 K(IPA+1,1)=3
56986 K(IPA+2,1)=3
56987 K(IPA+3,1)=3
56988 K(IPA,4)=MSTU(5)*(IPA+1)
56989 K(IPA,5)=K(IPA,4)
56990 K(IPA+1,4)=MSTU(5)*IPA
56991 K(IPA+1,5)=K(IPA+1,4)
56992 K(IPA+2,4)=MSTU(5)*(IPA+3)
56993 K(IPA+2,5)=K(IPA+2,4)
56994 K(IPA+3,4)=MSTU(5)*(IPA+2)
56995 K(IPA+3,5)=K(IPA+3,4)
56996 ENDIF
56997
56998C...Check kinematics.
56999 MKERR=0
57000 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
57001 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
57002 &MKERR=1
57003 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
57004 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
57005 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
57006 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
57007 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
57008 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
57009 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
57010 STHE4=SQRT(1D0-CTHE4**2)
57011 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
57012 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
57013 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
57014 STHE2=SQRT(1D0-CTHE2**2)
57015 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
57016 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
57017 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
57018 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
57019 IF(MKERR.EQ.1) CALL PYERRM(13,
57020 &'(PY4ENT:) unphysical kinematical variable setup')
57021
57022C...Store partons/particles in P vectors.
57023 P(IPA,3)=PA1
57024 P(IPA,4)=SQRT(PA1**2+PM1**2)
57025 P(IPA,5)=PM1
57026 P(IPA+3,1)=PA4*STHE4
57027 P(IPA+3,3)=PA4*CTHE4
57028 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
57029 P(IPA+3,5)=PM4
57030 P(IPA+1,1)=PA2*STHE2*CPHI2
57031 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
57032 P(IPA+1,3)=PA2*CTHE2
57033 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
57034 P(IPA+1,5)=PM2
57035 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
57036 P(IPA+2,2)=-P(IPA+1,2)
57037 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
57038 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
57039 P(IPA+2,5)=PM3
57040
57041C...Set N. Optionally fragment/decay.
57042 N=IPA+3
57043 IF(IP.EQ.0) CALL PYEXEC
57044
57045 RETURN
57046 END
57047
57048C*********************************************************************
57049
57050C...PY2FRM
57051C...An interface from a two-fermion generator to include
57052C...parton showers and hadronization.
57053
57054 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
57055
57056C...Double precision and integer declarations.
57057 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57058 IMPLICIT INTEGER(I-N)
57059 INTEGER PYK,PYCHGE,PYCOMP
57060C...Commonblocks.
57061 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57063 SAVE /PYJETS/,/PYDAT1/
57064C...Local arrays.
57065 DIMENSION IJOIN(2),INTAU(2)
57066
57067C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57068 IF(ICOM.EQ.0) THEN
57069 MSTU(28)=0
57070 CALL PYHEPC(2)
57071 ENDIF
57072
57073C...Loop through entries and pick up all final fermions/antifermions.
57074 I1=0
57075 I2=0
57076 DO 100 I=1,N
57077 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57078 KFA=IABS(K(I,2))
57079 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57080 IF(K(I,2).GT.0) THEN
57081 IF(I1.EQ.0) THEN
57082 I1=I
57083 ELSE
57084 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
57085 ENDIF
57086 ELSE
57087 IF(I2.EQ.0) THEN
57088 I2=I
57089 ELSE
57090 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
57091 ENDIF
57092 ENDIF
57093 ENDIF
57094 100 CONTINUE
57095
57096C...Check that event is arranged according to conventions.
57097 IF(I1.EQ.0.OR.I2.EQ.0) THEN
57098 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
57099 ENDIF
57100 IF(I2.LT.I1) THEN
57101 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
57102 ENDIF
57103
57104C...Check whether fermion pair is quarks or leptons.
57105 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57106 IQL12=1
57107 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57108 IQL12=2
57109 ELSE
57110 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
57111 ENDIF
57112
57113C...Decide whether to allow or not photon radiation in showers.
57114 MSTJ(41)=2
57115 IF(IRAD.EQ.0) MSTJ(41)=1
57116
57117C...Do colour joining and parton showers.
57118 IP1=I1
57119 IP2=I2
57120 IF(IQL12.EQ.1) THEN
57121 IJOIN(1)=IP1
57122 IJOIN(2)=IP2
57123 CALL PYJOIN(2,IJOIN)
57124 ENDIF
57125 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57126 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57127 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57128 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57129 ENDIF
57130
57131C...Do fragmentation and decays. Possibly except tau decay.
57132 IF(ITAU.EQ.0) THEN
57133 NTAU=0
57134 DO 110 I=1,N
57135 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57136 NTAU=NTAU+1
57137 INTAU(NTAU)=I
57138 K(I,1)=11
57139 ENDIF
57140 110 CONTINUE
57141 ENDIF
57142 CALL PYEXEC
57143 IF(ITAU.EQ.0) THEN
57144 DO 120 I=1,NTAU
57145 K(INTAU(I),1)=1
57146 120 CONTINUE
57147 ENDIF
57148
57149C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57150 IF(ICOM.EQ.0) THEN
57151 MSTU(28)=0
57152 CALL PYHEPC(1)
57153 ENDIF
57154
57155 END
57156
57157C*********************************************************************
57158
57159C...PY4FRM
57160C...An interface from a four-fermion generator to include
57161C...parton showers and hadronization.
57162
57163 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
57164
57165C...Double precision and integer declarations.
57166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57167 IMPLICIT INTEGER(I-N)
57168 INTEGER PYK,PYCHGE,PYCOMP
57169C...Commonblocks.
57170 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57171 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57172 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57173 COMMON/PYINT1/MINT(400),VINT(400)
57174 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
57175C...Local arrays.
57176 DIMENSION IJOIN(2),INTAU(4)
57177
57178C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57179 IF(ICOM.EQ.0) THEN
57180 MSTU(28)=0
57181 CALL PYHEPC(2)
57182 ENDIF
57183
57184C...Loop through entries and pick up all final fermions/antifermions.
57185 I1=0
57186 I2=0
57187 I3=0
57188 I4=0
57189 DO 100 I=1,N
57190 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57191 KFA=IABS(K(I,2))
57192 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57193 IF(K(I,2).GT.0) THEN
57194 IF(I1.EQ.0) THEN
57195 I1=I
57196 ELSEIF(I3.EQ.0) THEN
57197 I3=I
57198 ELSE
57199 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
57200 ENDIF
57201 ELSE
57202 IF(I2.EQ.0) THEN
57203 I2=I
57204 ELSEIF(I4.EQ.0) THEN
57205 I4=I
57206 ELSE
57207 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
57208 ENDIF
57209 ENDIF
57210 ENDIF
57211 100 CONTINUE
57212
57213C...Check that event is arranged according to conventions.
57214 IF(I3.EQ.0.OR.I4.EQ.0) THEN
57215 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
57216 ENDIF
57217 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57218 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
57219 ENDIF
57220
57221C...Check which fermion pairs are quarks and which leptons.
57222 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57223 IQL12=1
57224 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57225 IQL12=2
57226 ELSE
57227 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
57228 ENDIF
57229 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57230 IQL34=1
57231 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57232 IQL34=2
57233 ELSE
57234 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
57235 ENDIF
57236
57237C...Decide whether to allow or not photon radiation in showers.
57238 MSTJ(41)=2
57239 IF(IRAD.EQ.0) MSTJ(41)=1
57240
57241C...Decide on dipole pairing.
57242 IP1=I1
57243 IP2=I2
57244 IP3=I3
57245 IP4=I4
57246 IF(IQL12.EQ.IQL34) THEN
57247 R1SQ=A1SQ
57248 R2SQ=A2SQ
57249 DELTA=ATOTSQ-A1SQ-A2SQ
57250 IF(ISTRAT.EQ.1) THEN
57251 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
57252 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
57253 ELSEIF(ISTRAT.EQ.2) THEN
57254 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
57255 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
57256 ENDIF
57257 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
57258 IP2=I4
57259 IP4=I2
57260 ENDIF
57261 ENDIF
57262
57263C...If colour reconnection then bookkeep W+W- or Z0Z0
57264C...and copy q qbar q qbar consecutively.
57265 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57266 K(N+1,1)=11
57267 K(N+1,3)=IP1
57268 K(N+1,4)=N+3
57269 K(N+1,5)=N+4
57270 K(N+2,1)=11
57271 K(N+2,3)=IP3
57272 K(N+2,4)=N+5
57273 K(N+2,5)=N+6
57274 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
57275 K(N+1,2)=23
57276 K(N+2,2)=23
57277 MINT(1)=22
57278 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
57279 K(N+1,2)=24
57280 K(N+2,2)=-24
57281 MINT(1)=25
57282 ELSE
57283 K(N+1,2)=-24
57284 K(N+2,2)=24
57285 MINT(1)=25
57286 ENDIF
57287 DO 110 J=1,5
57288 K(N+3,J)=K(IP1,J)
57289 K(N+4,J)=K(IP2,J)
57290 K(N+5,J)=K(IP3,J)
57291 K(N+6,J)=K(IP4,J)
57292 P(N+1,J)=P(IP1,J)+P(IP2,J)
57293 P(N+2,J)=P(IP3,J)+P(IP4,J)
57294 P(N+3,J)=P(IP1,J)
57295 P(N+4,J)=P(IP2,J)
57296 P(N+5,J)=P(IP3,J)
57297 P(N+6,J)=P(IP4,J)
57298 V(N+1,J)=V(IP1,J)
57299 V(N+2,J)=V(IP3,J)
57300 V(N+3,J)=V(IP1,J)
57301 V(N+4,J)=V(IP2,J)
57302 V(N+5,J)=V(IP3,J)
57303 V(N+6,J)=V(IP4,J)
57304 110 CONTINUE
57305 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57306 & P(N+1,3)**2))
57307 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57308 & P(N+2,3)**2))
57309 K(N+3,3)=N+1
57310 K(N+4,3)=N+1
57311 K(N+5,3)=N+2
57312 K(N+6,3)=N+2
57313C...Remove original q qbar q qbar and update counters.
57314 K(IP1,1)=K(IP1,1)+10
57315 K(IP2,1)=K(IP2,1)+10
57316 K(IP3,1)=K(IP3,1)+10
57317 K(IP4,1)=K(IP4,1)+10
57318 IW1=N+1
57319 IW2=N+2
57320 NSD1=N+2
57321 IP1=N+3
57322 IP2=N+4
57323 IP3=N+5
57324 IP4=N+6
57325 N=N+6
57326 ENDIF
57327
57328C...Do colour joinings and parton showers.
57329 IF(IQL12.EQ.1) THEN
57330 IJOIN(1)=IP1
57331 IJOIN(2)=IP2
57332 CALL PYJOIN(2,IJOIN)
57333 ENDIF
57334 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57335 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57336 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57337 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57338 ENDIF
57339 NAFT1=N
57340 IF(IQL34.EQ.1) THEN
57341 IJOIN(1)=IP3
57342 IJOIN(2)=IP4
57343 CALL PYJOIN(2,IJOIN)
57344 ENDIF
57345 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57346 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57347 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57348 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57349 ENDIF
57350
57351C...Optionally do colour reconnection.
57352 MINT(32)=0
57353 MSTI(32)=0
57354 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57355 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
57356 MSTI(32)=MINT(32)
57357 ENDIF
57358
57359C...Do fragmentation and decays. Possibly except tau decay.
57360 IF(ITAU.EQ.0) THEN
57361 NTAU=0
57362 DO 120 I=1,N
57363 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57364 NTAU=NTAU+1
57365 INTAU(NTAU)=I
57366 K(I,1)=11
57367 ENDIF
57368 120 CONTINUE
57369 ENDIF
57370 CALL PYEXEC
57371 IF(ITAU.EQ.0) THEN
57372 DO 130 I=1,NTAU
57373 K(INTAU(I),1)=1
57374 130 CONTINUE
57375 ENDIF
57376
57377C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57378 IF(ICOM.EQ.0) THEN
57379 MSTU(28)=0
57380 CALL PYHEPC(1)
57381 ENDIF
57382
57383 END
57384
57385C*********************************************************************
57386
57387C...PY6FRM
57388C...An interface from a six-fermion generator to include
57389C...parton showers and hadronization.
57390
57391 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
57392
57393C...Double precision and integer declarations.
57394 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57395 IMPLICIT INTEGER(I-N)
57396 INTEGER PYK,PYCHGE,PYCOMP
57397C...Commonblocks.
57398 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57399 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57400 SAVE /PYJETS/,/PYDAT1/
57401C...Local arrays.
57402 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
57403
57404C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57405 IF(ICOM.EQ.0) THEN
57406 MSTU(28)=0
57407 CALL PYHEPC(2)
57408 ENDIF
57409
57410C...Loop through entries and pick up all final fermions/antifermions.
57411 I1=0
57412 I2=0
57413 I3=0
57414 I4=0
57415 I5=0
57416 I6=0
57417 DO 100 I=1,N
57418 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57419 KFA=IABS(K(I,2))
57420 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57421 IF(K(I,2).GT.0) THEN
57422 IF(I1.EQ.0) THEN
57423 I1=I
57424 ELSEIF(I3.EQ.0) THEN
57425 I3=I
57426 ELSEIF(I5.EQ.0) THEN
57427 I5=I
57428 ELSE
57429 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
57430 ENDIF
57431 ELSE
57432 IF(I2.EQ.0) THEN
57433 I2=I
57434 ELSEIF(I4.EQ.0) THEN
57435 I4=I
57436 ELSEIF(I6.EQ.0) THEN
57437 I6=I
57438 ELSE
57439 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
57440 ENDIF
57441 ENDIF
57442 ENDIF
57443 100 CONTINUE
57444
57445C...Check that event is arranged according to conventions.
57446 IF(I5.EQ.0.OR.I6.EQ.0) THEN
57447 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
57448 ENDIF
57449 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
57450 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
57451 ENDIF
57452
57453C...Check which fermion pairs are quarks and which leptons.
57454 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57455 IQL12=1
57456 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57457 IQL12=2
57458 ELSE
57459 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
57460 ENDIF
57461 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57462 IQL34=1
57463 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57464 IQL34=2
57465 ELSE
57466 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
57467 ENDIF
57468 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
57469 IQL56=1
57470 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
57471 IQL56=2
57472 ELSE
57473 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
57474 ENDIF
57475
57476C...Decide whether to allow or not photon radiation in showers.
57477 MSTJ(41)=2
57478 IF(IRAD.EQ.0) MSTJ(41)=1
57479
57480C...Allow dipole pairings only among leptons and quarks separately.
57481 P12D=P12
57482 P13D=0D0
57483 IF(IQL34.EQ.IQL56) P13D=P13
57484 P21D=0D0
57485 IF(IQL12.EQ.IQL34) P21D=P21
57486 P23D=0D0
57487 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
57488 P31D=0D0
57489 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
57490 P32D=0D0
57491 IF(IQL12.EQ.IQL56) P32D=P32
57492
57493C...Decide whether t+tbar.
57494 ITOP=0
57495 IF(PYR(0).LT.PTOP) THEN
57496 ITOP=1
57497
57498C...If t+tbar: reconstruct t's.
57499 IT=N+1
57500 ITB=N+2
57501 DO 110 J=1,5
57502 K(IT,J)=0
57503 K(ITB,J)=0
57504 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
57505 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
57506 V(IT,J)=0D0
57507 V(ITB,J)=0D0
57508 110 CONTINUE
57509 K(IT,1)=1
57510 K(ITB,1)=1
57511 K(IT,2)=6
57512 K(ITB,2)=-6
57513 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
57514 & P(IT,3)**2))
57515 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
57516 & P(ITB,3)**2))
57517 N=N+2
57518
57519C...If t+tbar: colour join t's and let them shower.
57520 IJOIN(1)=IT
57521 IJOIN(2)=ITB
57522 CALL PYJOIN(2,IJOIN)
57523 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
57524 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
57525 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57526
57527C...If t+tbar: pick up the t's after shower.
57528 ITNEW=IT
57529 ITBNEW=ITB
57530 DO 120 I=ITB+1,N
57531 IF(K(I,2).EQ.6) ITNEW=I
57532 IF(K(I,2).EQ.-6) ITBNEW=I
57533 120 CONTINUE
57534
57535C...If t+tbar: loop over two top systems.
57536 DO 200 IT1=1,2
57537 IF(IT1.EQ.1) THEN
57538 ITO=IT
57539 ITN=ITNEW
57540 IBO=I1
57541 IW1=I3
57542 IW2=I4
57543 ELSE
57544 ITO=ITB
57545 ITN=ITBNEW
57546 IBO=I2
57547 IW1=I5
57548 IW2=I6
57549 ENDIF
57550 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
57551 & '(PY6FRM:) not b in t decay')
57552
57553C...If t+tbar: find boost from original to new top frame.
57554 DO 130 J=1,3
57555 BETAO(J)=P(ITO,J)/P(ITO,4)
57556 BETAN(J)=P(ITN,J)/P(ITN,4)
57557 130 CONTINUE
57558
57559C...If t+tbar: boost copy of b by t shower and connect it in colour.
57560 N=N+1
57561 IB=N
57562 K(IB,1)=3
57563 K(IB,2)=K(IBO,2)
57564 K(IB,3)=ITN
57565 DO 140 J=1,5
57566 P(IB,J)=P(IBO,J)
57567 V(IB,J)=0D0
57568 140 CONTINUE
57569 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57570 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57571 K(IB,4)=MSTU(5)*ITN
57572 K(IB,5)=MSTU(5)*ITN
57573 K(ITN,4)=K(ITN,4)+IB
57574 K(ITN,5)=K(ITN,5)+IB
57575 K(ITN,1)=K(ITN,1)+10
57576 K(IBO,1)=K(IBO,1)+10
57577
57578C...If t+tbar: construct W recoiling against b.
57579 N=N+1
57580 IW=N
57581 DO 150 J=1,5
57582 K(IW,J)=0
57583 V(IW,J)=0D0
57584 150 CONTINUE
57585 K(IW,1)=1
57586 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
57587 IF(IABS(KCHW).EQ.3) THEN
57588 K(IW,2)=ISIGN(24,KCHW)
57589 ELSE
57590 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
57591 ENDIF
57592 K(IW,3)=IW1
57593
57594C...If t+tbar: construct W momentum, including boost by t shower.
57595 DO 160 J=1,4
57596 P(IW,J)=P(IW1,J)+P(IW2,J)
57597 160 CONTINUE
57598 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
57599 & P(IW,3)**2))
57600 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57601 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57602
57603C...If t+tbar: boost b and W to top rest frame.
57604 DO 170 J=1,3
57605 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
57606 170 CONTINUE
57607 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57608 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57609
57610C...If t+tbar: let b shower and pick up modified W.
57611 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
57612 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
57613 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
57614 DO 180 I=IW,N
57615 IF(IABS(K(I,2)).EQ.24) IWM=I
57616 180 CONTINUE
57617
57618C...If t+tbar: take copy of W decay products.
57619 DO 190 J=1,5
57620 K(N+1,J)=K(IW1,J)
57621 P(N+1,J)=P(IW1,J)
57622 V(N+1,J)=V(IW1,J)
57623 K(N+2,J)=K(IW2,J)
57624 P(N+2,J)=P(IW2,J)
57625 V(N+2,J)=V(IW2,J)
57626 190 CONTINUE
57627 K(IW1,1)=K(IW1,1)+10
57628 K(IW2,1)=K(IW2,1)+10
57629 K(IWM,1)=K(IWM,1)+10
57630 K(IWM,4)=N+1
57631 K(IWM,5)=N+2
57632 K(N+1,3)=IWM
57633 K(N+2,3)=IWM
57634 IF(IT1.EQ.1) THEN
57635 I3=N+1
57636 I4=N+2
57637 ELSE
57638 I5=N+1
57639 I6=N+2
57640 ENDIF
57641 N=N+2
57642
57643C...If t+tbar: boost W decay products, first by effects of t shower,
57644C...then by those of b shower. b and its shower simple boost back.
57645 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57646 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57647 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57648 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
57649 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
57650 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
57651 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
57652 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
57653 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
57654 200 CONTINUE
57655 ENDIF
57656
57657C...Decide on dipole pairing.
57658 IP1=I1
57659 IP3=I3
57660 IP5=I5
57661 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
57662 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
57663 IP2=I2
57664 IP4=I4
57665 IP6=I6
57666 ELSEIF(PRN.LT.P12D+P13D) THEN
57667 IP2=I2
57668 IP4=I6
57669 IP6=I4
57670 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
57671 IP2=I4
57672 IP4=I2
57673 IP6=I6
57674 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
57675 IP2=I4
57676 IP4=I6
57677 IP6=I2
57678 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
57679 IP2=I6
57680 IP4=I2
57681 IP6=I4
57682 ELSE
57683 IP2=I6
57684 IP4=I4
57685 IP6=I2
57686 ENDIF
57687
57688C...Do colour joinings and parton showers
57689C...(except ones already made for t+tbar).
57690 IF(ITOP.EQ.0) THEN
57691 IF(IQL12.EQ.1) THEN
57692 IJOIN(1)=IP1
57693 IJOIN(2)=IP2
57694 CALL PYJOIN(2,IJOIN)
57695 ENDIF
57696 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57697 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57698 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57699 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57700 ENDIF
57701 ENDIF
57702 IF(IQL34.EQ.1) THEN
57703 IJOIN(1)=IP3
57704 IJOIN(2)=IP4
57705 CALL PYJOIN(2,IJOIN)
57706 ENDIF
57707 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57708 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57709 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57710 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57711 ENDIF
57712 IF(IQL56.EQ.1) THEN
57713 IJOIN(1)=IP5
57714 IJOIN(2)=IP6
57715 CALL PYJOIN(2,IJOIN)
57716 ENDIF
57717 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
57718 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
57719 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
57720 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57721 ENDIF
57722
57723C...Do fragmentation and decays. Possibly except tau decay.
57724 IF(ITAU.EQ.0) THEN
57725 NTAU=0
57726 DO 210 I=1,N
57727 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57728 NTAU=NTAU+1
57729 INTAU(NTAU)=I
57730 K(I,1)=11
57731 ENDIF
57732 210 CONTINUE
57733 ENDIF
57734 CALL PYEXEC
57735 IF(ITAU.EQ.0) THEN
57736 DO 220 I=1,NTAU
57737 K(INTAU(I),1)=1
57738 220 CONTINUE
57739 ENDIF
57740
57741C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57742 IF(ICOM.EQ.0) THEN
57743 MSTU(28)=0
57744 CALL PYHEPC(1)
57745 ENDIF
57746
57747 END
57748
57749C*********************************************************************
57750
57751C...PY4JET
57752C...An interface from a four-parton generator to include
57753C...parton showers and hadronization.
57754
57755 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
57756
57757C...Double precision and integer declarations.
57758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57759 IMPLICIT INTEGER(I-N)
57760 INTEGER PYK,PYCHGE,PYCOMP
57761C...Commonblocks.
57762 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57763 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57764 SAVE /PYJETS/,/PYDAT1/
57765C...Local arrays.
57766 DIMENSION IJOIN(2),PTOT(4),BETA(3)
57767
57768C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57769 IF(ICOM.EQ.0) THEN
57770 MSTU(28)=0
57771 CALL PYHEPC(2)
57772 ENDIF
57773
57774C...Loop through entries and pick up all final partons.
57775 I1=0
57776 I2=0
57777 I3=0
57778 I4=0
57779 DO 100 I=1,N
57780 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57781 KFA=IABS(K(I,2))
57782 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
57783 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
57784 IF(I1.EQ.0) THEN
57785 I1=I
57786 ELSEIF(I3.EQ.0) THEN
57787 I3=I
57788 ELSE
57789 CALL PYERRM(16,'(PY4JET:) more than two quarks')
57790 ENDIF
57791 ELSEIF(K(I,2).LT.0) THEN
57792 IF(I2.EQ.0) THEN
57793 I2=I
57794 ELSEIF(I4.EQ.0) THEN
57795 I4=I
57796 ELSE
57797 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
57798 ENDIF
57799 ELSE
57800 IF(I3.EQ.0) THEN
57801 I3=I
57802 ELSEIF(I4.EQ.0) THEN
57803 I4=I
57804 ELSE
57805 CALL PYERRM(16,'(PY4JET:) more than two gluons')
57806 ENDIF
57807 ENDIF
57808 ENDIF
57809 100 CONTINUE
57810
57811C...Check that event is arranged according to conventions.
57812 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
57813 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
57814 ENDIF
57815 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57816 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
57817 ENDIF
57818
57819C...Check whether second pair are quarks or gluons.
57820 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57821 IQG34=1
57822 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
57823 IQG34=2
57824 ELSE
57825 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
57826 ENDIF
57827
57828C...Boost partons to their cm frame.
57829 DO 110 J=1,4
57830 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
57831 110 CONTINUE
57832 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
57833 DO 120 J=1,3
57834 BETA(J)=PTOT(J)/PTOT(4)
57835 120 CONTINUE
57836 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57837 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57838 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57839 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57840 NSAV=N
57841
57842C...Decide and set up shower history for q qbar q' qbar' events.
57843 IF(IQG34.EQ.1) THEN
57844 W1=PY4JTW(0,I1,I3,I4)
57845 W2=PY4JTW(0,I2,I3,I4)
57846 IF(W1.GT.PYR(0)*(W1+W2)) THEN
57847 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57848 ELSE
57849 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57850 ENDIF
57851
57852C...Decide and set up shower history for q qbar g g events.
57853 ELSE
57854 W1=PY4JTW(I1,I3,I2,I4)
57855 W2=PY4JTW(I1,I4,I2,I3)
57856 W3=PY4JTW(0,I3,I1,I4)
57857 W4=PY4JTW(0,I4,I1,I3)
57858 W5=PY4JTW(0,I3,I2,I4)
57859 W6=PY4JTW(0,I4,I2,I3)
57860 W7=PY4JTW(0,I1,I3,I4)
57861 W8=PY4JTW(0,I2,I3,I4)
57862 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
57863 IF(W1.GT.WR) THEN
57864 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
57865 ELSEIF(W1+W2.GT.WR) THEN
57866 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
57867 ELSEIF(W1+W2+W3.GT.WR) THEN
57868 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
57869 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
57870 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
57871 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
57872 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
57873 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
57874 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
57875 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
57876 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57877 ELSE
57878 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57879 ENDIF
57880 ENDIF
57881
57882C...Boost back original partons and mark them as deleted.
57883 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
57884 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
57885 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
57886 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
57887 K(I1,1)=K(I1,1)+10
57888 K(I2,1)=K(I2,1)+10
57889 K(I3,1)=K(I3,1)+10
57890 K(I4,1)=K(I4,1)+10
57891
57892C...Rotate shower initiating partons to be along z axis.
57893 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
57894 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
57895 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
57896 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
57897
57898C...Set up copy of shower initiating partons as on mass shell.
57899 DO 140 I=N+1,N+2
57900 DO 130 J=1,5
57901 K(I,J)=0
57902 P(I,J)=0D0
57903 V(I,J)=V(I1,J)
57904 130 CONTINUE
57905 K(I,1)=1
57906 K(I,2)=K(I-6,2)
57907 140 CONTINUE
57908 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
57909 K(N+1,3)=I1
57910 P(N+1,5)=P(I1,5)
57911 K(N+2,3)=I2
57912 P(N+2,5)=P(I2,5)
57913 ELSE
57914 K(N+1,3)=I2
57915 P(N+1,5)=P(I2,5)
57916 K(N+2,3)=I1
57917 P(N+2,5)=P(I1,5)
57918 ENDIF
57919 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
57920 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
57921 P(N+1,3)=PABS
57922 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
57923 P(N+2,3)=-PABS
57924 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
57925 N=N+2
57926
57927C...Decide whether to allow or not photon radiation in showers.
57928C...Connect up colours.
57929 MSTJ(41)=2
57930 IF(IRAD.EQ.0) MSTJ(41)=1
57931 IJOIN(1)=N-1
57932 IJOIN(2)=N
57933 CALL PYJOIN(2,IJOIN)
57934
57935C...Decide on maximum virtuality and do parton shower.
57936 IF(PMAX.LT.PARJ(82)) THEN
57937 PQMAX=QMAX
57938 ELSE
57939 PQMAX=PMAX
57940 ENDIF
57941 CALL PYSHOW(NSAV+1,-100,PQMAX)
57942
57943C...Rotate and boost back system.
57944 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
57945
57946C...Do fragmentation and decays.
57947 CALL PYEXEC
57948
57949C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57950 IF(ICOM.EQ.0) THEN
57951 MSTU(28)=0
57952 CALL PYHEPC(1)
57953 ENDIF
57954
57955 RETURN
57956 END
57957
57958C*********************************************************************
57959
57960C...PY4JTW
57961C...Auxiliary to PY4JET, to evaluate weight of configuration.
57962
57963 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
57964
57965C...Double precision and integer declarations.
57966 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57967 IMPLICIT INTEGER(I-N)
57968 INTEGER PYK,PYCHGE,PYCOMP
57969C...Commonblocks.
57970 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57971 SAVE /PYJETS/
57972
57973C...First case: when both original partons radiate.
57974C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
57975 IF(IA1.NE.0) THEN
57976 DO 100 J=1,4
57977 P(N+1,J)=P(IA1,J)+P(IA2,J)
57978 P(N+2,J)=P(IA3,J)+P(IA4,J)
57979 100 CONTINUE
57980 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57981 & P(N+1,3)**2))
57982 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57983 & P(N+2,3)**2))
57984 Z1=P(IA1,4)/P(N+1,4)
57985 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
57986 Z2=P(IA3,4)/P(N+2,4)
57987 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
57988
57989C...Second case: when one original parton radiates to three.
57990C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
57991 ELSE
57992 DO 110 J=1,4
57993 P(N+2,J)=P(IA3,J)+P(IA4,J)
57994 P(N+1,J)=P(N+2,J)+P(IA2,J)
57995 110 CONTINUE
57996 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57997 & P(N+1,3)**2))
57998 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57999 & P(N+2,3)**2))
58000 IF(K(IA2,2).EQ.21) THEN
58001 Z1=P(N+2,4)/P(N+1,4)
58002 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58003 & P(IA3,5)**2)
58004 ELSE
58005 Z1=P(IA2,4)/P(N+1,4)
58006 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58007 & P(IA2,5)**2)
58008 ENDIF
58009 Z2=P(IA3,4)/P(N+2,4)
58010 IF(K(IA2,2).EQ.21) THEN
58011 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
58012 & P(IA3,5)**2)
58013 ELSEIF(K(IA3,2).EQ.21) THEN
58014 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
58015 ELSE
58016 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
58017 ENDIF
58018 ENDIF
58019
58020C...Total weight.
58021 PY4JTW=WT1*WT2
58022
58023 RETURN
58024 END
58025
58026C*********************************************************************
58027
58028C...PY4JTS
58029C...Auxiliary to PY4JET, to set up chosen configuration.
58030
58031 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
58032
58033C...Double precision and integer declarations.
58034 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58035 IMPLICIT INTEGER(I-N)
58036 INTEGER PYK,PYCHGE,PYCOMP
58037C...Commonblocks.
58038 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58039 SAVE /PYJETS/
58040
58041C...Reset info.
58042 DO 110 I=N+1,N+6
58043 DO 100 J=1,5
58044 K(I,J)=0
58045 V(I,J)=V(IA2,J)
58046 100 CONTINUE
58047 K(I,1)=16
58048 110 CONTINUE
58049
58050C...First case: when both original partons radiate.
58051C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
58052 IF(IA1.NE.0) THEN
58053
58054C...Set up flavour and history pointers for new partons.
58055 K(N+1,2)=K(IA1,2)
58056 K(N+2,2)=K(IA3,2)
58057 K(N+3,2)=K(IA1,2)
58058 K(N+4,2)=K(IA2,2)
58059 K(N+5,2)=K(IA3,2)
58060 K(N+6,2)=K(IA4,2)
58061 K(N+1,3)=IA1
58062 K(N+1,4)=N+3
58063 K(N+1,5)=N+4
58064 K(N+2,3)=IA3
58065 K(N+2,4)=N+5
58066 K(N+2,5)=N+6
58067 K(N+3,3)=N+1
58068 K(N+4,3)=N+1
58069 K(N+5,3)=N+2
58070 K(N+6,3)=N+2
58071
58072C...Set up momenta for new partons.
58073 DO 120 J=1,5
58074 P(N+1,J)=P(IA1,J)+P(IA2,J)
58075 P(N+2,J)=P(IA3,J)+P(IA4,J)
58076 P(N+3,J)=P(IA1,J)
58077 P(N+4,J)=P(IA2,J)
58078 P(N+5,J)=P(IA3,J)
58079 P(N+6,J)=P(IA4,J)
58080 120 CONTINUE
58081 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58082 & P(N+1,3)**2))
58083 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58084 & P(N+2,3)**2))
58085 QMAX=MIN(P(N+1,5),P(N+2,5))
58086
58087C...Second case: q radiates twice.
58088C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
58089C...IA5=N+2 does not radiate.
58090 ELSEIF(K(IA2,2).EQ.21) THEN
58091
58092C...Set up flavour and history pointers for new partons.
58093 K(N+1,2)=K(IA3,2)
58094 K(N+2,2)=K(IA5,2)
58095 K(N+3,2)=K(IA3,2)
58096 K(N+4,2)=K(IA2,2)
58097 K(N+5,2)=K(IA3,2)
58098 K(N+6,2)=K(IA4,2)
58099 K(N+1,3)=IA3
58100 K(N+1,4)=N+3
58101 K(N+1,5)=N+4
58102 K(N+2,3)=IA5
58103 K(N+3,3)=N+1
58104 K(N+3,4)=N+5
58105 K(N+3,5)=N+6
58106 K(N+4,3)=N+1
58107 K(N+5,3)=N+3
58108 K(N+6,3)=N+3
58109
58110C...Set up momenta for new partons.
58111 DO 130 J=1,5
58112 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58113 P(N+2,J)=P(IA5,J)
58114 P(N+3,J)=P(IA3,J)+P(IA4,J)
58115 P(N+4,J)=P(IA2,J)
58116 P(N+5,J)=P(IA3,J)
58117 P(N+6,J)=P(IA4,J)
58118 130 CONTINUE
58119 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58120 & P(N+1,3)**2))
58121 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
58122 & P(N+3,3)**2))
58123 QMAX=P(N+3,5)
58124
58125C...Third case: q radiates g, g branches.
58126C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
58127C...IA5=N+2 does not radiate.
58128 ELSE
58129
58130C...Set up flavour and history pointers for new partons.
58131 K(N+1,2)=K(IA2,2)
58132 K(N+2,2)=K(IA5,2)
58133 K(N+3,2)=K(IA2,2)
58134 K(N+4,2)=21
58135 K(N+5,2)=K(IA3,2)
58136 K(N+6,2)=K(IA4,2)
58137 K(N+1,3)=IA2
58138 K(N+1,4)=N+3
58139 K(N+1,5)=N+4
58140 K(N+2,3)=IA5
58141 K(N+3,3)=N+1
58142 K(N+4,3)=N+1
58143 K(N+4,4)=N+5
58144 K(N+4,5)=N+6
58145 K(N+5,3)=N+4
58146 K(N+6,3)=N+4
58147
58148C...Set up momenta for new partons.
58149 DO 140 J=1,5
58150 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58151 P(N+2,J)=P(IA5,J)
58152 P(N+3,J)=P(IA2,J)
58153 P(N+4,J)=P(IA3,J)+P(IA4,J)
58154 P(N+5,J)=P(IA3,J)
58155 P(N+6,J)=P(IA4,J)
58156 140 CONTINUE
58157 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58158 & P(N+1,3)**2))
58159 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
58160 & P(N+4,3)**2))
58161 QMAX=P(N+4,5)
58162
58163 ENDIF
58164 N=N+6
58165
58166 RETURN
58167 END
58168
58169C*********************************************************************
58170
58171C...PYJOIN
58172C...Connects a sequence of partons with colour flow indices,
58173C...as required for subsequent shower evolution (or other operations).
58174
58175 SUBROUTINE PYJOIN(NJOIN,IJOIN)
58176
58177C...Double precision and integer declarations.
58178 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58179 IMPLICIT INTEGER(I-N)
58180 INTEGER PYK,PYCHGE,PYCOMP
58181C...Commonblocks.
58182 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58183 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58184 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58185 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58186C...Local array.
58187 DIMENSION IJOIN(*)
58188
58189C...Check that partons are of right types to be connected.
58190 IF(NJOIN.LT.2) GOTO 120
58191 KQSUM=0
58192 DO 100 IJN=1,NJOIN
58193 I=IJOIN(IJN)
58194 IF(I.LE.0.OR.I.GT.N) GOTO 120
58195 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
58196 KC=PYCOMP(K(I,2))
58197 IF(KC.EQ.0) GOTO 120
58198 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
58199 IF(KQ.EQ.0) GOTO 120
58200 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
58201 IF(KQ.NE.2) KQSUM=KQSUM+KQ
58202 IF(IJN.EQ.1) KQS=KQ
58203 100 CONTINUE
58204 IF(KQSUM.NE.0) GOTO 120
58205
58206C...Connect the partons sequentially (closing for gluon loop).
58207 KCS=(9-KQS)/2
58208 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
58209 DO 110 IJN=1,NJOIN
58210 I=IJOIN(IJN)
58211 K(I,1)=3
58212 IF(IJN.NE.1) IP=IJOIN(IJN-1)
58213 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
58214 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
58215 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
58216 K(I,KCS)=MSTU(5)*IN
58217 K(I,9-KCS)=MSTU(5)*IP
58218 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
58219 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
58220 110 CONTINUE
58221
58222C...Error exit: no action taken.
58223 RETURN
58224 120 CALL PYERRM(12,
58225 &'(PYJOIN:) given entries can not be joined by one string')
58226
58227 RETURN
58228 END
58229
58230C*********************************************************************
58231
58232C...PYGIVE
58233C...Sets values of commonblock variables.
58234
58235 SUBROUTINE PYGIVE(CHIN)
58236
58237C...Double precision and integer declarations.
58238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58239 IMPLICIT INTEGER(I-N)
58240 INTEGER PYK,PYCHGE,PYCOMP
58241C...Commonblocks.
58242 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58243 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58244 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58245 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58246 COMMON/PYDAT4/CHAF(500,2)
58247 CHARACTER CHAF*16
58248 COMMON/PYDATR/MRPY(6),RRPY(100)
58249 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
58250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58251 COMMON/PYINT1/MINT(400),VINT(400)
58252 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
58253 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
58254 COMMON/PYINT4/MWID(500),WIDS(500,5)
58255 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
58256 COMMON/PYINT6/PROC(0:500)
58257 CHARACTER PROC*28
58258 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
58259 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
58260 &XPDIR(-6:6)
58261 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58262 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58263 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
58264 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
58265 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
58266 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
58267C...Local arrays and character variables.
58268 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
58269 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
58270 &CHINR*16,CHDIG*10
58271 DIMENSION MSVAR(54,8)
58272
58273C...For each variable to be translated give: name,
58274C...integer/real/character, no. of indices, lower&upper index bounds.
58275 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
58276 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
58277 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
58278 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
58279 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
58280 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
58281 &'ITCM','RTCM'/
58282 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
58283 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
58284 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58285 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
58286 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
58287 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
58288 &1,1,1,6,4*0, 2,1,1,100,4*0,
58289 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
58290 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58291 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
58292 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
58293 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
58294 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
58295 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
58296 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
58297 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
58298 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
58299 &1,1,0,99,4*0, 2,1,0,99,4*0/
58300 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58301 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
58302
58303C...Length of character variable. Subdivide it into instructions.
58304 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
58305 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
58306 CHBIT=CHIN//' '
58307 LBIT=101
58308 100 LBIT=LBIT-1
58309 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
58310 LTOT=0
58311 DO 110 LCOM=1,LBIT
58312 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
58313 LTOT=LTOT+1
58314 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
58315 110 CONTINUE
58316 LLOW=0
58317 120 LHIG=LLOW+1
58318 130 LHIG=LHIG+1
58319 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
58320 LBIT=LHIG-LLOW-1
58321 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
58322
58323C...Send off decay-mode on/off commands to PYONOF.
58324 IONOF=0
58325 DO 135 LDIG=1,10
58326 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
58327 135 CONTINUE
58328 IF(IONOF.EQ.1) THEN
58329 CALL PYONOF(CHIN)
58330 RETURN
58331 ENDIF
58332
58333C...Peel off any text following exclamation mark.
58334 LHIG2=LBIT
58335 DO 140 LLOW2=LHIG2,1,-1
58336 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
58337 140 CONTINUE
58338 IF(LBIT.EQ.0) RETURN
58339
58340C...Identify commonblock variable.
58341 LNAM=1
58342 150 LNAM=LNAM+1
58343 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
58344 &LNAM.LE.6) GOTO 150
58345 CHNAM=CHBIT(1:LNAM-1)//' '
58346 DO 170 LCOM=1,LNAM-1
58347 DO 160 LALP=1,26
58348 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
58349 & CHALP(2)(LALP:LALP)
58350 160 CONTINUE
58351 170 CONTINUE
58352 IVAR=0
58353 DO 180 IV=1,54
58354 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
58355 180 CONTINUE
58356 IF(IVAR.EQ.0) THEN
58357 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
58358 LLOW=LHIG
58359 IF(LLOW.LT.LTOT) GOTO 120
58360 RETURN
58361 ENDIF
58362
58363C...Identify any indices.
58364 I1=0
58365 I2=0
58366 I3=0
58367 NINDX=0
58368 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
58369 LIND=LNAM
58370 190 LIND=LIND+1
58371 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
58372 CHIND=' '
58373 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
58374 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
58375 & IVAR.EQ.37)) THEN
58376 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
58377 READ(CHIND,'(I8)') KF
58378 I1=PYCOMP(KF)
58379 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
58380 & 'c') THEN
58381 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
58382 & CHNAM)
58383 LLOW=LHIG
58384 IF(LLOW.LT.LTOT) GOTO 120
58385 RETURN
58386 ELSE
58387 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58388 READ(CHIND,'(I8)') I1
58389 ENDIF
58390 LNAM=LIND
58391 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58392 NINDX=1
58393 ENDIF
58394 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58395 LIND=LNAM
58396 200 LIND=LIND+1
58397 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
58398 CHIND=' '
58399 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58400 READ(CHIND,'(I8)') I2
58401 LNAM=LIND
58402 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58403 NINDX=2
58404 ENDIF
58405 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58406 LIND=LNAM
58407 210 LIND=LIND+1
58408 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
58409 CHIND=' '
58410 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58411 READ(CHIND,'(I8)') I3
58412 LNAM=LIND+1
58413 NINDX=3
58414 ENDIF
58415
58416C...Check that indices allowed.
58417 IERR=0
58418 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
58419 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
58420 &IERR=2
58421 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
58422 &IERR=3
58423 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
58424 &IERR=4
58425 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
58426 IF(IERR.GE.1) THEN
58427 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
58428 & CHBIT(1:LNAM-1))
58429 LLOW=LHIG
58430 IF(LLOW.LT.LTOT) GOTO 120
58431 RETURN
58432 ENDIF
58433
58434C...Save old value of variable.
58435 IF(IVAR.EQ.1) THEN
58436 IOLD=N
58437 ELSEIF(IVAR.EQ.2) THEN
58438 IOLD=K(I1,I2)
58439 ELSEIF(IVAR.EQ.3) THEN
58440 ROLD=P(I1,I2)
58441 ELSEIF(IVAR.EQ.4) THEN
58442 ROLD=V(I1,I2)
58443 ELSEIF(IVAR.EQ.5) THEN
58444 IOLD=MSTU(I1)
58445 ELSEIF(IVAR.EQ.6) THEN
58446 ROLD=PARU(I1)
58447 ELSEIF(IVAR.EQ.7) THEN
58448 IOLD=MSTJ(I1)
58449 ELSEIF(IVAR.EQ.8) THEN
58450 ROLD=PARJ(I1)
58451 ELSEIF(IVAR.EQ.9) THEN
58452 IOLD=KCHG(I1,I2)
58453 ELSEIF(IVAR.EQ.10) THEN
58454 ROLD=PMAS(I1,I2)
58455 ELSEIF(IVAR.EQ.11) THEN
58456 ROLD=PARF(I1)
58457 ELSEIF(IVAR.EQ.12) THEN
58458 ROLD=VCKM(I1,I2)
58459 ELSEIF(IVAR.EQ.13) THEN
58460 IOLD=MDCY(I1,I2)
58461 ELSEIF(IVAR.EQ.14) THEN
58462 IOLD=MDME(I1,I2)
58463 ELSEIF(IVAR.EQ.15) THEN
58464 ROLD=BRAT(I1)
58465 ELSEIF(IVAR.EQ.16) THEN
58466 IOLD=KFDP(I1,I2)
58467 ELSEIF(IVAR.EQ.17) THEN
58468 CHOLD=CHAF(I1,I2)(1:8)
58469 ELSEIF(IVAR.EQ.18) THEN
58470 IOLD=MRPY(I1)
58471 ELSEIF(IVAR.EQ.19) THEN
58472 ROLD=RRPY(I1)
58473 ELSEIF(IVAR.EQ.20) THEN
58474 IOLD=MSEL
58475 ELSEIF(IVAR.EQ.21) THEN
58476 IOLD=MSUB(I1)
58477 ELSEIF(IVAR.EQ.22) THEN
58478 IOLD=KFIN(I1,I2)
58479 ELSEIF(IVAR.EQ.23) THEN
58480 ROLD=CKIN(I1)
58481 ELSEIF(IVAR.EQ.24) THEN
58482 IOLD=MSTP(I1)
58483 ELSEIF(IVAR.EQ.25) THEN
58484 ROLD=PARP(I1)
58485 ELSEIF(IVAR.EQ.26) THEN
58486 IOLD=MSTI(I1)
58487 ELSEIF(IVAR.EQ.27) THEN
58488 ROLD=PARI(I1)
58489 ELSEIF(IVAR.EQ.28) THEN
58490 IOLD=MINT(I1)
58491 ELSEIF(IVAR.EQ.29) THEN
58492 ROLD=VINT(I1)
58493 ELSEIF(IVAR.EQ.30) THEN
58494 IOLD=ISET(I1)
58495 ELSEIF(IVAR.EQ.31) THEN
58496 IOLD=KFPR(I1,I2)
58497 ELSEIF(IVAR.EQ.32) THEN
58498 ROLD=COEF(I1,I2)
58499 ELSEIF(IVAR.EQ.33) THEN
58500 IOLD=ICOL(I1,I2,I3)
58501 ELSEIF(IVAR.EQ.34) THEN
58502 ROLD=XSFX(I1,I2)
58503 ELSEIF(IVAR.EQ.35) THEN
58504 IOLD=ISIG(I1,I2)
58505 ELSEIF(IVAR.EQ.36) THEN
58506 ROLD=SIGH(I1)
58507 ELSEIF(IVAR.EQ.37) THEN
58508 IOLD=MWID(I1)
58509 ELSEIF(IVAR.EQ.38) THEN
58510 ROLD=WIDS(I1,I2)
58511 ELSEIF(IVAR.EQ.39) THEN
58512 IOLD=NGEN(I1,I2)
58513 ELSEIF(IVAR.EQ.40) THEN
58514 ROLD=XSEC(I1,I2)
58515 ELSEIF(IVAR.EQ.41) THEN
58516 CHOLD2=PROC(I1)
58517 ELSEIF(IVAR.EQ.42) THEN
58518 ROLD=SIGT(I1,I2,I3)
58519 ELSEIF(IVAR.EQ.43) THEN
58520 ROLD=XPVMD(I1)
58521 ELSEIF(IVAR.EQ.44) THEN
58522 ROLD=XPANL(I1)
58523 ELSEIF(IVAR.EQ.45) THEN
58524 ROLD=XPANH(I1)
58525 ELSEIF(IVAR.EQ.46) THEN
58526 ROLD=XPBEH(I1)
58527 ELSEIF(IVAR.EQ.47) THEN
58528 ROLD=XPDIR(I1)
58529 ELSEIF(IVAR.EQ.48) THEN
58530 IOLD=IMSS(I1)
58531 ELSEIF(IVAR.EQ.49) THEN
58532 ROLD=RMSS(I1)
58533 ELSEIF(IVAR.EQ.50) THEN
58534 ROLD=RVLAM(I1,I2,I3)
58535 ELSEIF(IVAR.EQ.51) THEN
58536 ROLD=RVLAMP(I1,I2,I3)
58537 ELSEIF(IVAR.EQ.52) THEN
58538 ROLD=RVLAMB(I1,I2,I3)
58539 ELSEIF(IVAR.EQ.53) THEN
58540 IOLD=ITCM(I1)
58541 ELSEIF(IVAR.EQ.54) THEN
58542 ROLD=RTCM(I1)
58543 ENDIF
58544
58545C...Print current value of variable. Loop back.
58546 IF(LNAM.GE.LBIT) THEN
58547 CHBIT(LNAM:14)=' '
58548 CHBIT(15:60)=' has the value '
58549 IF(MSVAR(IVAR,1).EQ.1) THEN
58550 WRITE(CHBIT(51:60),'(I10)') IOLD
58551 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58552 WRITE(CHBIT(47:60),'(F14.5)') ROLD
58553 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58554 CHBIT(53:60)=CHOLD
58555 ELSE
58556 CHBIT(33:60)=CHOLD
58557 ENDIF
58558 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58559 LLOW=LHIG
58560 IF(LLOW.LT.LTOT) GOTO 120
58561 RETURN
58562 ENDIF
58563
58564C...Read in new variable value.
58565 IF(MSVAR(IVAR,1).EQ.1) THEN
58566 CHINI=' '
58567 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
58568 READ(CHINI,'(I10)') INEW
58569 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58570 CHINR=' '
58571 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
58572 READ(CHINR,*) RNEW
58573 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58574 CHNEW=CHBIT(LNAM+1:LBIT)//' '
58575 ELSE
58576 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
58577 ENDIF
58578
58579C...Store new variable value.
58580 IF(IVAR.EQ.1) THEN
58581 N=INEW
58582 ELSEIF(IVAR.EQ.2) THEN
58583 K(I1,I2)=INEW
58584 ELSEIF(IVAR.EQ.3) THEN
58585 P(I1,I2)=RNEW
58586 ELSEIF(IVAR.EQ.4) THEN
58587 V(I1,I2)=RNEW
58588 ELSEIF(IVAR.EQ.5) THEN
58589 MSTU(I1)=INEW
58590 ELSEIF(IVAR.EQ.6) THEN
58591 PARU(I1)=RNEW
58592 ELSEIF(IVAR.EQ.7) THEN
58593 MSTJ(I1)=INEW
58594 ELSEIF(IVAR.EQ.8) THEN
58595 PARJ(I1)=RNEW
58596 ELSEIF(IVAR.EQ.9) THEN
58597 KCHG(I1,I2)=INEW
58598 ELSEIF(IVAR.EQ.10) THEN
58599 PMAS(I1,I2)=RNEW
58600 ELSEIF(IVAR.EQ.11) THEN
58601 PARF(I1)=RNEW
58602 ELSEIF(IVAR.EQ.12) THEN
58603 VCKM(I1,I2)=RNEW
58604 ELSEIF(IVAR.EQ.13) THEN
58605 MDCY(I1,I2)=INEW
58606 ELSEIF(IVAR.EQ.14) THEN
58607 MDME(I1,I2)=INEW
58608 ELSEIF(IVAR.EQ.15) THEN
58609 BRAT(I1)=RNEW
58610 ELSEIF(IVAR.EQ.16) THEN
58611 KFDP(I1,I2)=INEW
58612 ELSEIF(IVAR.EQ.17) THEN
58613 CHAF(I1,I2)=CHNEW
58614 ELSEIF(IVAR.EQ.18) THEN
58615 MRPY(I1)=INEW
58616 ELSEIF(IVAR.EQ.19) THEN
58617 RRPY(I1)=RNEW
58618 ELSEIF(IVAR.EQ.20) THEN
58619 MSEL=INEW
58620 ELSEIF(IVAR.EQ.21) THEN
58621 MSUB(I1)=INEW
58622 ELSEIF(IVAR.EQ.22) THEN
58623 KFIN(I1,I2)=INEW
58624 ELSEIF(IVAR.EQ.23) THEN
58625 CKIN(I1)=RNEW
58626 ELSEIF(IVAR.EQ.24) THEN
58627 MSTP(I1)=INEW
58628 ELSEIF(IVAR.EQ.25) THEN
58629 PARP(I1)=RNEW
58630 ELSEIF(IVAR.EQ.26) THEN
58631 MSTI(I1)=INEW
58632 ELSEIF(IVAR.EQ.27) THEN
58633 PARI(I1)=RNEW
58634 ELSEIF(IVAR.EQ.28) THEN
58635 MINT(I1)=INEW
58636 ELSEIF(IVAR.EQ.29) THEN
58637 VINT(I1)=RNEW
58638 ELSEIF(IVAR.EQ.30) THEN
58639 ISET(I1)=INEW
58640 ELSEIF(IVAR.EQ.31) THEN
58641 KFPR(I1,I2)=INEW
58642 ELSEIF(IVAR.EQ.32) THEN
58643 COEF(I1,I2)=RNEW
58644 ELSEIF(IVAR.EQ.33) THEN
58645 ICOL(I1,I2,I3)=INEW
58646 ELSEIF(IVAR.EQ.34) THEN
58647 XSFX(I1,I2)=RNEW
58648 ELSEIF(IVAR.EQ.35) THEN
58649 ISIG(I1,I2)=INEW
58650 ELSEIF(IVAR.EQ.36) THEN
58651 SIGH(I1)=RNEW
58652 ELSEIF(IVAR.EQ.37) THEN
58653 MWID(I1)=INEW
58654 ELSEIF(IVAR.EQ.38) THEN
58655 WIDS(I1,I2)=RNEW
58656 ELSEIF(IVAR.EQ.39) THEN
58657 NGEN(I1,I2)=INEW
58658 ELSEIF(IVAR.EQ.40) THEN
58659 XSEC(I1,I2)=RNEW
58660 ELSEIF(IVAR.EQ.41) THEN
58661 PROC(I1)=CHNEW2
58662 ELSEIF(IVAR.EQ.42) THEN
58663 SIGT(I1,I2,I3)=RNEW
58664 ELSEIF(IVAR.EQ.43) THEN
58665 XPVMD(I1)=RNEW
58666 ELSEIF(IVAR.EQ.44) THEN
58667 XPANL(I1)=RNEW
58668 ELSEIF(IVAR.EQ.45) THEN
58669 XPANH(I1)=RNEW
58670 ELSEIF(IVAR.EQ.46) THEN
58671 XPBEH(I1)=RNEW
58672 ELSEIF(IVAR.EQ.47) THEN
58673 XPDIR(I1)=RNEW
58674 ELSEIF(IVAR.EQ.48) THEN
58675 IMSS(I1)=INEW
58676 ELSEIF(IVAR.EQ.49) THEN
58677 RMSS(I1)=RNEW
58678 ELSEIF(IVAR.EQ.50) THEN
58679 RVLAM(I1,I2,I3)=RNEW
58680 ELSEIF(IVAR.EQ.51) THEN
58681 RVLAMP(I1,I2,I3)=RNEW
58682 ELSEIF(IVAR.EQ.52) THEN
58683 RVLAMB(I1,I2,I3)=RNEW
58684 ELSEIF(IVAR.EQ.53) THEN
58685 ITCM(I1)=INEW
58686 ELSEIF(IVAR.EQ.54) THEN
58687 RTCM(I1)=RNEW
58688 ENDIF
58689
58690C...Write old and new value. Loop back.
58691 CHBIT(LNAM:14)=' '
58692 CHBIT(15:60)=' changed from to '
58693 IF(MSVAR(IVAR,1).EQ.1) THEN
58694 WRITE(CHBIT(33:42),'(I10)') IOLD
58695 WRITE(CHBIT(51:60),'(I10)') INEW
58696 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58697 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58698 WRITE(CHBIT(29:42),'(F14.5)') ROLD
58699 WRITE(CHBIT(47:60),'(F14.5)') RNEW
58700 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58701 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58702 CHBIT(35:42)=CHOLD
58703 CHBIT(53:60)=CHNEW
58704 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58705 ELSE
58706 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
58707 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
58708 ENDIF
58709 LLOW=LHIG
58710 IF(LLOW.LT.LTOT) GOTO 120
58711
58712C...Format statement for output on unit MSTU(11) (by default 6).
58713 5000 FORMAT(5X,A60)
58714 5100 FORMAT(5X,A88)
58715
58716 RETURN
58717 END
58718
58719C*********************************************************************
58720
58721C...PYONOF
58722C...Switches on and off decay channel by search for match.
58723
58724 SUBROUTINE PYONOF(CHIN)
58725
58726C...Double precision and integer declarations.
58727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58728 IMPLICIT INTEGER(I-N)
58729 INTEGER PYK,PYCHGE,PYCOMP
58730C...Commonblocks.
58731 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58732 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58733 SAVE /PYDAT1/,/PYDAT3/
58734C...Local arrays and character variables.
58735 INTEGER KFCMP(10),KFTMP(10)
58736 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
58737 &CHALP(2)*26
58738 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58739 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
58740
58741C...Determine length of character variable.
58742 CHTMP=CHIN//' '
58743 LBEG=0
58744 100 LBEG=LBEG+1
58745 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
58746 LEND=LBEG-1
58747 105 LEND=LEND+1
58748 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
58749 110 LEND=LEND-1
58750 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
58751 LEN=1+LEND-LBEG
58752 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
58753
58754C...Find colon separator and particle code.
58755 LCOLON=0
58756 120 LCOLON=LCOLON+1
58757 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
58758 CHCODE=' '
58759 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
58760 READ(CHCODE,'(I8)',ERR=300) KF
58761 KC=PYCOMP(KF)
58762
58763C...Done if unknown code or no decay channels.
58764 IF(KC.EQ.0) THEN
58765 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
58766 RETURN
58767 ENDIF
58768 IDCBEG=MDCY(KC,2)
58769 IDCLEN=MDCY(KC,3)
58770 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
58771 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
58772 RETURN
58773 ENDIF
58774
58775C...Find command name up to blank or equal sign.
58776 LSEP=LCOLON
58777 130 LSEP=LSEP+1
58778 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
58779 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
58780 CHMODE=' '
58781 LMODE=LSEP-LCOLON-1
58782 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
58783
58784C...Convert to uppercase.
58785 DO 150 LCOM=1,LMODE
58786 DO 140 LALP=1,26
58787 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
58788 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
58789 140 CONTINUE
58790 150 CONTINUE
58791
58792C...Identify command. Failed if not identified.
58793 MODE=0
58794 IF(CHMODE.EQ.'ALLOFF') MODE=1
58795 IF(CHMODE.EQ.'ALLON') MODE=2
58796 IF(CHMODE.EQ.'OFFIFANY') MODE=3
58797 IF(CHMODE.EQ.'ONIFANY') MODE=4
58798 IF(CHMODE.EQ.'OFFIFALL') MODE=5
58799 IF(CHMODE.EQ.'ONIFALL') MODE=6
58800 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
58801 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
58802 IF(MODE.EQ.0) THEN
58803 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
58804 RETURN
58805 ENDIF
58806
58807C...Simple cases when all on or all off.
58808 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
58809 WRITE(MSTU(11),1000) KF,CHMODE
58810 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
58811 IF(MDME(IDC,1).LT.0) GOTO 160
58812 MDME(IDC,1)=MODE-1
58813 160 CONTINUE
58814 RETURN
58815 ENDIF
58816
58817C...Identify matching list.
58818 NCMP=0
58819 LBEG=LSEP
58820 170 LBEG=LBEG+1
58821 IF(LBEG.GT.LEN) GOTO 190
58822 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
58823 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
58824 LEND=LBEG-1
58825 180 LEND=LEND+1
58826 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
58827 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
58828 IF(LEND.LT.LEN) LEND=LEND-1
58829 CHCODE=' '
58830 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
58831 READ(CHCODE,'(I8)',ERR=300) KFREAD
58832 NCMP=NCMP+1
58833 KFCMP(NCMP)=IABS(KFREAD)
58834 LBEG=LEND
58835 IF(NCMP.LT.10) GOTO 170
58836 190 CONTINUE
58837 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
58838
58839C...Only one matching required.
58840 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
58841 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
58842 IF(MDME(IDC,1).LT.0) GOTO 220
58843 DO 210 IKF=1,5
58844 KFNOW=IABS(KFDP(IDC,IKF))
58845 IF(KFNOW.EQ.0) GOTO 210
58846 DO 200 ICMP=1,NCMP
58847 IF(KFCMP(ICMP).EQ.KFNOW) THEN
58848 MDME(IDC,1)=MODE-3
58849 GOTO 220
58850 ENDIF
58851 200 CONTINUE
58852 210 CONTINUE
58853 220 CONTINUE
58854 RETURN
58855 ENDIF
58856
58857C...Multiple matchings required.
58858 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
58859 IF(MDME(IDC,1).LT.0) GOTO 260
58860 NTMP=NCMP
58861 DO 230 ITMP=1,NTMP
58862 KFTMP(ITMP)=KFCMP(ITMP)
58863 230 CONTINUE
58864 NFIN=0
58865 DO 250 IKF=1,5
58866 KFNOW=IABS(KFDP(IDC,IKF))
58867 IF(KFNOW.EQ.0) GOTO 250
58868 NFIN=NFIN+1
58869 DO 240 ITMP=1,NTMP
58870 IF(KFTMP(ITMP).EQ.KFNOW) THEN
58871 KFTMP(ITMP)=KFTMP(NTMP)
58872 NTMP=NTMP-1
58873 GOTO 250
58874 ENDIF
58875 240 CONTINUE
58876 250 CONTINUE
58877 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
58878 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
58879 & MDME(IDC,1)=MODE-7
58880 260 CONTINUE
58881 RETURN
58882
58883C...Error exit for impossible read of particle code.
58884 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
58885 &//CHCODE)
58886
58887C...Formats for output.
58888 1000 FORMAT(' Decays for',I8,' set ',A10)
58889 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
58890
58891 RETURN
58892 END
58893C*********************************************************************
58894
58895C...PYTUNE
58896C...Presets for a few specific underlying-event and min-bias tunes
58897C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
58898C...others require particular versions of pythia (e.g. the SCI and GAL
58899C...models). See below for details.
58900 SUBROUTINE PYTUNE(ITUNE)
58901C
58902C ITUNE NAME (detailed descriptions below)
58903C 0 Default : No settings changed => linked Pythia version's defaults.
58904C ====== Old UE, Q2-ordered showers ==========================================
58905C 100 A : Rick Field's CDF Tune A
58906C 101 AW : Rick Field's CDF Tune AW
58907C 102 BW : Rick Field's CDF Tune BW
58908C 103 DW : Rick Field's CDF Tune DW
58909C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling
58910C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally)
58911C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome)
58912C 107 ACR : Tune A modified with annealing CR
58913C 108 D6 : Rick Field's CDF Tune D6 (NB: needs CTEQ6L pdfs externally)
58914C 109 D6T : Rick Field's CDF Tune D6T (NB: needs CTEQ6L pdfs externally)
58915C ====== Intermediate Models =================================================
58916C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
58917C 201 APT : Tune A modified to use pT-ordered final-state showers
58918C ====== New UE, interleaved pT-ordered showers, annealing CR ================
58919C 300 S0 : Sandhoff-Skands Tune 0
58920C 301 S1 : Sandhoff-Skands Tune 1
58921C 302 S2 : Sandhoff-Skands Tune 2
58922C 303 S0A : S0 with "Tune A" UE energy scaling
58923C 304 NOCR : New UE "best try" without colour reconnections
58924C 305 Old : New UE, original (primitive) colour reconnections
58925C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune (needs CTEQ6L externally)
58926C ======= The Uppsala models =================================================
58927C ( NB! must be run with special modified Pythia 6.215 version )
58928C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
58929C 400 GAL 0 : Generalized area-law model. Old parameters
58930C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters
58931C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands)
58932C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands)
58933C
58934C More details;
58935C
58936C Quick Dictionary:
58937C BE : Bose-Einstein
58938C BR : Beam Remnants
58939C CR : Colour Reconnections
58940C HAD: Hadronization
58941C ISR/FSR: Initial-State Radiation / Final-State Radiation
58942C FSI: Final-State Interactions (=CR+BE)
58943C MB : Minimum-bias
58944C MI : Multiple Interactions
58945C UE : Underlying Event
58946C
58947C A (100) and AW (101). Old UE model, Q2-ordered showers.
58948C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58949C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58950C...Key feature: extensively compared to CDF data (R.D. Field).
58951C...* Large starting scale for ISR (PARP(67)=4)
58952C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
58953C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58954C
58955C BW (102). Old UE model, Q2-ordered showers.
58956C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58957C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58958C...Key feature: extensively compared to CDF data (R.D. Field).
58959C...NB: Can also be run with Pythia 6.2 or 6.312+
58960C...* Small starting scale for ISR (PARP(67)=1)
58961C...* BW has more radiation due to smaller mu_R choice in alpha_s.
58962C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58963C
58964C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
58965C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58966C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58967C...Key feature: extensively compared to CDF data (R.D. Field).
58968C...NB: Can also be run with Pythia 6.2 or 6.312+
58969C...* Intermediate starting scale for ISR (PARP(67)=2.5)
58970C...* DWT has a different reference energy, the same as the "S" models
58971C... below, leading to more UE activity at the LHC, but less at RHIC.
58972C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58973C
58974C QW (105). Old UE model, Q2-ordered showers.
58975C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58976C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58977C...Key feature: uses CTEQ61 (external pdf library must be linked)
58978C
58979C ATLAS-DC2 (106). Old UE model, Q2-ordered showers.
58980C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58981C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58982C...Key feature: tune used by the ATLAS collaboration.
58983C
58984C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
58985C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
58986C...Key feature: Tune A modified to use annealing CR.
58987C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
58988C
58989C D6 (108) and D6T (109). Old UE model, Q2-ordered showers, CTEQ6L PDF.
58990C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
58991C
58992C...IM1 (200). Intermediate model, Q2-ordered showers.
58993C...Key feature: new UE model with Q2-ordered showers and no interleaving.
58994C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
58995C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
58996C
58997C...APT (201). Old UE model, pT-ordered final-state showers
58998C...Key feature: Rick Field's Tune A, but with new final-state showers
58999C
59000C S0 (300) and S0A (303). New UE model, pT-ordered showers.
59001C...Key feature: large amount of multiple interactions
59002C...* Somewhat faster than the other colour annealing scenarios.
59003C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
59004C... from Tune A, leading to less UE at the LHC, but more at RHIC.
59005C...* Small amount of radiation.
59006C...* Large amount of low-pT MI
59007C...* Low degree of proton lumpiness (broad matter dist.)
59008C...* CR Type S (driven by free triplets), of medium strength.
59009C...* See: Pythia6402 update notes or later.
59010C
59011C S1 (301). New UE model, pT-ordered showers.
59012C...Key feature: large amount of radiation.
59013C...* Large amount of low-pT perturbative ISR
59014C...* Large amount of FSR off ISR partons
59015C...* Small amount of low-pT multiple interactions
59016C...* Moderate degree of proton lumpiness
59017C...* Least aggressive CR type (S+S Type I), but with large strength
59018C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59019C
59020C S2 (302). New UE model, pT-ordered showers.
59021C...Key feature: very lumpy proton + gg string cluster formation allowed
59022C...* Small amount of radiation
59023C...* Moderate amount of low-pT MI
59024C...* High degree of proton lumpiness (more spiky matter distribution)
59025C...* Most aggressive CR type (S+S Type II), but with small strength
59026C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59027C
59028C NOCR (304). New UE model, pT-ordered showers.
59029C...Key feature: no colour reconnections (NB: "Best fit" only).
59030C...* NB: <pT>(Nch) problematic in this tune.
59031C...* Small amount of radiation
59032C...* Small amount of low-pT MI
59033C...* Low degree of proton lumpiness
59034C...* Large BR composite x enhancement factor
59035C...* Most clever colour flow without CR ("Lambda ordering")
59036C
59037C ATLAS-CSC (306). New UE mode, pT-ordered showers, CTEQ6L.
59038C...Key feature: 11-parameter ATLAS tune of the new framework.
59039C...* Old (pre-annealing) colour reconnections a la 305.
59040C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
59041C
59042C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
59043C...with an unmodified Pythia distribution.
59044C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
59045C
59046C ::: + Future improvements?
59047C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
59048C (problem: K-factor affects everything so only works as
59049C intended for min-bias, not for UE ... probably need a
59050C better long-term solution to handle UE as well. Anyway,
59051C Mark uses MSTP(33) and PARP(31)-PARP(33).)
59052
59053C...Global statements
59054 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59055 INTEGER PYK,PYCHGE,PYCOMP
59056
59057C...Commonblocks.
59058 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59059 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59060
59061C...SCI and GAL Commonblocks
59062 COMMON /SCIPAR/MSWI(2),PARSCI(2)
59063
59064C...Internal parameters
59065 PARAMETER(MXTUNS=500)
59066 CHARACTER*8 CHVERS, CHDOC
59067 PARAMETER (CHVERS='1.012 ',CHDOC='Sep 2007')
59068 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
59069 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
59070 & CHPARJ(41:100), CH40
59071 CHARACTER*60 CH60
59072 CHARACTER*70 CH70
59073 DATA (CHNAMS(I),I=0,1)/'Default',' '/
59074 DATA (CHNAMS(I),I=100,110)/
59075 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
59076 & 'ATLAS Tune','Tune ACR','Tune D6','Tune D6T',' '/
59077 DATA (CHNAMS(I),I=300,310)/
59078 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
59079 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',2*' '/
59080 DATA (CHNAMS(I),I=200,210)/
59081 & 'IM Tune 1','Tune APT',9*' '/
59082 DATA (CHNAMS(I),I=400,410)/
59083 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
59084 DATA (CHMSTJ(I),I=11,20)/
59085 & 'HAD choice of fragmentation function(s)',4*' ',
59086 & 'HAD treatment of small-mass systems',4*' '/
59087 DATA (CHMSTJ(I),I=41,50)/
59088 & 'FSR type (Q2 or pT) for old framework',9*' '/
59089 DATA (CHMSTP(I),I=51,100)/
59090 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
59091 6 'ISR master switch',6*' ',
59092 6 'ISR phase space choice & ME corrections',' ',
59093 7 'ISR IR regularization scheme',' ',
59094 7 'ISR scheme for FSR off ISR',8*' ',
59095 8 'UE model',
59096 8 'UE hadron transverse mass distribution',5*' ',
59097 8 'BR composite scheme','BR colour scheme',
59098 9 'BR primordial kT compensation',
59099 9 'BR primordial kT distribution',
59100 9 'BR energy partitioning scheme',2*' ',
59101 9 'FSI colour (re-)connection model',5*' '/
59102 DATA (CHPARP(I),I=61,100)/
59103 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
59104 6 2*' ','ISR Q2max factor',3*' ',
59105 7 'FSR Q2max factor for non-s-channel procs',5*' ',
59106 7 'FSI colour reconnection turnoff scale',
59107 7 'FSI colour reconnection strength',
59108 7 'BR composite x enhancement','BR breakup suppression',
59109 8 2*'UE IR cutoff at reference ecm',
59110 8 2*'UE mass distribution parameter',
59111 8 'UE gg colour correlated fraction','UE total gg fraction',
59112 8 2*' ',
59113 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
59114 9 'BR primordial kT width <|kT|>',' ',
59115 9 'BR primordial kT UV cutoff',7*' '/
59116 DATA (CHPARJ(I),I=41,90)/
59117 4 ' ','HAD string parameter b',8*' ',
59118 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
59119 6 10*' ',10*' ',
59120 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
59121 SAVE /PYDAT1/,/PYPARS/
59122 SAVE /SCIPAR/
59123
59124C...1) Shorthand notation
59125 M13=MSTU(13)
59126 M11=MSTU(11)
59127 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
59128 CHNAME=CHNAMS(ITUNE)
59129 IF (ITUNE.EQ.0) GOTO 9999
59130 ELSE
59131 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
59132 GOTO 9999
59133 ENDIF
59134
59135C...2) Hello World
59136 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
59137
59138C...3) Tune parameters
59139
59140C=============================================================================
59141C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
59142 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
59143 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59144 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59145 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59146 & ' with tune.')
59147 ENDIF
59148
59149C...PDFs
59150 MSTP(52)=1
59151 MSTP(51)=7
59152C...ISR
59153 PARP(64)=1D0
59154C...UE on, new model.
59155 MSTP(81)=21
59156C...Slow IR cutoff energy scaling by default
59157 PARP(89)=1800D0
59158 PARP(90)=0.16D0
59159C...Switch off trial joinings
59160 MSTP(96)=0
59161C...Primordial kT cutoff
59162 PARP(93)=5D0
59163
59164C...S0 (300), S0A (303)
59165 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
59166 IF (M13.GE.1) THEN
59167 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59168 WRITE(M11,5030) CH60
59169 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
59170 WRITE(M11,5030) CH60
59171 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59172 WRITE(M11,5030) CH60
59173 ENDIF
59174C...Smooth ISR, low FSR
59175 MSTP(70)=2
59176 MSTP(72)=0
59177C...pT0
59178 PARP(82)=1.85D0
59179C...Transverse density profile.
59180 MSTP(82)=5
59181 PARP(83)=1.6D0
59182C...Colour Reconnections
59183 MSTP(95)=6
59184 PARP(78)=0.20D0
59185 PARP(77)=0.0D0
59186C... Reference energy for pT0 and energy scaling pace.
59187 IF (ITUNE.EQ.303) PARP(90)=0.25D0
59188C...Lambda_FSR scale.
59189 PARJ(81)=0.23D0
59190C...FSR activity.
59191 PARP(71)=4D0
59192C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59193 MSTP(89)=1
59194 MSTP(88)=0
59195 PARP(79)=2D0
59196 PARP(80)=0.01D0
59197
59198C...S1 (301)
59199 ELSEIF(ITUNE.EQ.301) THEN
59200 IF (M13.GE.1) THEN
59201 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59202 WRITE(M11,5030) CH60
59203 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59204 WRITE(M11,5030) CH60
59205 ENDIF
59206C...Sharp ISR, high FSR
59207 MSTP(70)=0
59208 MSTP(72)=1
59209C...pT0
59210 PARP(82)=2.1D0
59211C...Colour Reconnections
59212 MSTP(95)=2
59213 PARP(78)=0.35D0
59214C...Transverse density profile.
59215 MSTP(82)=5
59216 PARP(83)=1.4D0
59217C...Lambda_FSR scale.
59218 PARJ(81)=0.23D0
59219C...FSR activity.
59220 PARP(71)=4D0
59221C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59222 MSTP(89)=1
59223 MSTP(88)=0
59224 PARP(79)=2D0
59225 PARP(80)=0.01D0
59226
59227C...S2 (302)
59228 ELSEIF(ITUNE.EQ.302) THEN
59229 IF (M13.GE.1) THEN
59230 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59231 WRITE(M11,5030) CH60
59232 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59233 WRITE(M11,5030) CH60
59234 ENDIF
59235C...Smooth ISR, low FSR
59236 MSTP(70)=2
59237 MSTP(72)=0
59238C...pT0
59239 PARP(82)=1.9D0
59240C...Transverse density profile.
59241 MSTP(82)=5
59242 PARP(83)=1.2D0
59243C...Colour Reconnections
59244 MSTP(95)=4
59245 PARP(78)=0.15D0
59246C...Lambda_FSR scale.
59247 PARJ(81)=0.23D0
59248C...FSR activity.
59249 PARP(71)=4D0
59250C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59251 MSTP(89)=1
59252 MSTP(88)=0
59253 PARP(79)=2D0
59254 PARP(80)=0.01D0
59255
59256C...NOCR (304)
59257 ELSEIF(ITUNE.EQ.304) THEN
59258 IF (M13.GE.1) THEN
59259 CH60='"best try" without colour reconnections'
59260 WRITE(M11,5030) CH60
59261 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59262 WRITE(M11,5030) CH60
59263 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59264 WRITE(M11,5030) CH60
59265 ENDIF
59266C...Smooth ISR, low FSR
59267 MSTP(70)=2
59268 MSTP(72)=0
59269C...pT0
59270 PARP(82)=2.05D0
59271C...Transverse density profile.
59272 MSTP(82)=5
59273 PARP(83)=1.8D0
59274C...Colour Reconnections
59275 MSTP(95)=0
59276C...Lambda_FSR scale.
59277 PARJ(81)=0.23D0
59278C...FSR activity.
59279 PARP(71)=4D0
59280C...Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
59281 MSTP(89)=2
59282 MSTP(88)=0
59283 PARP(79)=3D0
59284 PARP(80)=0.01D0
59285
59286C..."Lo FSR" retune (305)
59287 ELSEIF(ITUNE.EQ.305) THEN
59288 IF (M13.GE.1) THEN
59289 CH60='"Lo FSR retune" with primitive colour reconnections'
59290 WRITE(M11,5030) CH60
59291 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
59292 WRITE(M11,5030) CH60
59293 ENDIF
59294C...Smooth ISR, low FSR
59295 MSTP(70)=2
59296 MSTP(72)=0
59297C...pT0
59298 PARP(82)=1.9D0
59299C...Transverse density profile.
59300 MSTP(82)=5
59301 PARP(83)=2.0D0
59302C...Colour Reconnections
59303 MSTP(95)=1
59304 PARP(78)=1.0D0
59305C...Lambda_FSR scale.
59306 PARJ(81)=0.23D0
59307C...FSR activity.
59308 PARP(71)=4D0
59309C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59310 MSTP(89)=1
59311 MSTP(88)=0
59312 PARP(79)=2D0
59313 PARP(80)=0.01D0
59314 ENDIF
59315C...Output
59316 IF (M13.GE.1) THEN
59317 WRITE(M11,5030) ' '
59318 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59319 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59320 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59321 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59322 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59323 WRITE(M11,5030) CH60
59324 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59325 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59326 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59327 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59328 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59329 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59330 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59331 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59332 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59333 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59334 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59335 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59336 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59337 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59338 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59339 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59340 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59341 ENDIF
59342
59343C=============================================================================
59344C...ATLAS-CSC 11-parameter tune (By A. Moraes)
59345 ELSEIF (ITUNE.EQ.306) THEN
59346 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59347 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59348 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59349 & ' with tune.')
59350 ENDIF
59351
59352C...PDFs
59353 MSTP(52)=2
59354 MSTP(54)=2
59355 MSTP(56)=2
59356 MSTP(51)=10042
59357 MSTP(53)=10042
59358 MSTP(55)=10042
59359C...ISR
59360C PARP(64)=1D0
59361C...UE on, new model.
59362 MSTP(81)=21
59363C...Energy scaling
59364 PARP(89)=1800D0
59365 PARP(90)=0.22D0
59366C...Switch off trial joinings
59367 MSTP(96)=0
59368C...Primordial kT cutoff
59369
59370 IF (M13.GE.1) THEN
59371 CH60='see presentations by A. Moraes (ATLAS),'
59372 WRITE(M11,5030) CH60
59373 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59374 WRITE(M11,5030) CH60
59375 WRITE(M11,5030) ' '
59376 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59377 & 'externally linked and'
59378 WRITE(M11,5035) CH70
59379 CH70='MSTP(51) should be set manually according to '//
59380 & 'the library used'
59381 WRITE(M11,5035) CH70
59382 ENDIF
59383C...Smooth ISR, low FSR
59384 MSTP(70)=2
59385 MSTP(72)=0
59386C...pT0
59387 PARP(82)=1.9D0
59388C...Transverse density profile.
59389 MSTP(82)=4
59390 PARP(83)=0.3D0
59391 PARP(84)=0.5D0
59392C...ISR & FSR in interactions after the first (default)
59393 MSTP(84)=1
59394 MSTP(85)=1
59395C...No double-counting (default)
59396 MSTP(86)=2
59397C...Companion quark parent gluon (1-x) power
59398 MSTP(87)=4
59399C...Primordial kT compensation along chaings (default = 0 : uniform)
59400 MSTP(90)=1
59401C...Colour Reconnections
59402 MSTP(95)=1
59403 PARP(78)=0.2D0
59404C...Lambda_FSR scale.
59405 PARJ(81)=0.23D0
59406C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59407 MSTP(89)=1
59408 MSTP(88)=0
59409C PARP(79)=2D0
59410 PARP(80)=0.01D0
59411C...Peterson charm frag, and c and b hadr parameters
59412 MSTJ(11)=3
59413 PARJ(54)=-0.07
59414 PARJ(55)=-0.006
59415C... Output
59416 IF (M13.GE.1) THEN
59417 WRITE(M11,5030) ' '
59418 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59419 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59420 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59421 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59422 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59423 WRITE(M11,5030) CH60
59424 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59425 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59426 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59427 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59428 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
59429 WRITE(M11,5030) CH60
59430 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59431 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59432 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59433 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59434 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59435 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59436 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59437 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59438 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59439 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
59440 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59441 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59442 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59443 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59444 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59445 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59446 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59447 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59448 ENDIF
59449
59450C=============================================================================
59451C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
59452C...(100-105,108-109) and ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
59453 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
59454 & ITUNE.EQ.109) THEN
59455 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
59456 WRITE(M11,5010) ITUNE, CHNAME
59457 CH60='see R.D. Field (CDF), in hep-ph/0610012'
59458 WRITE(M11,5030) CH60
59459 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59460 WRITE(M11,5030) CH60
59461 ENDIF
59462C...Multiple interactions on, old framework
59463 MSTP(81)=1
59464C...Fast IR cutoff energy scaling by default
59465 PARP(89)=1800D0
59466 PARP(90)=0.25D0
59467C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
59468 MSTP(51)=7
59469 MSTP(52)=1
59470 IF (ITUNE.EQ.105) THEN
59471 MSTP(51)=10150
59472 MSTP(52)=2
59473 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59474 MSTP(52)=2
59475 MSTP(54)=2
59476 MSTP(56)=2
59477 MSTP(51)=10042
59478 MSTP(53)=10042
59479 MSTP(55)=10042
59480 ENDIF
59481C...Double Gaussian matter distribution.
59482 MSTP(82)=4
59483 PARP(83)=0.5D0
59484 PARP(84)=0.4D0
59485C...FSR activity.
59486 PARP(71)=4D0
59487C...Lambda_FSR scale.
59488 PARJ(81)=0.29D0
59489C...Fragmentation functions and c and b parameters
59490 MSTJ(11)=4
59491 PARJ(54)=-0.05
59492 PARJ(55)=-0.005
59493
59494C...Tune A and AW
59495 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
59496C...pT0.
59497 PARP(82)=2.0D0
59498c...String drawing almost completely minimizes string length.
59499 PARP(85)=0.9D0
59500 PARP(86)=0.95D0
59501C...ISR cutoff, muR scale factor, and phase space size
59502 PARP(62)=1D0
59503 PARP(64)=1D0
59504 PARP(67)=4D0
59505C...Intrinsic kT, size, and max
59506 MSTP(91)=1
59507 PARP(91)=1D0
59508 PARP(93)=5D0
59509C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
59510 IF (ITUNE.EQ.101) THEN
59511 PARP(62)=1.25D0
59512 PARP(64)=0.2D0
59513 PARP(91)=2.1D0
59514 PARP(92)=15.0D0
59515 ENDIF
59516
59517C...Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
59518 ELSEIF (ITUNE.EQ.102) THEN
59519C...pT0.
59520 PARP(82)=1.9D0
59521c...String drawing completely minimizes string length.
59522 PARP(85)=1.0D0
59523 PARP(86)=1.0D0
59524C...ISR cutoff, muR scale factor, and phase space size
59525 PARP(62)=1.25D0
59526 PARP(64)=0.2D0
59527 PARP(67)=1D0
59528C...Intrinsic kT, size, and max
59529 MSTP(91)=1
59530 PARP(91)=2.1D0
59531 PARP(93)=15D0
59532
59533C...Tune DW
59534 ELSEIF (ITUNE.EQ.103) THEN
59535C...pT0.
59536 PARP(82)=1.9D0
59537c...String drawing completely minimizes string length.
59538 PARP(85)=1.0D0
59539 PARP(86)=1.0D0
59540C...ISR cutoff, muR scale factor, and phase space size
59541 PARP(62)=1.25D0
59542 PARP(64)=0.2D0
59543 PARP(67)=2.5D0
59544C...Intrinsic kT, size, and max
59545 MSTP(91)=1
59546 PARP(91)=2.1D0
59547 PARP(93)=15D0
59548
59549C...Tune DWT
59550 ELSEIF (ITUNE.EQ.104) THEN
59551C...pT0.
59552 PARP(82)=1.9409D0
59553C...Run II ref scale and slow scaling
59554 PARP(89)=1960D0
59555 PARP(90)=0.16D0
59556c...String drawing completely minimizes string length.
59557 PARP(85)=1.0D0
59558 PARP(86)=1.0D0
59559C...ISR cutoff, muR scale factor, and phase space size
59560 PARP(62)=1.25D0
59561 PARP(64)=0.2D0
59562 PARP(67)=2.5D0
59563C...Intrinsic kT, size, and max
59564 MSTP(91)=1
59565 PARP(91)=2.1D0
59566 PARP(93)=15D0
59567
59568C...Tune QW
59569 ELSEIF(ITUNE.EQ.105) THEN
59570 IF (M13.GE.1) THEN
59571 WRITE(M11,5030) ' '
59572 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59573 & 'externally linked and'
59574 WRITE(M11,5035) CH70
59575 CH70='MSTP(51) should be set manually according to '//
59576 & 'the library used'
59577 WRITE(M11,5035) CH70
59578 ENDIF
59579C...pT0.
59580 PARP(82)=1.1D0
59581c...String drawing completely minimizes string length.
59582 PARP(85)=1.0D0
59583 PARP(86)=1.0D0
59584C...ISR cutoff, muR scale factor, and phase space size
59585 PARP(62)=1.25D0
59586 PARP(64)=0.2D0
59587 PARP(67)=2.5D0
59588C...Intrinsic kT, size, and max
59589 MSTP(91)=1
59590 PARP(91)=2.1D0
59591 PARP(93)=15D0
59592
59593C...Tune D6 and D6T
59594 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59595 IF (M13.GE.1) THEN
59596 WRITE(M11,5030) ' '
59597 CH70='NB! This tune requires CTEQ6L pdfs to be '//
59598 & 'externally linked and'
59599 WRITE(M11,5035) CH70
59600 CH70='MSTP(51) should be set manually according to '//
59601 & 'the library used'
59602 WRITE(M11,5035) CH70
59603 ENDIF
59604C...The "Rick" proton, double gauss with 0.5/0.4
59605 MSTP(82)=4
59606 PARP(83)=0.5D0
59607 PARP(84)=0.4D0
59608c...String drawing completely minimizes string length.
59609 PARP(85)=1.0D0
59610 PARP(86)=1.0D0
59611 IF (ITUNE.EQ.108) THEN
59612C...D6: pT0, Run I ref scale, and fast energy scaling
59613 PARP(82)=1.8D0
59614 PARP(89)=1800D0
59615 PARP(90)=0.25D0
59616 ELSE
59617C...D6T: pT0, Run II ref scale, and slow energy scaling
59618 PARP(82)=1.8387D0
59619 PARP(89)=1960D0
59620 PARP(90)=0.16D0
59621 ENDIF
59622C...ISR cutoff, muR scale factor, and phase space size
59623 PARP(62)=1.25D0
59624 PARP(64)=0.2D0
59625 PARP(67)=2.5D0
59626C...Intrinsic kT, size, and max
59627 MSTP(91)=1
59628 PARP(91)=2.1D0
59629 PARP(93)=15D0
59630
59631C...Old ATLAS-DC2 5-parameter tune
59632 ELSEIF(ITUNE.EQ.106) THEN
59633 IF (M13.GE.1) THEN
59634 WRITE(M11,5010) ITUNE, CHNAME
59635 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
59636 WRITE(M11,5030) CH60
59637 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59638 WRITE(M11,5030) CH60
59639 ENDIF
59640C... pT0.
59641 PARP(82)=1.8D0
59642C... Different ref and rescaling pacee
59643 PARP(89)=1000D0
59644 PARP(90)=0.16D0
59645C... Parameters of mass distribution
59646 PARP(83)=0.5D0
59647 PARP(84)=0.5D0
59648C... Old default string drawing
59649 PARP(85)=0.33D0
59650 PARP(86)=0.66D0
59651C... ISR, phase space equivalent to Tune B
59652 PARP(62)=1D0
59653 PARP(64)=1D0
59654 PARP(67)=1D0
59655C... FSR
59656 PARP(71)=4D0
59657 PARJ(81)=0.29D0
59658C... Intrinsic kT
59659 MSTP(91)=1
59660 PARP(91)=1D0
59661 PARP(93)=5D0
59662 ENDIF
59663
59664C... Output
59665 IF (M13.GE.1) THEN
59666 WRITE(M11,5030) ' '
59667 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59668 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59669 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59670 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59671 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59672 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59673 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59674 WRITE(M11,5030) CH60
59675 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59676 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59677 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59678 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59679 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59680 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59681 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59682 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59683 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59684 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59685 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59686 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59687 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59688 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59689 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59690 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59691 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59692 ENDIF
59693
59694C=============================================================================
59695C... ACR, tune A with new CR (107)
59696 ELSEIF(ITUNE.EQ.107) THEN
59697 IF (M13.GE.1) THEN
59698 WRITE(M11,5010) ITUNE, CHNAME
59699 CH60='Tune A modified with new colour reconnections'
59700 WRITE(M11,5030) CH60
59701 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
59702 WRITE(M11,5030) CH60
59703 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
59704 WRITE(M11,5030) CH60
59705 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59706 WRITE(M11,5030) CH60
59707 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59708 WRITE(M11,5030) CH60
59709 ENDIF
59710 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
59711 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59712 & ' with tune. Using defaults.')
59713 GOTO 9998
59714 ENDIF
59715 MSTP(81)=1
59716 PARP(89)=1800D0
59717 PARP(90)=0.25D0
59718 MSTP(82)=4
59719 PARP(83)=0.5D0
59720 PARP(84)=0.4D0
59721 MSTP(51)=7
59722 MSTP(52)=1
59723 PARP(71)=4D0
59724 PARJ(81)=0.29D0
59725 PARP(82)=2.0D0
59726 PARP(85)=0.0D0
59727 PARP(86)=0.66D0
59728 PARP(62)=1D0
59729 PARP(64)=1D0
59730 PARP(67)=4D0
59731 MSTP(91)=1
59732 PARP(91)=1D0
59733 PARP(93)=5D0
59734 MSTP(95)=6
59735 PARP(78)=0.25D0
59736C...Fragmentation functions and c and b parameters
59737 MSTJ(11)=4
59738 PARJ(54)=-0.05
59739 PARJ(55)=-0.005
59740C...Output
59741 IF (M13.GE.1) THEN
59742 WRITE(M11,5030) ' '
59743 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59744 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59745 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59746 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59747 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59748 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59749 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59750 WRITE(M11,5030) CH60
59751 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59752 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59753 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59754 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59755 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59756 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59757 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59758 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59759 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59760 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59761 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59762 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59763 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59764 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59765 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59766 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59767 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59768 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59769 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59770 ENDIF
59771
59772C=============================================================================
59773C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
59774 ELSEIF(ITUNE.EQ.200) THEN
59775 IF (M13.GE.1) THEN
59776 WRITE(M11,5010) ITUNE, CHNAME
59777 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
59778 WRITE(M11,5030) CH60
59779 ENDIF
59780 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59781 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59782 & ' with tune.')
59783 ENDIF
59784C...PDF
59785 MSTP(51)=7
59786 MSTP(52)=1
59787C...ISR
59788 PARP(62)=1D0
59789 PARP(64)=1D0
59790 PARP(67)=4D0
59791C...FSR
59792 PARP(71)=4D0
59793 PARJ(81)=0.29D0
59794C...UE
59795 MSTP(81)=11
59796 PARP(82)=2.25D0
59797 PARP(89)=1800D0
59798 PARP(90)=0.25D0
59799C... ExpOfPow(1.8) overlap profile
59800 MSTP(82)=5
59801 PARP(83)=1.8D0
59802C... Valence qq
59803 MSTP(88)=0
59804C... Rap Tune
59805 MSTP(89)=1
59806C... Default diquark, BR-g-BR supp
59807 PARP(79)=2D0
59808 PARP(80)=0.01D0
59809C... Final state reconnect.
59810 MSTP(95)=1
59811 PARP(78)=0.55D0
59812C...Fragmentation functions and c and b parameters
59813 MSTJ(11)=4
59814 PARJ(54)=-0.05
59815 PARJ(55)=-0.005
59816C... Output
59817 IF (M13.GE.1) THEN
59818 WRITE(M11,5030) ' '
59819 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59820 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59821 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59822 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59823 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59824 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59825 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59826 WRITE(M11,5030) CH60
59827 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59828 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59829 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59830 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59831 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59832 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59833 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59834 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59835 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59836 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59837 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59838 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59839 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59840 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59841 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59842 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59843 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59844 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59845 ENDIF
59846
59847C...APT. Tune A modified to use new pT-ordered FSR.
59848 ELSEIF(ITUNE.EQ.201) THEN
59849 IF (M13.GE.1) THEN
59850 WRITE(M11,5010) ITUNE, CHNAME
59851 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
59852 WRITE(M11,5030) CH60
59853 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59854 WRITE(M11,5030) CH60
59855 CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59856 WRITE(M11,5030) CH60
59857 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59858 WRITE(M11,5030) CH60
59859 ENDIF
59860 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
59861 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59862 & ' with tune.')
59863 ENDIF
59864C...First set as if Pythia tune A
59865C...Multiple interactions on, old framework
59866 MSTP(81)=1
59867C...Fast IR cutoff energy scaling by default
59868 PARP(89)=1800D0
59869 PARP(90)=0.25D0
59870C...Default CTEQ5L (internal)
59871 MSTP(51)=7
59872 MSTP(52)=1
59873C...Double Gaussian matter distribution.
59874 MSTP(82)=4
59875 PARP(83)=0.5D0
59876 PARP(84)=0.4D0
59877C...FSR activity.
59878 PARP(71)=4D0
59879c...String drawing almost completely minimizes string length.
59880 PARP(85)=0.9D0
59881 PARP(86)=0.95D0
59882C...ISR cutoff, muR scale factor, and phase space size
59883 PARP(62)=1D0
59884 PARP(64)=1D0
59885 PARP(67)=4D0
59886C...Intrinsic kT, size, and max
59887 MSTP(91)=1
59888 PARP(91)=1D0
59889 PARP(93)=5D0
59890C...Use pT-ordered FSR
59891 MSTJ(41)=12
59892C...Lambda_FSR scale for pT-ordering
59893 PARJ(81)=0.23D0
59894C...Retune pT0
59895 PARP(82)=2.1D0
59896C...Fragmentation functions and c and b parameters
59897 MSTJ(11)=4
59898 PARJ(54)=-0.05
59899 PARJ(55)=-0.005
59900
59901C... Output
59902 IF (M13.GE.1) THEN
59903 WRITE(M11,5030) ' '
59904 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59905 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59906 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59907 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59908 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59909 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59910 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59911 WRITE(M11,5030) CH60
59912 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
59913 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59914 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59915 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59916 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59917 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59918 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59919 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59920 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59921 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59922 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59923 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59924 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59925 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59926 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59927 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59928 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59929 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59930 ENDIF
59931
59932C=============================================================================
59933C...Uppsala models: Generalized Area Law and Soft Colour Interactions
59934 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
59935 IF (M13.GE.1) THEN
59936 WRITE(M11,5010) ITUNE, CHNAME
59937 CH60='see J. Rathsman, PLB452(1999)364'
59938 WRITE(M11,5030) CH60
59939C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
59940C ? WRITE(M11,5030)
59941 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59942 WRITE(M11,5030) CH60
59943 WRITE(M11,5030) ' '
59944 CH70='NB! The GAL model must be run with modified '//
59945 & 'Pythia v6.215:'
59946 WRITE(M11,5035) CH70
59947 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
59948 WRITE(M11,5035) CH70
59949 WRITE(M11,5030) ' '
59950 ENDIF
59951C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
59952 MSWI(2) = 3
59953 PARSCI(2) = 0.10
59954 MSWI(1) = 2
59955 PARSCI(1) = 0.44
59956 MSTJ(16) = 0
59957 PARJ(42) = 0.45
59958 PARJ(82) = 2.0
59959 PARP(62) = 2.0
59960 MSTP(81) = 1
59961 MSTP(82) = 1
59962 PARP(81) = 1.9
59963 MSTP(92) = 1
59964 IF(CHNAME.EQ.'GAL Tune 1') THEN
59965C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
59966 MSTP(82)=4
59967 PARP(83)=0.25D0
59968 PARP(84)=0.5D0
59969 PARP(82) = 1.75
59970 IF (M13.GE.1) THEN
59971 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59972 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59973 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59974 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59975 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59976 ENDIF
59977 ELSE
59978 IF (M13.GE.1) THEN
59979 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59980 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
59981 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59982 ENDIF
59983 ENDIF
59984C...Output
59985 IF (M13.GE.1) THEN
59986 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59987 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
59988 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
59989 CH40='FSI SCI/GAL selection'
59990 WRITE(M11,6040) 1, MSWI(1), CH40
59991 CH40='FSI SCI/GAL sea quark treatment'
59992 WRITE(M11,6040) 2, MSWI(2), CH40
59993 CH40='FSI SCI/GAL sea quark treatment parm'
59994 WRITE(M11,6050) 1, PARSCI(1), CH40
59995 CH40='FSI SCI/GAL string reco probability R_0'
59996 WRITE(M11,6050) 2, PARSCI(2), CH40
59997 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
59998 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
59999 ENDIF
60000 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
60001 IF (M13.GE.1) THEN
60002 WRITE(M11,5010) ITUNE, CHNAME
60003 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
60004 WRITE(M11,5030) CH60
60005 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
60006 WRITE(M11,5030) CH60
60007 WRITE(M11,5030) ' '
60008 CH70='NB! The SCI model must be run with modified '//
60009 & 'Pythia v6.215:'
60010 WRITE(M11,5035) CH70
60011 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
60012 WRITE(M11,5035) CH70
60013 WRITE(M11,5030) ' '
60014 ENDIF
60015C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
60016 MSTP(81)=1
60017 MSTP(82)=1
60018 PARP(81)=2.2
60019 MSTP(92)=1
60020 MSWI(2)=2
60021 PARSCI(2)=0.50
60022 MSWI(1)=2
60023 PARSCI(1)=0.44
60024 MSTJ(16)=0
60025 IF (CHNAME.EQ.'SCI Tune 1') THEN
60026C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
60027 MSTP(81) = 1
60028 MSTP(82) = 3
60029 PARP(82) = 2.4
60030 PARP(83) = 0.5D0
60031 PARP(62) = 1.5
60032 PARP(84)=0.25D0
60033 IF (M13.GE.1) THEN
60034 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60035 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60036 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60037 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60038 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60039 ENDIF
60040 ELSE
60041 IF (M13.GE.1) THEN
60042 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60043 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60044 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60045 ENDIF
60046 ENDIF
60047C...Output
60048 IF (M13.GE.1) THEN
60049 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60050 CH40='FSI SCI/GAL selection'
60051 WRITE(M11,6040) 1, MSWI(1), CH40
60052 CH40='FSI SCI/GAL sea quark treatment'
60053 WRITE(M11,6040) 2, MSWI(2), CH40
60054 CH40='FSI SCI/GAL sea quark treatment parm'
60055 WRITE(M11,6050) 1, PARSCI(1), CH40
60056 CH40='FSI SCI/GAL string reco probability R_0'
60057 WRITE(M11,6050) 2, PARSCI(2), CH40
60058 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60059 ENDIF
60060
60061 ELSE
60062 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
60063
60064 ENDIF
60065
60066 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
60067
60068 9999 RETURN
60069
60070 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
60071 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
60072 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
60073 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
60074 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
60075 5030 FORMAT(' *',3x,10x,A60,3x,'*')
60076 5035 FORMAT(' *',3x,A70,3x,'*')
60077 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
60078 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
60079 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
60080 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
60081 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
60082 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
60083 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
60084 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
60085 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
60086
60087 END
60088
60089C*********************************************************************
60090
60091C...PYEXEC
60092C...Administrates the fragmentation and decay chain.
60093
60094 SUBROUTINE PYEXEC
60095
60096C...Double precision and integer declarations.
60097 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60098 IMPLICIT INTEGER(I-N)
60099 INTEGER PYK,PYCHGE,PYCOMP
60100C...Commonblocks.
60101 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60104 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60105 COMMON/PYINT1/MINT(400),VINT(400)
60106 COMMON/PYINT4/MWID(500),WIDS(500,5)
60107 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
60108C...Local array.
60109 DIMENSION PS(2,6),IJOIN(100)
60110
60111C...Initialize and reset.
60112 MSTU(24)=0
60113 IF(MSTU(12).NE.12345) CALL PYLIST(0)
60114 MSTU(29)=0
60115 MSTU(31)=MSTU(31)+1
60116 MSTU(1)=0
60117 MSTU(2)=0
60118 MSTU(3)=0
60119 IF(MSTU(17).LE.0) MSTU(90)=0
60120 MCONS=1
60121
60122C...Sum up momentum, energy and charge for starting entries.
60123 NSAV=N
60124 DO 110 I=1,2
60125 DO 100 J=1,6
60126 PS(I,J)=0D0
60127 100 CONTINUE
60128 110 CONTINUE
60129 DO 130 I=1,N
60130 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
60131 DO 120 J=1,4
60132 PS(1,J)=PS(1,J)+P(I,J)
60133 120 CONTINUE
60134 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
60135 130 CONTINUE
60136 PARU(21)=PS(1,4)
60137
60138C...Start by all decays of coloured resonances involved in shower.
60139 NORIG=N
60140 DO 140 I=1,NORIG
60141 IF(K(I,1).EQ.3) THEN
60142 KC=PYCOMP(K(I,2))
60143 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
60144 ENDIF
60145 140 CONTINUE
60146
60147C...Prepare system for subsequent fragmentation/decay.
60148 CALL PYPREP(0)
60149 IF(MINT(51).NE.0) RETURN
60150
60151C...Loop through jet fragmentation and particle decays.
60152 MBE=0
60153 150 MBE=MBE+1
60154 IP=0
60155 160 IP=IP+1
60156 KC=0
60157 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
60158 IF(KC.EQ.0) THEN
60159
60160C...Deal with any remaining undecayed resonance
60161C...(normally the task of PYEVNT, so seldom used).
60162 ELSEIF(MWID(KC).NE.0) THEN
60163 IBEG=IP
60164 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
60165 IBEG=IP+1
60166 170 IBEG=IBEG-1
60167 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
60168 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
60169 IEND=IP-1
60170 180 IEND=IEND+1
60171 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
60172 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
60173 NJOIN=0
60174 DO 190 I=IBEG,IEND
60175 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
60176 NJOIN=NJOIN+1
60177 IJOIN(NJOIN)=I
60178 ENDIF
60179 190 CONTINUE
60180 ENDIF
60181 CALL PYRESD(IP)
60182 CALL PYPREP(IBEG)
60183 IF(MINT(51).NE.0) RETURN
60184
60185C...Particle decay if unstable and allowed. Save long-lived particle
60186C...decays until second pass after Bose-Einstein effects.
60187 ELSEIF(KCHG(KC,2).EQ.0) THEN
60188 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
60189 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
60190 & CALL PYDECY(IP)
60191
60192C...Decay products may develop a shower.
60193 IF(MSTJ(92).GT.0) THEN
60194 IP1=MSTJ(92)
60195 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
60196 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
60197 MINT(33)=0
60198 CALL PYSHOW(IP1,IP1+1,QMAX)
60199 CALL PYPREP(IP1)
60200 IF(MINT(51).NE.0) RETURN
60201 MSTJ(92)=0
60202 ELSEIF(MSTJ(92).LT.0) THEN
60203 IP1=-MSTJ(92)
60204 MINT(33)=0
60205 CALL PYSHOW(IP1,-3,P(IP,5))
60206 CALL PYPREP(IP1)
60207 IF(MINT(51).NE.0) RETURN
60208 MSTJ(92)=0
60209 ENDIF
60210
60211C...Jet fragmentation: string or independent fragmentation.
60212 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
60213 MFRAG=MSTJ(1)
60214 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
60215 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
60216 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
60217 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
60218 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
60219 ENDIF
60220 ENDIF
60221 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
60222 IF(MFRAG.EQ.2) CALL PYINDF(IP)
60223 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
60224 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
60225 ENDIF
60226
60227C...Loop back if enough space left in PYJETS and no error abort.
60228 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
60229 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
60230 GOTO 160
60231 ELSEIF(IP.LT.N) THEN
60232 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
60233 ENDIF
60234
60235C...Include simple Bose-Einstein effect parametrization if desired.
60236 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
60237 CALL PYBOEI(NSAV)
60238 GOTO 150
60239 ENDIF
60240
60241C...Check that momentum, energy and charge were conserved.
60242 DO 210 I=1,N
60243 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
60244 DO 200 J=1,4
60245 PS(2,J)=PS(2,J)+P(I,J)
60246 200 CONTINUE
60247 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
60248 210 CONTINUE
60249 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
60250 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
60251 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
60252 &'(PYEXEC:) four-momentum was not conserved')
60253 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
60254 &'(PYEXEC:) charge was not conserved')
60255
60256 RETURN
60257 END
60258
60259C*********************************************************************
60260
60261C...PYPREP
60262C...Rearranges partons along strings.
60263C...Special considerations for systems with junctions, with
60264C...possibility of junction-antijunction annihilation.
60265C...Allows small systems to collapse into one or two particles.
60266C...Checks flavours and colour singlet invariant masses.
60267
60268 SUBROUTINE PYPREP(IP)
60269
60270C...Double precision and integer declarations.
60271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60272 INTEGER PYK,PYCHGE,PYCOMP
60273C...Commonblocks.
60274 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60276 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60278 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60279 COMMON/PYINT1/MINT(400),VINT(400)
60280C...The common block of colour tags.
60281 COMMON/PYCTAG/NCT,MCT(4000,2)
60282 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
60283 &/PYPARS/
60284 DATA NERRPR/0/
60285 SAVE NERRPR
60286C...Local arrays.
60287 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
60288 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
60289 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
60290 &IJCP(0:6),TJUOLD(5)
60291 CHARACTER CHTMP*6
60292
60293C...Function to give four-product.
60294 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)
60295
60296C...Rearrange parton shower product listing along strings: begin loop.
60297 MSTU(24)=0
60298 NOLD=N
60299 I1=N
60300 NJUNC=0
60301 NPIECE=0
60302 NJJSTR=0
60303 MSTU32=MSTU(32)+1
60304 DO 100 I=MAX(1,IP),N
60305C...First store junction positions.
60306 IF(K(I,1).EQ.42) THEN
60307 NJUNC=NJUNC+1
60308 IJUNC(NJUNC,0)=I
60309 IJUNC(NJUNC,4)=0
60310 ENDIF
60311 100 CONTINUE
60312
60313 DO 250 MQGST=1,3
60314 DO 240 I=MAX(1,IP),N
60315C...Special treatment for junctions
60316 IF (K(I,1).LE.0) GOTO 240
60317 IF(K(I,1).EQ.42) THEN
60318C...MQGST=2: Look for junction-junction strings (not detected in the
60319C...main search below).
60320 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
60321 IF (NJJSTR.EQ.0) THEN
60322 NJJSTR = (3*NJUNC-NPIECE)/2
60323 ENDIF
60324C...Check how many already identified strings end on this junction
60325 ILC=0
60326 DO 110 J=1,NPIECE
60327 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
60328 110 CONTINUE
60329C...If less than 3, remaining must be to another junction
60330 IF (ILC.LT.3) THEN
60331 IF (ILC.NE.2) THEN
60332C...Multiple j-j connections not handled yet.
60333 CALL PYERRM(2,
60334 & '(PYPREP:) Too many junction-junction strings.')
60335 MINT(51)=1
60336 RETURN
60337 ENDIF
60338C...The colour information in the junction is unreadable for the
60339C...colour space search further down in this routine, so we must
60340C...start on the colour mother of this junction and then "artificially"
60341C...prevent the colour mother from connecting here again.
60342 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
60343 KCS=4
60344 IF (MOD(ITJUNC,2).EQ.0) KCS=5
60345C...Switch colour if the junction-junction leg is presumably a
60346C...junction mother leg rather than a junction daughter leg.
60347 IF (ITJUNC.GE.3) KCS=9-KCS
60348 IF (MINT(33).EQ.0) THEN
60349C...Find the unconnected leg and reorder junction daughter pointers so
60350C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
60351C...piece.
60352 IA=MOD(K(I,4),MSTU(5))
60353 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
60354 ITMP=MOD(K(I,5),MSTU(5))
60355 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
60356 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
60357 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
60358 ELSE
60359 K(I,5)=K(I,5)+(IA-ITMP)
60360 ENDIF
60361 K(I,4)=K(I,4)+(ITMP-IA)
60362 IA=ITMP
60363 ENDIF
60364 IF (ITJUNC.LE.2) THEN
60365C...Beam baryon junction
60366 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
60367 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
60368C...Else 1 -> 2 decay junction
60369 ELSE
60370 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
60371 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
60372 ENDIF
60373 I1BEG = I1
60374 NSTP = 0
60375 GOTO 170
60376C...Alternatively use colour tag information.
60377 ELSE
60378C...Find a final state parton with appropriate dangling colour tag.
60379 JCT=0
60380 IA=0
60381 IJUMO=K(I,3)
60382 DO 140 J1=MAX(1,IP),N
60383 IF (K(J1,1).NE.3) GOTO 140
60384C...Check for matching final-state colour tag
60385 IMATCH=0
60386 DO 120 J2=MAX(1,IP),N
60387 IF (K(J2,1).NE.3) GOTO 120
60388 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
60389 120 CONTINUE
60390 IF (IMATCH.EQ.1) GOTO 140
60391C...Check whether this colour tag belongs to the present junction
60392C...by seeing whether any parton with this colour tag has the same
60393C...mother as the junction.
60394 JCT=MCT(J1,KCS-3)
60395 IMATCH=0
60396 DO 130 J2=MINT(84)+1,N
60397 IMO2=K(J2,3)
60398C...First scattering partons have IMO1 = 3 and 4.
60399 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
60400 & IMO2=IMO2-2
60401 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
60402 & IMATCH=1
60403 130 CONTINUE
60404 IF (IMATCH.EQ.0) GOTO 140
60405 IA=J1
60406 140 CONTINUE
60407C...Check for junction-junction strings without intermediate final state
60408C...glue (not detected above).
60409 IF (IA.EQ.0) THEN
60410 DO 160 MJU=1,NJUNC
60411 IJU2=IJUNC(MJU,0)
60412 IF (IJU2.EQ.I) GOTO 160
60413 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
60414C...Only opposite types of junctions can connect to each other.
60415 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
60416 IS=0
60417 DO 150 J=1,NPIECE
60418 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
60419 150 CONTINUE
60420 IF (IS.EQ.3) GOTO 160
60421 IB=I
60422 IA=IJU2
60423 160 CONTINUE
60424 ENDIF
60425C...Switch to other side of adjacent parton and step from there.
60426 KCS=9-KCS
60427 I1BEG = I1
60428 NSTP = 0
60429 GOTO 170
60430 ENDIF
60431 ELSE IF (ILC.NE.3) THEN
60432 ENDIF
60433 ENDIF
60434 ENDIF
60435
60436C...Look for coloured string endpoint, or (later) leftover gluon.
60437 IF(K(I,1).NE.3) GOTO 240
60438 KC=PYCOMP(K(I,2))
60439 IF(KC.EQ.0) GOTO 240
60440 KQ=KCHG(KC,2)
60441 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
60442
60443C...Pick up loose string end.
60444 KCS=4
60445 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
60446 IA=I
60447 IB=I
60448 I1BEG=I1
60449 NSTP=0
60450 170 NSTP=NSTP+1
60451 IF(NSTP.GT.4*N) THEN
60452 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
60453 MINT(51)=1
60454 RETURN
60455 ENDIF
60456
60457C...Copy undecayed parton. Finished if reached string endpoint.
60458 IF(K(IA,1).EQ.3) THEN
60459 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
60460 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60461 MINT(51)=1
60462 MSTU(24)=1
60463 RETURN
60464 ENDIF
60465 I1=I1+1
60466 K(I1,1)=2
60467 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
60468 K(I1,2)=K(IA,2)
60469 K(I1,3)=IA
60470 K(I1,4)=0
60471 K(I1,5)=0
60472 DO 180 J=1,5
60473 P(I1,J)=P(IA,J)
60474 V(I1,J)=V(IA,J)
60475 180 CONTINUE
60476 K(IA,1)=K(IA,1)+10
60477 IF(K(I1,1).EQ.1) GOTO 240
60478 ENDIF
60479
60480C...Also finished (for now) if reached junction; then copy to end.
60481 IF(K(IA,1).EQ.42) THEN
60482 NCOPY=I1-I1BEG
60483 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
60484 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60485 MINT(51)=1
60486 MSTU(24)=1
60487 RETURN
60488 ENDIF
60489 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
60490 DO 200 ICOPY=1,NCOPY
60491 DO 190 J=1,5
60492 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
60493 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
60494 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
60495 190 CONTINUE
60496 200 CONTINUE
60497 ENDIF
60498C...For junction-junction strings, find end leg and reorder junction
60499C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
60500C...junction-junction string piece.
60501 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
60502 ITMP=MOD(K(IA,4),MSTU(5))
60503 IF (ITMP.NE.IB) THEN
60504 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
60505 K(IA,5)=K(IA,5)+(ITMP-IB)
60506 ELSE
60507 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
60508 ENDIF
60509 K(IA,4)=K(IA,4)+(IB-ITMP)
60510 ENDIF
60511 ENDIF
60512 NPIECE=NPIECE+1
60513C...IPIECE:
60514C...0: endpoint in original ER
60515C...1:
60516C...2:
60517C...3: Parton immediately next to junction
60518C...4: Junction
60519 IPIECE(NPIECE,0)=I
60520 IPIECE(NPIECE,1)=MSTU32+1
60521 IPIECE(NPIECE,2)=MSTU32+NCOPY
60522 IPIECE(NPIECE,3)=IB
60523 IPIECE(NPIECE,4)=IA
60524 MSTU32=MSTU32+NCOPY
60525 I1=I1BEG
60526 GOTO 240
60527 ENDIF
60528
60529C...GOTO next parton in colour space.
60530 IB=IA
60531 IF (MINT(33).EQ.0) THEN
60532 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
60533 & )).NE.0) THEN
60534 IA=MOD(K(IB,KCS),MSTU(5))
60535 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
60536 MREV=0
60537 ELSE
60538 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
60539 & MSTU(5)).EQ.0) KCS=9-KCS
60540 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
60541 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
60542 MREV=1
60543 ENDIF
60544 IF(IA.LE.0.OR.IA.GT.N) THEN
60545 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
60546 IF(NERRPR.LT.5) THEN
60547 NERRPR=NERRPR+1
60548 WRITE(MSTU(11),*) 'started at:', I
60549 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
60550 WRITE(MSTU(11),*) 'MQGST =',MQGST
60551 CALL PYLIST(4)
60552 ENDIF
60553 MINT(51)=1
60554 RETURN
60555 ENDIF
60556 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
60557 & ,MSTU(5)).EQ.IB) THEN
60558 IF(MREV.EQ.1) KCS=9-KCS
60559 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
60560 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
60561 ELSE
60562 IF(MREV.EQ.0) KCS=9-KCS
60563 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
60564 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
60565 ENDIF
60566 IF(IA.NE.I) GOTO 170
60567C...Use colour tag information
60568 ELSE
60569C...First create colour tags starting on IB if none already present.
60570 IF (MCT(IB,KCS-3).EQ.0) THEN
60571 CALL PYCTTR(IB,KCS,IB)
60572 IF(MINT(51).NE.0) RETURN
60573 ENDIF
60574 JCT=MCT(IB,KCS-3)
60575 IFOUND=0
60576C...Find final state tag partner
60577 DO 210 IT=MAX(1,IP),N
60578 IF (IT.EQ.IB) GOTO 210
60579 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
60580 & .0) THEN
60581 IFOUND=IFOUND+1
60582 IA=IT
60583 ENDIF
60584 210 CONTINUE
60585C...Just copy and goto next if exactly one partner found.
60586 IF (IFOUND.EQ.1) THEN
60587 GOTO 170
60588C...When no match found, match is presumably junction.
60589 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
60590C...Check whether this colour tag matches a junction
60591C...by seeing whether any parton with this colour tag has the same
60592C...mother as a junction.
60593C...NB: Only type 1 and 2 junctions handled presently.
60594 DO 230 IJU=1,NJUNC
60595 IJUMO=K(IJUNC(IJU,0),3)
60596 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
60597C...Colours only connect to junctions, anti-colours to antijunctions:
60598 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
60599 IMATCH=0
60600 DO 220 J1=MAX(1,IP),N
60601 IF (K(J1,1).LE.0) GOTO 220
60602C...First scattering partons have IMO1 = 3 and 4.
60603 IMO=K(J1,3)
60604 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
60605 & IMO=IMO-2
60606 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
60607 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
60608 & IMATCH=1
60609C...Attempt at handling type > 3 junctions also. Not tested.
60610 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
60611 & .IJUMO) IMATCH=1
60612 220 CONTINUE
60613 IF (IMATCH.EQ.0) GOTO 230
60614 IA=IJUNC(IJU,0)
60615 IFOUND=IFOUND+1
60616 230 CONTINUE
60617
60618 IF (IFOUND.EQ.1) THEN
60619 GOTO 170
60620 ELSEIF (IFOUND.EQ.0) THEN
60621 WRITE(CHTMP,*) JCT
60622 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
60623 & //CHTMP)
60624 IF(NERRPR.LT.5) THEN
60625 NERRPR=NERRPR+1
60626 CALL PYLIST(4)
60627 ENDIF
60628 MINT(51)=1
60629 RETURN
60630 ENDIF
60631 ELSEIF (IFOUND.GE.2) THEN
60632 WRITE(CHTMP,*) JCT
60633 CALL PYERRM(12
60634 & ,'(PYPREP:) too many occurences of colour line: '//
60635 & CHTMP)
60636 IF(NERRPR.LT.5) THEN
60637 NERRPR=NERRPR+1
60638 CALL PYLIST(4)
60639 ENDIF
60640 MINT(51)=1
60641 RETURN
60642 ENDIF
60643 ENDIF
60644 K(I1,1)=1
60645 240 CONTINUE
60646 250 CONTINUE
60647
60648C...Junction systems remain.
60649 IJU=0
60650 IJUS=0
60651 IJUCNT=0
60652 MREV=0
60653 IJJSTR=0
60654 260 IJUCNT=IJUCNT+1
60655 IF (IJUCNT.LE.NJUNC) THEN
60656C...If we are not processing a j-j string, treat this junction as new.
60657 IF (IJJSTR.EQ.0) THEN
60658 IJU=IJUNC(IJUCNT,0)
60659 MREV=0
60660C...If junction has already been read, ignore it.
60661 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
60662C...If we are on a j-j string, goto second j-j junction.
60663 ELSE
60664 IJUCNT=IJUCNT-1
60665 IJU=IJUS
60666 ENDIF
60667C...Mark selected junction read.
60668 DO 270 J=1,NJUNC
60669 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
60670 270 CONTINUE
60671C...Determine junction type
60672 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
60673C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
60674C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
60675C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
60676 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
60677 IHK=0
60678 280 IHK=IHK+1
60679C...Find which quarks belong to given junction.
60680 IHF=0
60681 DO 290 IPC=1,NPIECE
60682 IF (IPIECE(IPC,4).EQ.IJU) THEN
60683 IHF=IHF+1
60684 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
60685 ENDIF
60686 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
60687 290 CONTINUE
60688C...IHK = 3 is special. Either normal string piece, or j-j string.
60689 IF(IHK.EQ.3) THEN
60690 IF (MREV.NE.1) THEN
60691 DO 300 IPC=1,NPIECE
60692C...If there is a j-j string starting on the present junction which has
60693C...zero length, insert next junction immediately.
60694 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
60695 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
60696 IJJSTR = 1
60697 GOTO 340
60698 ENDIF
60699 300 CONTINUE
60700 MREV = 1
60701C...If MREV is 1 and IHK is 3 we are finished with this system.
60702 ELSE
60703 MREV=0
60704 GOTO 260
60705 ENDIF
60706 ENDIF
60707
60708C...If we've gotten this far, then either IHK < 3, or
60709C...an interjunction string exists, or just a third normal string.
60710 IJUNC(IJUCNT,IHK)=0
60711 IJJSTR = 0
60712C..Order pieces belonging to this junction. Also look for j-j.
60713 DO 310 IPC=1,NPIECE
60714 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
60715 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
60716 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
60717 IJUNC(IJUCNT,IHK)=IPC
60718 IJJSTR = 1
60719 MREV = 0
60720 ENDIF
60721 310 CONTINUE
60722C...Copy back chains in proper order. MREV=0/1 : descending/ascending
60723 IPC=IJUNC(IJUCNT,IHK)
60724C...Temporary solution to cover for bug.
60725 IF(IPC.LE.0) THEN
60726 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
60727 MINT(51)=1
60728 RETURN
60729 ENDIF
60730 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
60731 I1=I1+1
60732 DO 320 J=1,5
60733 K(I1,J)=K(MSTU(4)-ICP,J)
60734 P(I1,J)=P(MSTU(4)-ICP,J)
60735 V(I1,J)=V(MSTU(4)-ICP,J)
60736 320 CONTINUE
60737 330 CONTINUE
60738 K(I1,1)=2
60739C...Mark last quark.
60740 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
60741C...Do not insert junctions at wrong places.
60742 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
60743C...Insert junction.
60744 340 IJUS = IJU
60745 IF (IHK.EQ.3) THEN
60746C...Shift to end junction if a j-j string has been processed.
60747 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
60748 MREV= 1
60749 ENDIF
60750 I1=I1+1
60751 DO 350 J=1,5
60752 K(I1,J)=0
60753 P(I1,J)=0.
60754 V(I1,J)=0.
60755 350 CONTINUE
60756 K(I1,1)=41
60757 K(IJUS,1)=K(IJUS,1)+10
60758 K(I1,2)=K(IJUS,2)
60759 K(I1,3)=IJUS
60760 360 IF (IHK.LT.3) GOTO 280
60761 ELSE
60762 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
60763 MINT(51)=1
60764 RETURN
60765 ENDIF
60766 IF (IJUCNT.NE.NJUNC) GOTO 260
60767 ENDIF
60768 N=I1
60769
60770C...Rearrange three strings from junction, e.g. in case one has been
60771C...shortened by shower, so the last is the largest-energy one.
60772 IF(NJUNC.GE.1) THEN
60773C...Find systems with exactly one junction.
60774 MJUN1=0
60775 NBEG=NOLD+1
60776 DO 470 I=NOLD+1,N
60777 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
60778 ELSEIF(K(I,1).EQ.41) THEN
60779 MJUN1=MJUN1+1
60780 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
60781 MJUN1=0
60782 NBEG=I+1
60783 ELSE
60784 NEND=I
60785C...Sum up energy-momentum in each junction string.
60786 DO 370 J=1,5
60787 PJU(1,J)=0D0
60788 PJU(2,J)=0D0
60789 PJU(3,J)=0D0
60790 370 CONTINUE
60791 NJU=0
60792 DO 390 I1=NBEG,NEND
60793 IF(K(I1,2).NE.21) THEN
60794 NJU=NJU+1
60795 IJUR(NJU)=I1
60796 ENDIF
60797 DO 380 J=1,5
60798 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
60799 380 CONTINUE
60800 390 CONTINUE
60801C...Find which of them has highest energy (minus mass) in rest frame.
60802 DO 400 J=1,5
60803 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
60804 400 CONTINUE
60805 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
60806 & PJU(4,3)**2))
60807 DO 410 I2=1,3
60808 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
60809 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
60810 410 CONTINUE
60811 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
60812C...Decide how to rearrange so that new last has highest energy.
60813 IF(PJU(1,6).LT.PJU(2,6)) THEN
60814 IRNG(1,1)=IJUR(1)
60815 IRNG(1,2)=IJUR(2)-1
60816 IRNG(2,1)=IJUR(4)
60817 IRNG(2,2)=IJUR(3)+1
60818 IRNG(4,1)=IJUR(3)-1
60819 IRNG(4,2)=IJUR(2)
60820 ELSE
60821 IRNG(1,1)=IJUR(4)
60822 IRNG(1,2)=IJUR(3)+1
60823 IRNG(2,1)=IJUR(2)
60824 IRNG(2,2)=IJUR(3)-1
60825 IRNG(4,1)=IJUR(2)-1
60826 IRNG(4,2)=IJUR(1)
60827 ENDIF
60828 IRNG(3,1)=IJUR(3)
60829 IRNG(3,2)=IJUR(3)
60830C...Copy in correct order below bottom of current event record.
60831 I2=N
60832 DO 440 II=1,4
60833 DO 430 I1=IRNG(II,1),IRNG(II,2),
60834 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
60835 I2=I2+1
60836 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
60837 CALL PYERRM(11,
60838 & '(PYPREP:) no more memory left in PYJETS')
60839 MINT(51)=1
60840 MSTU(24)=1
60841 RETURN
60842 ENDIF
60843 DO 420 J=1,5
60844 K(I2,J)=K(I1,J)
60845 P(I2,J)=P(I1,J)
60846 V(I2,J)=V(I1,J)
60847 420 CONTINUE
60848 IF(K(I2,1).EQ.1) K(I2,1)=2
60849 430 CONTINUE
60850 440 CONTINUE
60851 K(I2,1)=1
60852C...Copy back up, overwriting but now in correct order.
60853 DO 460 I1=NBEG,NEND
60854 I2=I1-NBEG+N+1
60855 DO 450 J=1,5
60856 K(I1,J)=K(I2,J)
60857 P(I1,J)=P(I2,J)
60858 V(I1,J)=V(I2,J)
60859 450 CONTINUE
60860 460 CONTINUE
60861 ENDIF
60862 MJUN1=0
60863 NBEG=I+1
60864 ENDIF
60865 470 CONTINUE
60866
60867C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
60868C...to two q-qbar systems.
60869C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
60870 IF (MSTJ(19).NE.1) THEN
60871 MJUN1 = 0
60872 JJGLUE = 0
60873 NBEG = NOLD+1
60874C...Force collapse when MSTJ(19)=2.
60875 IF (MSTJ(19).EQ.2) THEN
60876 DELMJJ = 1D9
60877 DELMQQ = 0D0
60878 ENDIF
60879C...Find systems with exactly two junctions.
60880 DO 700 I=NOLD+1,N
60881C...Count junctions
60882 IF (K(I,1).EQ.41) THEN
60883 MJUN1 = MJUN1+1
60884C...Check for interjunction gluons
60885 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
60886 JJGLUE = 1
60887 ENDIF
60888 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
60889C...If end of system reached with either zero or one junction, restart
60890C...with next system.
60891 MJUN1 = 0
60892 JJGLUE = 0
60893 NBEG = I+1
60894 ELSEIF(K(I,1).EQ.1) THEN
60895C...If end of system reached with exactly two junctions, compute string
60896C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
60897C...length measure for the (q-qbar)(q-qbar) topology.
60898 NEND=I
60899C...Loop down through chain.
60900 ISID=0
60901 DO 480 I1=NBEG,NEND
60902C...Store string piece division locations in event record
60903 IF (K(I1,2).NE.21) THEN
60904 ISID = ISID+1
60905 IJCP(ISID) = I1
60906 ENDIF
60907 480 CONTINUE
60908C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
60909 ISW=0
60910 IF (PYR(0).LT.0.5D0) ISW=1
60911C...Randomly choose which qqbar string gets the jj gluons.
60912 IGS=1
60913 IF (PYR(0).GT.0.5D0) IGS=2
60914C...Only compute string lengths when no topology forced.
60915 IF (MSTJ(19).EQ.0) THEN
60916C...Repeat following for each junction
60917 DO 570 IJU=1,2
60918C...Initialize iterative procedure for finding JRF
60919 IJRFIT=0
60920 DO 490 IX=1,3
60921 TJUOLD(IX)=0D0
60922 490 CONTINUE
60923 TJUOLD(4)=1D0
60924C...Start iteration. Sum up momenta in string pieces
60925 500 DO 540 IJS=1,3
60926C...JD=-1 for first junction, +1 for second junction.
60927C...Find out where piece starts and ends and which direction to go.
60928 JD=2*IJU-3
60929 IF (IJS.LE.2) THEN
60930 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
60931 IB = IJCP((IJU-1)*7 - JD*IJS)
60932 ELSEIF (IJS.EQ.3) THEN
60933 JD =-JD
60934 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
60935 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
60936 ENDIF
60937C...Initialize junction pull 4-vector.
60938 DO 510 J=1,5
60939 PUL(IJS,J)=0D0
60940 510 CONTINUE
60941C...Initialize weight
60942 PWT = 0D0
60943 PWTOLD = 0D0
60944C...Sum up (weighted) momenta along each string piece
60945 DO 530 ISP=IA,IB,JD
60946C...If present parton not last in chain
60947 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
60948C...If last parton was a junction, store present weight
60949 IF (K(ISP-JD,2).EQ.88) THEN
60950 PWTOLD = PWT
60951C...If last parton was a quark, reset to stored weight.
60952 ELSEIF (K(ISP-JD,2).NE.21) THEN
60953 PWT = PWTOLD
60954 ENDIF
60955 ENDIF
60956C...Skip next parton if weight already large
60957 IF (PWT.GT.10D0) GOTO 530
60958C...Compute momentum in TJUOLD frame:
60959 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
60960 & )*P(ISP,3)
60961 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
60962 DO 520 J=1,3
60963 TMP=P(ISP,J)+TJUOLD(J)*BFC
60964 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
60965 520 CONTINUE
60966C...Boosted energy
60967 TMP=TJUOLD(4)*P(ISP,4)+TDP
60968 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
60969C...Update weight
60970 PWT=PWT+TMP/PARJ(48)
60971C...Put |p| rather than m in 5th slot
60972 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
60973 & +PUL(IJS,3)**2)
60974 530 CONTINUE
60975 540 CONTINUE
60976C...Compute boost
60977 IJRFIT=IJRFIT+1
60978 CALL PYJURF(PUL,T)
60979C...Combine new boost (T) with old boost (TJUOLD)
60980 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
60981 DO 550 IX=1,3
60982 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
60983 & ))
60984 550 CONTINUE
60985 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
60986 & **2)
60987C...If last boost small, accept JRF, else iterate.
60988C...Also prevent possibility of infinite loop.
60989 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
60990 & IJRFIT.LT.MSTJ(18))THEN
60991 GOTO 500
60992 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
60993 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
60994 ENDIF
60995C...Store final boost, with change of sign since TJJ motion vector.
60996 DO 560 IX=1,3
60997 TJJ(IJU,IX)=-TJUOLD(IX)
60998 560 CONTINUE
60999 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
61000 & +TJJ(IJU,3)**2)
61001 570 CONTINUE
61002C...String length measure for (q-qbar)(q-qbar) topology.
61003C...Note only momenta of nearest partons used (since rest of system
61004C...identical).
61005 IF (JJGLUE.EQ.0) THEN
61006 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
61007 & -1,IJCP(5-ISW)+1)
61008 ELSE
61009C...Put jj gluons on selected string (IGS selected randomly above).
61010 IF (IGS.EQ.1) THEN
61011 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61012 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
61013 ELSE
61014 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
61015 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61016 & ,IJCP(5-ISW)+1)
61017 ENDIF
61018 ENDIF
61019C...String length measure for q-q-j-j-q-q topology.
61020 T1G1=0D0
61021 T2G2=0D0
61022 T1T2=0D0
61023 T1P1=0D0
61024 T1P2=0D0
61025 T2P3=0D0
61026 T2P4=0D0
61027 ISGN=-1
61028C...Note only momenta of nearest partons used (since rest of system
61029C...identical).
61030 DO 580 IX=1,4
61031 IF (IX.EQ.4) ISGN=1
61032 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
61033 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
61034 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
61035 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
61036 IF (JJGLUE.EQ.0) THEN
61037C...Junction motion vector dot product gives length when inter-junction
61038C...gluons absent.
61039 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
61040 ELSE
61041C...Junction motion vector dot products with gluon momenta give length
61042C...when inter-junction gluons present.
61043 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
61044 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
61045 ENDIF
61046 580 CONTINUE
61047 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
61048 IF (JJGLUE.EQ.0) THEN
61049 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
61050 ELSE
61051 DELMJJ=DELMJJ*4D0*T1G1*T2G2
61052 ENDIF
61053 ENDIF
61054C...If delmjj > delmqq collapse string system to q-qbar q-qbar
61055C...(Always the case for MSTJ(19)=2 due to initialization above)
61056 IF (DELMJJ.GT.DELMQQ) THEN
61057C...Put new system at end of event record
61058 NCOP=N
61059 DO 650 IST=1,2
61060 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
61061 NCOP=NCOP+1
61062 DO 590 IX=1,5
61063 P(NCOP,IX)=P(ICOP,IX)
61064 K(NCOP,IX)=K(ICOP,IX)
61065 590 CONTINUE
61066 600 CONTINUE
61067 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
61068C...Insert inter-junction gluon string piece (reversed)
61069 NJJGL=0
61070 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
61071 NJJGL=NJJGL+1
61072 NCOP=NCOP+1
61073 DO 610 IX=1,5
61074 P(NCOP,IX)=P(ICOP,IX)
61075 K(NCOP,IX)=K(ICOP,IX)
61076 610 CONTINUE
61077 620 CONTINUE
61078 ENDIF
61079 IFC=-2*IST+3
61080 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
61081 NCOP=NCOP+1
61082 DO 630 IX=1,5
61083 P(NCOP,IX)=P(ICOP,IX)
61084 K(NCOP,IX)=K(ICOP,IX)
61085 630 CONTINUE
61086 640 CONTINUE
61087 K(NCOP,1)=1
61088 650 CONTINUE
61089C...Copy system back in right order
61090 DO 670 ICOP=NBEG,NEND-2
61091 DO 660 IX=1,5
61092 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
61093 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
61094 660 CONTINUE
61095 670 CONTINUE
61096C...Shift down rest of event record
61097 DO 690 ICOP=NEND+1,N
61098 DO 680 IX=1,5
61099 P(ICOP-2,IX)=P(ICOP,IX)
61100 K(ICOP-2,IX)=K(ICOP,IX)
61101 680 CONTINUE
61102 690 CONTINUE
61103C...Update length of event record.
61104 N=N-2
61105 ENDIF
61106 MJUN1=0
61107 NBEG=I+1
61108 ENDIF
61109 700 CONTINUE
61110 ENDIF
61111 ENDIF
61112
61113C...Done if no checks on small-mass systems.
61114 IF(MSTJ(14).LT.0) RETURN
61115 IF(MSTJ(14).EQ.0) GOTO 1140
61116
61117C...Find lowest-mass colour singlet jet system.
61118 NS=N
61119 710 NSIN=N-NS
61120 PDMIN=1D0+PARJ(32)
61121 IC=0
61122 DO 770 I=MAX(1,IP),N
61123 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
61124 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
61125 NSIN=NSIN+1
61126 IC=I
61127 DO 720 J=1,4
61128 DPS(J)=P(I,J)
61129 720 CONTINUE
61130 MSTJ(93)=1
61131 DPS(5)=PYMASS(K(I,2))
61132 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
61133 DO 730 J=1,4
61134 DPS(J)=DPS(J)+P(I,J)
61135 730 CONTINUE
61136 MSTJ(93)=1
61137 DPS(5)=DPS(5)+PYMASS(K(I,2))
61138 ELSEIF(K(I,1).EQ.2) THEN
61139 DO 740 J=1,4
61140 DPS(J)=DPS(J)+P(I,J)
61141 740 CONTINUE
61142 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61143 DO 750 J=1,4
61144 DPS(J)=DPS(J)+P(I,J)
61145 750 CONTINUE
61146 MSTJ(93)=1
61147 DPS(5)=DPS(5)+PYMASS(K(I,2))
61148 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
61149 & DPS(5)
61150 IF(PD.LT.PDMIN) THEN
61151 PDMIN=PD
61152 DO 760 J=1,5
61153 DPC(J)=DPS(J)
61154 760 CONTINUE
61155 IC1=IC
61156 IC2=I
61157 ENDIF
61158 IC=0
61159 ELSE
61160 NSIN=NSIN+1
61161 ENDIF
61162 770 CONTINUE
61163
61164C...Done if lowest-mass system above threshold for string frag.
61165 IF(PDMIN.GE.PARJ(32)) GOTO 1140
61166
61167C...Fill small-mass system as cluster.
61168 NSAV=N
61169 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
61170 K(N+1,1)=11
61171 K(N+1,2)=91
61172 K(N+1,3)=IC1
61173 P(N+1,1)=DPC(1)
61174 P(N+1,2)=DPC(2)
61175 P(N+1,3)=DPC(3)
61176 P(N+1,4)=DPC(4)
61177 P(N+1,5)=PECM
61178
61179C...Set up history, assuming cluster -> 2 hadrons.
61180 NBODY=2
61181 K(N+1,4)=N+2
61182 K(N+1,5)=N+3
61183 K(N+2,1)=1
61184 K(N+3,1)=1
61185 IF(MSTU(16).NE.2) THEN
61186 K(N+2,3)=N+1
61187 K(N+3,3)=N+1
61188 ELSE
61189 K(N+2,3)=IC1
61190 K(N+3,3)=IC2
61191 ENDIF
61192 K(N+2,4)=0
61193 K(N+3,4)=0
61194 K(N+2,5)=0
61195 K(N+3,5)=0
61196 V(N+1,5)=0D0
61197 V(N+2,5)=0D0
61198 V(N+3,5)=0D0
61199
61200C...Find total flavour content - complicated by presence of junctions.
61201 NQ=0
61202 NDIQ=0
61203 DO 780 I=IC1,IC2
61204 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
61205 NQ=NQ+1
61206 KFQ(NQ)=K(I,2)
61207 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
61208 ENDIF
61209 780 CONTINUE
61210
61211C...If several diquarks, split up one to give even number of flavours.
61212 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
61213 I1=3
61214 IF(IABS(KFQ(3)).LT.1000) I1=1
61215 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
61216 KFQ(I1)=KFQ(I1)/1000
61217 NQ=4
61218 NDIQ=NDIQ-1
61219 ENDIF
61220
61221C...If four quark ends, join two to diquark.
61222 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
61223 I1=1
61224 I2=2
61225 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
61226 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
61227 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61228 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61229 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61230 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61231 KFQ(I2)=KFQ(4)
61232 NQ=3
61233 NDIQ=1
61234 ENDIF
61235
61236C...If two quark ends, plus quark or diquark, join quarks to diquark.
61237 IF(NQ.EQ.3) THEN
61238 I1=1
61239 I2=2
61240 IF(IABS(KFQ(I1)).GT.1000) I1=3
61241 IF(IABS(KFQ(I2)).GT.1000) I2=3
61242 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61243 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61244 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61245 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61246 KFQ(I2)=KFQ(3)
61247 NQ=2
61248 NDIQ=NDIQ+1
61249 ENDIF
61250
61251C...Form two particles from flavours of lowest-mass system, if feasible.
61252 NTRY = 0
61253 790 NTRY = NTRY + 1
61254
61255C...Open string with two specified endpoint flavours.
61256 IF(NQ.EQ.2) THEN
61257 KC1=PYCOMP(KFQ(1))
61258 KC2=PYCOMP(KFQ(2))
61259 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
61260 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61261 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61262 IF(KQ1+KQ2.NE.0) GOTO 1140
61263C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
61264 800 K1=KFQ(1)
61265 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
61266 MSTU(125)=0
61267 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
61268 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
61269 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
61270
61271C...Open string with four specified flavours.
61272 ELSEIF(NQ.EQ.4) THEN
61273 KC1=PYCOMP(KFQ(1))
61274 KC2=PYCOMP(KFQ(2))
61275 KC3=PYCOMP(KFQ(3))
61276 KC4=PYCOMP(KFQ(4))
61277 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
61278 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61279 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61280 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
61281 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
61282 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
61283C...Combine flavours pairwise to form two hadrons.
61284 810 I1=1
61285 I2=2
61286 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61287 & IABS(KFQ(2)).GT.1000)) I2=3
61288 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61289 & IABS(KFQ(3)).GT.1000))) I2=4
61290 I3=3
61291 IF(I2.EQ.3) I3=2
61292 I4=10-I1-I2-I3
61293 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
61294 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
61295 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
61296
61297C...Closed string.
61298 ELSE
61299 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
61300C...No room for popcorn mesons in closed string -> 2 hadrons.
61301 MSTU(125)=0
61302 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
61303 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
61304 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
61305 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
61306 ENDIF
61307 P(N+2,5)=PYMASS(K(N+2,2))
61308 P(N+3,5)=PYMASS(K(N+3,2))
61309
61310C...If it does not work: try again (a number of times), give up (if no
61311C...place to shuffle momentum or too many flavours), or form one hadron.
61312 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
61313 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
61314 GOTO 790
61315 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
61316 GOTO 1140
61317 ELSE
61318 GOTO 890
61319 END IF
61320 END IF
61321
61322C...Perform two-particle decay of jet system.
61323C...First step: find reference axis in decaying system rest frame.
61324C...(Borrow slot N+2 for temporary direction.)
61325 DO 830 J=1,4
61326 P(N+2,J)=P(IC1,J)
61327 830 CONTINUE
61328 DO 850 I=IC1+1,IC2-1
61329 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61330 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61331 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
61332 DO 840 J=1,4
61333 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
61334 840 CONTINUE
61335 ENDIF
61336 850 CONTINUE
61337 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
61338 &-DPC(3)/DPC(4))
61339 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
61340 PHI1=PYANGL(P(N+2,1),P(N+2,2))
61341
61342C...Second step: generate isotropic/anisotropic decay.
61343 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
61344 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
61345 860 UE(3)=PYR(0)
61346 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
61347 PT2=(1D0-UE(3)**2)*PA**2
61348 IF(MSTJ(16).LE.0) THEN
61349 PREV=0.5D0
61350 ELSE
61351 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
61352 PR1=P(N+2,5)**2+PT2
61353 PR2=P(N+3,5)**2+PT2
61354 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
61355 PREVCF=PARJ(42)
61356 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61357 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
61358 ENDIF
61359 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
61360 PHI=PARU(2)*PYR(0)
61361 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
61362 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
61363 DO 870 J=1,3
61364 P(N+2,J)=PA*UE(J)
61365 P(N+3,J)=-PA*UE(J)
61366 870 CONTINUE
61367 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
61368 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
61369
61370C...Third step: move back to event frame and set production vertex.
61371 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
61372 &DPC(3)/DPC(4))
61373 DO 880 J=1,4
61374 V(N+1,J)=V(IC1,J)
61375 V(N+2,J)=V(IC1,J)
61376 V(N+3,J)=V(IC2,J)
61377 880 CONTINUE
61378 N=N+3
61379 GOTO 1120
61380
61381C...Else form one particle, if possible.
61382 890 NBODY=1
61383 K(N+1,5)=N+2
61384 DO 900 J=1,4
61385 V(N+1,J)=V(IC1,J)
61386 V(N+2,J)=V(IC1,J)
61387 900 CONTINUE
61388
61389C...Select hadron flavour from available quark flavours.
61390 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
61391 GOTO 1140
61392 ELSEIF(NQ.EQ.2) THEN
61393 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
61394 ELSE
61395 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
61396 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
61397 ENDIF
61398 IF(K(N+2,2).EQ.0) GOTO 910
61399 P(N+2,5)=PYMASS(K(N+2,2))
61400
61401C...Use old algorithm for E/p conservation? (EN)
61402 IF (MSTJ(16).LE.0) GOTO 1080
61403
61404C...Find the string piece closest to the cluster by a loop
61405C...over the undecayed partons not in present cluster. (EN)
61406 DGLOMI=1D30
61407 IBEG=0
61408 I0=0
61409 NJUNC=0
61410 DO 940 I1=MAX(1,IP),N-1
61411 IF(K(I1,1).EQ.1) NJUNC=0
61412 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
61413 IF(K(I1,1).EQ.41) GOTO 940
61414 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
61415 I0=0
61416 ELSEIF(K(I1,1).EQ.2) THEN
61417 IF(I0.EQ.0) I0=I1
61418 I2=I1
61419 920 I2=I2+1
61420 IF(K(I2,1).EQ.41) GOTO 940
61421 IF(K(I2,1).GT.10) GOTO 920
61422 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
61423 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
61424 & NJUNC.EQ.0) GOTO 940
61425 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
61426 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
61427 & K(I2,1).NE.1)) GOTO 940
61428
61429C...Define velocity vectors e1, e2, ecl and differences e3, e4.
61430 DO 930 J=1,3
61431 E1(J)=P(I1,J)/P(I1,4)
61432 E2(J)=P(I2,J)/P(I2,4)
61433 ECL(J)=P(N+1,J)/P(N+1,4)
61434 E3(J)=E2(J)-E1(J)
61435 E4(J)=ECL(J)-E1(J)
61436 930 CONTINUE
61437
61438C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
61439 E3S=E3(1)**2+E3(2)**2+E3(3)**2
61440 E4S=E4(1)**2+E4(2)**2+E4(3)**2
61441 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
61442 IF(E34.LE.0D0) THEN
61443 DDMIN=E4S
61444 ELSEIF(E34.LT.E3S) THEN
61445 DDMIN=E4S-E34**2/E3S
61446 ELSE
61447 DDMIN=E4S-2D0*E34+E3S
61448 ENDIF
61449
61450C...Is this the smallest so far?
61451 IF(DDMIN.LT.DGLOMI) THEN
61452 DGLOMI=DDMIN
61453 IBEG=I0
61454 IPCS=I1
61455 ENDIF
61456 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
61457 I0=0
61458 ENDIF
61459 940 CONTINUE
61460
61461C... Check if there are any strings to connect to the new gluon. (EN)
61462 IF (IBEG.EQ.0) GOTO 1080
61463
61464C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
61465 IF (P(N+1,5).GE.P(N+2,5)) THEN
61466
61467C...Construct 'gluon' that is needed to put hadron on the mass shell.
61468 FRAC=P(N+2,5)/P(N+1,5)
61469 DO 950 J=1,5
61470 P(N+2,J)=FRAC*P(N+1,J)
61471 PG(J)=(1D0-FRAC)*P(N+1,J)
61472 950 CONTINUE
61473
61474C... Copy string with new gluon put in.
61475 N=N+2
61476 I=IBEG-1
61477 960 I=I+1
61478 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
61479 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
61480 N=N+1
61481 DO 970 J=1,5
61482 K(N,J)=K(I,J)
61483 P(N,J)=P(I,J)
61484 V(N,J)=V(I,J)
61485 970 CONTINUE
61486 K(I,1)=K(I,1)+10
61487 K(I,4)=N
61488 K(I,5)=N
61489 K(N,3)=I
61490 IF(I.EQ.IPCS) THEN
61491 N=N+1
61492 DO 980 J=1,5
61493 K(N,J)=K(N-1,J)
61494 P(N,J)=PG(J)
61495 V(N,J)=V(N-1,J)
61496 980 CONTINUE
61497 K(N,2)=21
61498 K(N,3)=NSAV+1
61499 ENDIF
61500 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
61501 GOTO 1120
61502
61503C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
61504C...from string piece endpoints.
61505 ELSE
61506
61507C...Begin by copying string that should give energy to cluster.
61508 N=N+2
61509 I=IBEG-1
61510 990 I=I+1
61511 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
61512 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
61513 N=N+1
61514 DO 1000 J=1,5
61515 K(N,J)=K(I,J)
61516 P(N,J)=P(I,J)
61517 V(N,J)=V(I,J)
61518 1000 CONTINUE
61519 K(I,1)=K(I,1)+10
61520 K(I,4)=N
61521 K(I,5)=N
61522 K(N,3)=I
61523 IF(I.EQ.IPCS) I1=N
61524 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
61525 I2=I1+1
61526
61527C...Set initial Phad.
61528 DO 1010 J=1,4
61529 P(NSAV+2,J)=P(NSAV+1,J)
61530 1010 CONTINUE
61531
61532C...Calculate Pg, a part of which will be added to Phad later. (EN)
61533 1020 IF(MSTJ(16).EQ.1) THEN
61534 ALPHA=1D0
61535 BETA=1D0
61536 ELSE
61537 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
61538 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
61539 ENDIF
61540 DO 1030 J=1,4
61541 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
61542 1030 CONTINUE
61543 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
61544
61545C..Solve 2nd order equation, use the best (smallest) solution. (EN)
61546 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
61547 & P(NSAV+2,3)**2
61548 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
61549 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
61550 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
61551
61552C...If all gluon energy eaten, zero it and take a step back.
61553 ITER=0
61554 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
61555 ITER=1
61556 DO 1040 J=1,4
61557 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
61558 P(I1,J)=0D0
61559 1040 CONTINUE
61560 P(I1,5)=0D0
61561 K(I1,1)=K(I1,1)+10
61562 I1=I1-1
61563 IF(K(I1,1).EQ.41) ITER=-1
61564 ENDIF
61565 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
61566 ITER=1
61567 DO 1050 J=1,4
61568 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
61569 P(I2,J)=0D0
61570 1050 CONTINUE
61571 P(I2,5)=0D0
61572 K(I2,1)=K(I2,1)+10
61573 I2=I2+1
61574 IF(K(I2,1).EQ.41) ITER=-1
61575 ENDIF
61576 IF(ITER.EQ.1) GOTO 1020
61577
61578C...If also all endpoint energy eaten, revert to old procedure.
61579 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
61580 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
61581 DO 1060 I=NSAV+3,N
61582 IM=K(I,3)
61583 K(IM,1)=K(IM,1)-10
61584 K(IM,4)=0
61585 K(IM,5)=0
61586 1060 CONTINUE
61587 N=NSAV
61588 GOTO 1080
61589 ENDIF
61590
61591C... Construct the collapsed hadron and modified string partons.
61592 DO 1070 J=1,4
61593 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
61594 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
61595 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
61596 1070 CONTINUE
61597 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
61598 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
61599
61600C...Finished with string collapse in new scheme.
61601 GOTO 1120
61602 ENDIF
61603
61604C... Use old algorithm; by choice or when in trouble.
61605 1080 CONTINUE
61606C...Find parton/particle which combines to largest extra mass.
61607 IR=0
61608 HA=0D0
61609 HSM=0D0
61610 DO 1100 MCOMB=1,3
61611 IF(IR.NE.0) GOTO 1100
61612 DO 1090 I=MAX(1,IP),N
61613 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
61614 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
61615 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
61616 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
61617 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
61618 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
61619 & GOTO 1090
61620 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
61621 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
61622 IF(HSR.GT.HSM) THEN
61623 IR=I
61624 HA=HCR
61625 HSM=HSR
61626 ENDIF
61627 1090 CONTINUE
61628 1100 CONTINUE
61629
61630C...Shuffle energy and momentum to put new particle on mass shell.
61631 IF(IR.NE.0) THEN
61632 HB=PECM**2+HA
61633 HC=P(N+2,5)**2+HA
61634 HD=P(IR,5)**2+HA
61635 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
61636 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
61637 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
61638 DO 1110 J=1,4
61639 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
61640 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
61641 1110 CONTINUE
61642 N=N+2
61643 ELSE
61644 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
61645 RETURN
61646 ENDIF
61647
61648C...Mark collapsed system and store daughter pointers. Iterate.
61649 1120 DO 1130 I=IC1,IC2
61650 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61651 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61652 K(I,1)=K(I,1)+10
61653 IF(MSTU(16).NE.2) THEN
61654 K(I,4)=NSAV+1
61655 K(I,5)=NSAV+1
61656 ELSE
61657 K(I,4)=NSAV+2
61658 K(I,5)=NSAV+1+NBODY
61659 ENDIF
61660 ENDIF
61661 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
61662 1130 CONTINUE
61663 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
61664
61665C...Check flavours and invariant masses in parton systems.
61666 1140 NP=0
61667 KFN=0
61668 KQS=0
61669 NJU=0
61670 DO 1150 J=1,5
61671 DPS(J)=0D0
61672 1150 CONTINUE
61673 DO 1180 I=MAX(1,IP),N
61674 IF(K(I,1).EQ.41) NJU=NJU+1
61675 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
61676 KC=PYCOMP(K(I,2))
61677 IF(KC.EQ.0) GOTO 1180
61678 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61679 IF(KQ.EQ.0) GOTO 1180
61680 NP=NP+1
61681 IF(KQ.NE.2) THEN
61682 KFN=KFN+1
61683 KQS=KQS+KQ
61684 MSTJ(93)=1
61685 DPS(5)=DPS(5)+PYMASS(K(I,2))
61686 ENDIF
61687 DO 1160 J=1,4
61688 DPS(J)=DPS(J)+P(I,J)
61689 1160 CONTINUE
61690 IF(K(I,1).EQ.1) THEN
61691 NFERR=0
61692 IF(NJU.EQ.0.AND.NP.NE.1) THEN
61693 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
61694 ELSEIF(NJU.EQ.1) THEN
61695 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
61696 ELSEIF(NJU.EQ.2) THEN
61697 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
61698 ELSEIF(NJU.GE.3) THEN
61699 NFERR=1
61700 ENDIF
61701 IF(NFERR.EQ.1) THEN
61702 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
61703 MINT(51)=1
61704 RETURN
61705 ENDIF
61706 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
61707 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
61708 & '(PYPREP:) too small mass in jet system')
61709 NP=0
61710 KFN=0
61711 KQS=0
61712 NJU=0
61713 DO 1170 J=1,5
61714 DPS(J)=0D0
61715 1170 CONTINUE
61716 ENDIF
61717 1180 CONTINUE
61718
61719 RETURN
61720 END
61721
61722C*********************************************************************
61723
61724C...PYSTRF
61725C...Handles the fragmentation of an arbitrary colour singlet
61726C...jet system according to the Lund string fragmentation model.
61727
61728 SUBROUTINE PYSTRF(IP)
61729
61730C...Double precision and integer declarations.
61731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61732 IMPLICIT INTEGER(I-N)
61733 INTEGER PYK,PYCHGE,PYCOMP
61734C...Commonblocks.
61735 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61737 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61738 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61739C...Local arrays. All MOPS variables ends with MO
61740 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
61741 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
61742 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
61743 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
61744 &PBST(3,5),TJUOLD(5)
61745
61746C...Function: four-product of two vectors.
61747 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)
61748 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
61749 &DP(I,3)*DP(J,3)
61750
61751C...Reset counters.
61752 MSTJ(91)=0
61753 NSAV=N
61754 MSTU90=MSTU(90)
61755 NP=0
61756 KQSUM=0
61757 DO 100 J=1,5
61758 DPS(J)=0D0
61759 100 CONTINUE
61760 MJU(1)=0
61761 MJU(2)=0
61762 NTRYFN=0
61763 IJUORI(1)=0
61764 IJUORI(2)=0
61765
61766C...Identify parton system.
61767 I=IP-1
61768 110 I=I+1
61769 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61770 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
61771 IF(MSTU(21).GE.1) RETURN
61772 ENDIF
61773 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
61774 KC=PYCOMP(K(I,2))
61775 IF(KC.EQ.0) GOTO 110
61776 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61777 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
61778 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
61779 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61780 IF(MSTU(21).GE.1) RETURN
61781 ENDIF
61782
61783C...Take copy of partons to be considered. Check flavour sum.
61784 NP=NP+1
61785 DO 120 J=1,5
61786 K(N+NP,J)=K(I,J)
61787 P(N+NP,J)=P(I,J)
61788 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
61789 120 CONTINUE
61790 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
61791 K(N+NP,3)=I
61792 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61793 IF(K(I,1).EQ.41) THEN
61794 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
61795 MJU(1)=N+NP
61796 IJUORI(1)=I
61797 ELSE
61798 MJU(2)=N+NP
61799 IJUORI(2)=I
61800 ENDIF
61801 ENDIF
61802 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
61803 IF(MOD(KQSUM,3).NE.0) THEN
61804 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
61805 IF(MSTU(21).GE.1) RETURN
61806 ENDIF
61807 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
61808
61809C...Boost copied system to CM frame (for better numerical precision).
61810 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
61811 MBST=0
61812 MSTU(33)=1
61813 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
61814 & -DPS(3)/DPS(4))
61815 ELSE
61816 MBST=1
61817 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
61818 DO 130 I=N+1,N+NP
61819 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61820 IF(P(I,3).GT.0D0) THEN
61821 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
61822 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61823 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61824 ELSE
61825 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
61826 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61827 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61828 ENDIF
61829 130 CONTINUE
61830 ENDIF
61831
61832C...Search for very nearby partons that may be recombined.
61833 NTRYR=0
61834 NTRYWR=0
61835 PARU12=PARU(12)
61836 PARU13=PARU(13)
61837 MJU(3)=MJU(1)
61838 MJU(4)=MJU(2)
61839 NR=NP
61840 NRMIN=2
61841 IF(MJU(1).GT.0) NRMIN=NRMIN+2
61842 IF(MJU(2).GT.0) NRMIN=NRMIN+2
61843 140 IF(NR.GT.NRMIN) THEN
61844 PDRMIN=2D0*PARU12
61845 DO 150 I=N+1,N+NR
61846 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
61847 I1=I+1
61848 IF(I.EQ.N+NR) I1=N+1
61849 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
61850 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
61851 & GOTO 150
61852 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
61853 & GOTO 150
61854 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
61855 & P(I1,2)**2+P(I1,3)**2))
61856 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
61857 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
61858 IF(PDR.LT.PDRMIN) THEN
61859 IR=I
61860 PDRMIN=PDR
61861 ENDIF
61862 150 CONTINUE
61863
61864C...Recombine very nearby partons to avoid machine precision problems.
61865 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
61866 DO 160 J=1,4
61867 P(N+1,J)=P(N+1,J)+P(N+NR,J)
61868 160 CONTINUE
61869 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
61870 & P(N+1,3)**2))
61871 NR=NR-1
61872 GOTO 140
61873 ELSEIF(PDRMIN.LT.PARU12) THEN
61874 DO 170 J=1,4
61875 P(IR,J)=P(IR,J)+P(IR+1,J)
61876 170 CONTINUE
61877 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
61878 & P(IR,3)**2))
61879 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
61880 DO 190 I=IR+1,N+NR-1
61881 K(I,1)=K(I+1,1)
61882 K(I,2)=K(I+1,2)
61883 DO 180 J=1,5
61884 P(I,J)=P(I+1,J)
61885 180 CONTINUE
61886 190 CONTINUE
61887 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
61888 NR=NR-1
61889 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
61890 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
61891 GOTO 140
61892 ENDIF
61893 ENDIF
61894 NTRYR=NTRYR+1
61895
61896C...Reset particle counter. Skip ahead if no junctions are present;
61897C...this is usually the case!
61898 NRS=MAX(5*NR+11,NP)
61899 NTRY=0
61900 200 NTRY=NTRY+1
61901 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61902 PARU12=4D0*PARU12
61903 PARU13=2D0*PARU13
61904 GOTO 140
61905 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
61906 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61907 IF(MSTU(21).GE.1) RETURN
61908 ENDIF
61909 I=N+NRS
61910 MSTU(90)=MSTU90
61911 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
61912 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
61913 & ' junction strings not handled by MSTJ(12)>3 options')
61914 DO 640 JT=1,2
61915 NJS(JT)=0
61916 IF(MJU(JT).EQ.0) GOTO 640
61917 JS=3-2*JT
61918
61919C++SKANDS
61920C...Find and sum up momentum on three sides of junction.
61921C...Begin with previous boost = zero.
61922 IJRFIT=0
61923 DO 210 IX=1,3
61924 TJUOLD(IX)=0D0
61925 210 CONTINUE
61926 TJUOLD(4)=1D0
61927 220 IU=0
61928C...Beginning and end of string system in event record.
61929 I1BEG=N+1+(JT-1)*(NR-1)
61930 I1END=N+NR+(JT-1)*(1-NR)
61931C...Look for junction string piece end points
61932 DO 230 I1=I1BEG,I1END,JS
61933 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
61934C...Store junction string piece end points.
61935C 1-junction systems 2-junction systems
61936C IU : 1 2 3 4 1 2 3 4 5 6
61937C 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
61938 IU=IU+1
61939 IJU(IU)=I1
61940 ENDIF
61941C...Sum over momenta, from junction outwards.
61942 230 CONTINUE
61943 DO 280 IU=1,3
61944 PWT=0D0
61945C...Initialize junction drag and string piece 4-vectors.
61946 DO 240 J=1,5
61947 PBST(IU,J)=0D0
61948 PJU(IU,J)=0D0
61949 240 CONTINUE
61950C...First two branches. Inwards out means opposite direction to JS.
61951C...(JS is 1 for JT=1, -1 for JT=2)
61952 IF (IU.LT.3) THEN
61953 I1A=IJU(IU+1)-JS
61954 I1B=IJU(IU)
61955 IDIR=-JS
61956C...Last branch (gq or gjgqgq). Direction now reversed.
61957 ELSE
61958 I1A=IJU(IU)+JS
61959 I1B=I1END
61960 IDIR=JS
61961 ENDIF
61962 DO 270 I1=I1A,I1B,IDIR
61963C...Sum up momentum directions with exponential suppression
61964C...for use in finding junction rest frame below.
61965 IF (K(I1,2).EQ.88) THEN
61966C...gjgqgq type system encountered. Use current PWT as start
61967C...for both strings.
61968 PWTOLD=PWT
61969 ELSE
61970 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
61971C...Sum up string piece (boosted) 4-momenta.
61972 DO 250 J=1,4
61973 PJU(IU,J)=PJU(IU,J)+P(I1,J)
61974 250 CONTINUE
61975C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
61976C...boost is zero, see above). Skip parton if suppression factor large.
61977 IF (PWT.GT.10D0) GOTO 270
61978C...Compute momentum in current frame:
61979 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
61980 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
61981 DO 260 J=1,3
61982 PTMP=P(I1,J)+TJUOLD(J)*BFC
61983 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
61984 260 CONTINUE
61985C...Boosted energy
61986 PTMP=TJUOLD(4)*P(I1,4)+TDP
61987 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
61988 PWT=PWT+PTMP/PARJ(48)
61989 ENDIF
61990 270 CONTINUE
61991C...Put |p| rather than m in 5th slot.
61992 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
61993 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
61994 280 CONTINUE
61995
61996C...Calculate boost from present frame to next JRF candidate.
61997 IJRFIT=IJRFIT+1
61998 CALL PYJURF(PBST,TJU)
61999
62000C...After some iterations do not take full step in new direction.
62001 IF(IJRFIT.GT.5) THEN
62002 REDUCE=0.8D0**(IJRFIT-5)
62003 TJU(1)=REDUCE*TJU(1)
62004 TJU(2)=REDUCE*TJU(2)
62005 TJU(3)=REDUCE*TJU(3)
62006 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62007 ENDIF
62008
62009C...Combine new boost (TJU) with old boost (TJUOLD)
62010 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
62011 DO 290 IX=1,3
62012 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
62013 290 CONTINUE
62014 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
62015
62016C...If last boost small, accept JRF, else iterate.
62017C...Also prevent possibility of infinite loop.
62018 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
62019 & IJRFIT.LT.MSTJ(18)) THEN
62020 GOTO 220
62021 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
62022 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
62023 ENDIF
62024
62025C...Now store total boost in TJU and change perception.
62026C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
62027C...TJU = junction motion vector in string CM, so the sign changes.
62028 DO 300 J=1,3
62029 TJU(J)=-TJUOLD(J)
62030 300 CONTINUE
62031 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62032
62033C--SKANDS
62034
62035C...Calculate string piece energies in junction rest frame.
62036 DO 310 IU=1,3
62037 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
62038 & TJU(3)*PJU(IU,3)
62039 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
62040 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
62041 310 CONTINUE
62042
62043C...Start preparing for fragmentation of two strings from junction.
62044 ISTA=I
62045 NTRYER=0
62046 320 NTRYER=NTRYER+1
62047 I=ISTA
62048 DO 620 IU=1,2
62049 NS=IABS(IJU(IU+1)-IJU(IU))
62050
62051C...Junction strings: find longitudinal string directions.
62052 DO 350 IS=1,NS
62053 IS1=IJU(IU)+JS*(IS-1)
62054 IS2=IJU(IU)+JS*IS
62055 DO 330 J=1,5
62056 DP(1,J)=0.5D0*P(IS1,J)
62057 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
62058 DP(2,J)=0.5D0*P(IS2,J)
62059 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
62060 & (PJU(IU,5)/PBST(IU,5))
62061 330 CONTINUE
62062 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
62063 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
62064 DP(3,5)=DFOUR(1,1)
62065 DP(4,5)=DFOUR(2,2)
62066 DHKC=DFOUR(1,2)
62067 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
62068 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62069 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62070 DP(3,5)=0D0
62071 DP(4,5)=0D0
62072 DHKC=DFOUR(1,2)
62073 ENDIF
62074 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62075 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62076 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62077 IN1=N+NR+4*IS-3
62078 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62079 DO 340 J=1,4
62080 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62081 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62082 340 CONTINUE
62083 350 CONTINUE
62084
62085C...Junction strings: initialize flavour, momentum and starting pos.
62086 ISAV=I
62087 MSTU91=MSTU(90)
62088 360 NTRY=NTRY+1
62089 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62090 PARU12=4D0*PARU12
62091 PARU13=2D0*PARU13
62092 GOTO 140
62093 ELSEIF(NTRY.GT.100) THEN
62094 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62095 IF(MSTU(21).GE.1) RETURN
62096 ENDIF
62097 I=ISAV
62098 MSTU(90)=MSTU91
62099 IRANKJ=0
62100 IE(1)=K(N+1+(JT/2)*(NP-1),3)
62101 IF (MOD(JT+IU,2).NE.0) THEN
62102 IE(1)=K(IJU(IU),3)
62103 IF (NP-NR.NE.0) THEN
62104C...If gluons have disappeared. Original IJU must be used.
62105 IT=IP
62106 NE=1
62107 370 IT=IT+1
62108 IF (K(IT,2).NE.21) THEN
62109 NE=NE+1
62110 ENDIF
62111 IF (NE.EQ.IU+4*(JT-1)) THEN
62112 IE(1)=IT
62113 ELSEIF (IT.LE.IP+NP) THEN
62114 GOTO 370
62115 ELSE
62116 CALL PYERRM(14,'(PYSTRF:) '//
62117 & 'Original IJU could not be reconstructed!')
62118 ENDIF
62119 ENDIF
62120 ENDIF
62121 IN(4)=N+NR+1
62122 IN(5)=IN(4)+1
62123 IN(6)=N+NR+4*NS+1
62124 DO 390 JQ=1,2
62125 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
62126 P(IN1,1)=2-JQ
62127 P(IN1,2)=JQ-1
62128 P(IN1,3)=1D0
62129 380 CONTINUE
62130 390 CONTINUE
62131 KFL(1)=K(IJU(IU),2)
62132 PX(1)=0D0
62133 PY(1)=0D0
62134 GAM(1)=0D0
62135 DO 400 J=1,5
62136 PJU(IU+3,J)=0D0
62137 400 CONTINUE
62138
62139C...Junction strings: find initial transverse directions.
62140 DO 410 J=1,4
62141 DP(1,J)=P(IN(4),J)
62142 DP(2,J)=P(IN(4)+1,J)
62143 DP(3,J)=0D0
62144 DP(4,J)=0D0
62145 410 CONTINUE
62146 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62147 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62148 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62149 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62150 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62151 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62152 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62153 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62154 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62155 DHC12=DFOUR(1,2)
62156 DHCX1=DFOUR(3,1)/DHC12
62157 DHCX2=DFOUR(3,2)/DHC12
62158 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62159 DHCY1=DFOUR(4,1)/DHC12
62160 DHCY2=DFOUR(4,2)/DHC12
62161 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62162 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62163 DO 420 J=1,4
62164 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62165 P(IN(6),J)=DP(3,J)
62166 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62167 & DHCYX*DP(3,J))
62168 420 CONTINUE
62169
62170C...Junction strings: produce new particle, origin.
62171 430 I=I+1
62172 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62173 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62174 IF(MSTU(21).GE.1) RETURN
62175 ENDIF
62176 IRANKJ=IRANKJ+1
62177 K(I,1)=1
62178 K(I,3)=IE(1)
62179 K(I,4)=0
62180 K(I,5)=0
62181
62182C...Junction strings: generate flavour, hadron, pT, z and Gamma.
62183 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
62184 IF(K(I,2).EQ.0) GOTO 360
62185 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
62186 & IABS(KFL(3)).GT.10) THEN
62187 IF(PYR(0).GT.PARJ(19)) GOTO 440
62188 ENDIF
62189 P(I,5)=PYMASS(K(I,2))
62190 CALL PYPTDI(KFL(1),PX(3),PY(3))
62191 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
62192 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
62193 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
62194 & MSTU(90).LT.8) THEN
62195 MSTU(90)=MSTU(90)+1
62196 MSTU(90+MSTU(90))=I
62197 PARU(90+MSTU(90))=Z
62198 ENDIF
62199 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
62200 DO 450 J=1,3
62201 IN(J)=IN(3+J)
62202 450 CONTINUE
62203
62204C...Junction strings: stepping within 'low' string region.
62205 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62206 & P(IN(1),5)**2.GE.PR(1)) THEN
62207 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
62208 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
62209 DO 460 J=1,4
62210 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
62211 460 CONTINUE
62212 GOTO 560
62213C...Has used up energy of junction string, i.e. no more hadrons in it.
62214 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
62215 DO 470 J=1,5
62216 P(I,J)=0D0
62217 470 CONTINUE
62218 GOTO 600
62219C...Stepping from 'low' string region
62220 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62221 P(IN(2)+2,4)=P(IN(2)+2,3)
62222 P(IN(2)+2,1)=1D0
62223 IN(2)=IN(2)+4
62224 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62225 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62226 P(IN(1)+2,4)=P(IN(1)+2,3)
62227 P(IN(1)+2,1)=0D0
62228 IN(1)=IN(1)+4
62229 ENDIF
62230 ENDIF
62231
62232C...Junction strings: find new transverse directions.
62233 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
62234 & IN(1).GT.IN(2)) GOTO 360
62235 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
62236 DO 490 J=1,4
62237 DP(1,J)=P(IN(1),J)
62238 DP(2,J)=P(IN(2),J)
62239 DP(3,J)=0D0
62240 DP(4,J)=0D0
62241 490 CONTINUE
62242 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62243 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62244 DHC12=DFOUR(1,2)
62245 IF(DHC12.LE.1D-2) THEN
62246 P(IN(1)+2,4)=P(IN(1)+2,3)
62247 P(IN(1)+2,1)=0D0
62248 IN(1)=IN(1)+4
62249 GOTO 480
62250 ENDIF
62251 IN(3)=N+NR+4*NS+5
62252 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62253 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62254 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62255 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62256 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62257 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62258 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62259 DHCX1=DFOUR(3,1)/DHC12
62260 DHCX2=DFOUR(3,2)/DHC12
62261 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62262 DHCY1=DFOUR(4,1)/DHC12
62263 DHCY2=DFOUR(4,2)/DHC12
62264 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62265 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62266 DO 500 J=1,4
62267 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62268 P(IN(3),J)=DP(3,J)
62269 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62270 & DHCYX*DP(3,J))
62271 500 CONTINUE
62272C...Express pT with respect to new axes, if sensible.
62273 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
62274 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
62275 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62276 PX(3)=PXP
62277 PY(3)=PYP
62278 ENDIF
62279 ENDIF
62280
62281C...Junction strings: sum up known four-momentum, coefficients for m2.
62282 DO 530 J=1,4
62283 DHG(J)=0D0
62284 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
62285 & PY(3)*P(IN(3)+1,J)
62286 DO 510 IN1=IN(4),IN(1)-4,4
62287 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62288 510 CONTINUE
62289 DO 520 IN2=IN(5),IN(2)-4,4
62290 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62291 520 CONTINUE
62292 530 CONTINUE
62293 DHM(1)=FOUR(I,I)
62294 DHM(2)=2D0*FOUR(I,IN(1))
62295 DHM(3)=2D0*FOUR(I,IN(2))
62296 DHM(4)=2D0*FOUR(IN(1),IN(2))
62297
62298C...Junction strings: find coefficients for Gamma expression.
62299 DO 550 IN2=IN(1)+1,IN(2),4
62300 DO 540 IN1=IN(1),IN2-1,4
62301 DHC=2D0*FOUR(IN1,IN2)
62302 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
62303 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
62304 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
62305 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62306 540 CONTINUE
62307 550 CONTINUE
62308
62309C...Junction strings: solve (m2, Gamma) equation system for energies.
62310 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
62311 IF(ABS(DHS1).LT.1D-4) GOTO 360
62312 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
62313 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
62314 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
62315 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62316 & ABS(DHS1)-DHS2/DHS1)
62317 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
62318 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
62319 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
62320
62321C...Junction strings: step to new region if necessary.
62322 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
62323 P(IN(2)+2,4)=P(IN(2)+2,3)
62324 P(IN(2)+2,1)=1D0
62325 IN(2)=IN(2)+4
62326 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62327 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62328 P(IN(1)+2,4)=P(IN(1)+2,3)
62329 P(IN(1)+2,1)=0D0
62330 IN(1)=IN(1)+4
62331 ENDIF
62332 GOTO 480
62333 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
62334 P(IN(1)+2,4)=P(IN(1)+2,3)
62335 P(IN(1)+2,1)=0D0
62336 IN(1)=IN(1)+4
62337 GOTO 480
62338 ENDIF
62339
62340C...Junction strings: particle four-momentum, remainder, loop back.
62341 560 DO 570 J=1,4
62342 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
62343 & P(IN(2)+2,4)*P(IN(2),J)
62344 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
62345 570 CONTINUE
62346 IF(P(I,4).LT.P(I,5)) GOTO 360
62347 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62348 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62349 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
62350 KFL(1)=-KFL(3)
62351 PX(1)=-PX(3)
62352 PY(1)=-PY(3)
62353 GAM(1)=GAM(3)
62354 IF(IN(3).NE.IN(6)) THEN
62355 DO 580 J=1,4
62356 P(IN(6),J)=P(IN(3),J)
62357 P(IN(6)+1,J)=P(IN(3)+1,J)
62358 580 CONTINUE
62359 ENDIF
62360 DO 590 JQ=1,2
62361 IN(3+JQ)=IN(JQ)
62362 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62363 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
62364 590 CONTINUE
62365 GOTO 430
62366 ENDIF
62367
62368C...Junction strings: save quantities left after each string.
62369 IF(IABS(KFL(1)).GT.10) GOTO 360
62370 600 I=I-1
62371 KFJH(IU)=KFL(1)
62372 DO 610 J=1,4
62373 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
62374 610 CONTINUE
62375
62376C...Junction strings: loopback if much unused energy in both strings.
62377 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62378 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62379 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
62380 620 CONTINUE
62381 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
62382 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
62383 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
62384 & .AND.NTRYER.LT.10) GOTO 320
62385
62386C...Junction strings: put together to new effective string endpoint.
62387 NJS(JT)=I-ISTA
62388 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
62389 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
62390 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
62391 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
62392 DO 630 J=1,4
62393 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
62394 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
62395 630 CONTINUE
62396 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
62397 & PJS(JT,3)**2))
62398 PJS(JT+2,5)=0D0
62399 640 CONTINUE
62400
62401C...Open versus closed strings. Choose breakup region for latter.
62402 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
62403 NS=MJU(2)-MJU(1)
62404 NB=MJU(1)-N
62405 ELSEIF(MJU(1).NE.0) THEN
62406 NS=N+NR-MJU(1)
62407 NB=MJU(1)-N
62408 ELSEIF(MJU(2).NE.0) THEN
62409 NS=MJU(2)-N
62410 NB=1
62411 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
62412 NS=NR-1
62413 NB=1
62414 ELSE
62415 NS=NR+1
62416 W2SUM=0D0
62417 DO 660 IS=1,NR
62418 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
62419 W2SUM=W2SUM+P(N+NR+IS,1)
62420 660 CONTINUE
62421 W2RAN=PYR(0)*W2SUM
62422 NB=0
62423 670 NB=NB+1
62424 W2SUM=W2SUM-P(N+NR+NB,1)
62425 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
62426 ENDIF
62427
62428C...Find longitudinal string directions (i.e. lightlike four-vectors).
62429 DO 700 IS=1,NS
62430 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
62431 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
62432 DO 680 J=1,5
62433 DP(1,J)=P(IS1,J)
62434 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
62435 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
62436 DP(2,J)=P(IS2,J)
62437 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
62438 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
62439 680 CONTINUE
62440 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
62441 & DP(1,2)**2-DP(1,3)**2))
62442 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
62443 & DP(2,2)**2-DP(2,3)**2))
62444 DP(3,5)=DFOUR(1,1)
62445 DP(4,5)=DFOUR(2,2)
62446 DHKC=DFOUR(1,2)
62447 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
62448 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62449 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62450 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62451 IN1=N+NR+4*IS-3
62452 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62453 DO 690 J=1,4
62454 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62455 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62456 690 CONTINUE
62457 700 CONTINUE
62458
62459C...Begin initialization: sum up energy, set starting position.
62460 ISAV=I
62461 MSTU91=MSTU(90)
62462 710 NTRY=NTRY+1
62463 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62464 PARU12=4D0*PARU12
62465 PARU13=2D0*PARU13
62466 GOTO 140
62467 ELSEIF(NTRY.GT.100) THEN
62468 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62469 IF(MSTU(21).GE.1) RETURN
62470 ENDIF
62471 I=ISAV
62472 MSTU(90)=MSTU91
62473 DO 730 J=1,4
62474 P(N+NRS,J)=0D0
62475 DO 720 IS=1,NR
62476 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
62477 720 CONTINUE
62478 730 CONTINUE
62479 DO 750 JT=1,2
62480 IRANK(JT)=0
62481 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
62482 IF(NS.GT.NR) IRANK(JT)=1
62483 IBARRK(JT)=0
62484 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
62485 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
62486 IN(3*JT+2)=IN(3*JT+1)+1
62487 IN(3*JT+3)=N+NR+4*NS+2*JT-1
62488 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
62489 P(IN1,1)=2-JT
62490 P(IN1,2)=JT-1
62491 P(IN1,3)=1D0
62492 740 CONTINUE
62493 750 CONTINUE
62494
62495C.. MOPS variables and switches
62496 NRVMO=0
62497 XBMO=1D0
62498 MSTU(121)=0
62499 MSTU(122)=0
62500
62501C...Initialize flavour and pT variables for open string.
62502 IF(NS.LT.NR) THEN
62503 PX(1)=0D0
62504 PY(1)=0D0
62505 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
62506 PX(2)=-PX(1)
62507 PY(2)=-PY(1)
62508 DO 760 JT=1,2
62509 KFL(JT)=K(IE(JT),2)
62510 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
62511 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
62512 MSTJ(93)=1
62513 PMQ(JT)=PYMASS(KFL(JT))
62514 GAM(JT)=0D0
62515 760 CONTINUE
62516
62517C...Closed string: random initial breakup flavour, pT and vertex.
62518 ELSE
62519 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62520 IBMO=0
62521 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
62522C.. Closed string: first vertex diq attempt => enforced second
62523C.. vertex diq
62524 IF(IABS(KFL(1)).GT.10)THEN
62525 IBMO=1
62526 MSTU(121)=0
62527 GOTO 770
62528 ENDIF
62529 IF(IBMO.EQ.1) MSTU(121)=-1
62530 KFL(2)=-KFL(1)
62531 CALL PYPTDI(KFL(1),PX(1),PY(1))
62532 PX(2)=-PX(1)
62533 PY(2)=-PY(1)
62534 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
62535 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
62536 ZR=PR3/(Z*P(N+NR+1,5)**2)
62537 IF(ZR.GE.1D0) GOTO 780
62538 DO 790 JT=1,2
62539 MSTJ(93)=1
62540 PMQ(JT)=PYMASS(KFL(JT))
62541 GAM(JT)=PR3*(1D0-Z)/Z
62542 IN1=N+NR+3+4*(JT/2)*(NS-1)
62543 P(IN1,JT)=1D0-Z
62544 P(IN1,3-JT)=JT-1
62545 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
62546 P(IN1+1,JT)=ZR
62547 P(IN1+1,3-JT)=2-JT
62548 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
62549 790 CONTINUE
62550 ENDIF
62551C.. MOPS variables
62552 DO 800 JT=1,2
62553 XTMO(JT)=1D0
62554 PM2QMO(JT)=PMQ(JT)**2
62555 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
62556 800 CONTINUE
62557
62558C...Find initial transverse directions (i.e. spacelike four-vectors).
62559 DO 840 JT=1,2
62560 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
62561 IN1=IN(3*JT+1)
62562 IN3=IN(3*JT+3)
62563 DO 810 J=1,4
62564 DP(1,J)=P(IN1,J)
62565 DP(2,J)=P(IN1+1,J)
62566 DP(3,J)=0D0
62567 DP(4,J)=0D0
62568 810 CONTINUE
62569 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62570 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62571 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62572 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62573 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62574 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62575 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62576 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62577 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62578 DHC12=DFOUR(1,2)
62579 DHCX1=DFOUR(3,1)/DHC12
62580 DHCX2=DFOUR(3,2)/DHC12
62581 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62582 DHCY1=DFOUR(4,1)/DHC12
62583 DHCY2=DFOUR(4,2)/DHC12
62584 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62585 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62586 DO 820 J=1,4
62587 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62588 P(IN3,J)=DP(3,J)
62589 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62590 & DHCYX*DP(3,J))
62591 820 CONTINUE
62592 ELSE
62593 DO 830 J=1,4
62594 P(IN3+2,J)=P(IN3,J)
62595 P(IN3+3,J)=P(IN3+1,J)
62596 830 CONTINUE
62597 ENDIF
62598 840 CONTINUE
62599
62600C...Remove energy used up in junction string fragmentation.
62601 IF(MJU(1)+MJU(2).GT.0) THEN
62602 DO 860 JT=1,2
62603 IF(NJS(JT).EQ.0) GOTO 860
62604 DO 850 J=1,4
62605 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
62606 850 CONTINUE
62607 860 CONTINUE
62608 PARJST=PARJ(33)
62609 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62610 WMIN=PARJST+PMQ(1)+PMQ(2)
62611 WREM2=FOUR(N+NRS,N+NRS)
62612 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
62613 NTRYWR=NTRYWR+1
62614 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
62615 GOTO 140
62616 ENDIF
62617 ENDIF
62618
62619C...Produce new particle: side, origin.
62620 870 I=I+1
62621 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62622 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62623 IF(MSTU(21).GE.1) RETURN
62624 ENDIF
62625C.. New side priority for popcorn systems
62626 IF(MSTU(121).LE.0)THEN
62627 JT=1.5D0+PYR(0)
62628 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
62629 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
62630 ENDIF
62631 JR=3-JT
62632 JS=3-2*JT
62633 IRANK(JT)=IRANK(JT)+1
62634 K(I,1)=1
62635 K(I,4)=0
62636 K(I,5)=0
62637
62638C...Generate flavour, hadron and pT.
62639 880 K(I,3)=IE(JT)
62640 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
62641 IF(K(I,2).EQ.0) GOTO 710
62642 MU90MO=MSTU(90)
62643 IF(MSTU(121).EQ.-1) GOTO 910
62644 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
62645 &IABS(KFL(3)).GT.10) THEN
62646 IF(PYR(0).GT.PARJ(19)) GOTO 880
62647 ENDIF
62648 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62649 &K(I,3)=IJUORI(JT)
62650 P(I,5)=PYMASS(K(I,2))
62651 CALL PYPTDI(KFL(JT),PX(3),PY(3))
62652 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
62653
62654C...Final hadrons for small invariant mass.
62655 MSTJ(93)=1
62656 PMQ(3)=PYMASS(KFL(3))
62657 PARJST=PARJ(33)
62658 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62659 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
62660 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
62661 &WMIN-0.5D0*PARJ(36)*PMQ(3)
62662 WREM2=FOUR(N+NRS,N+NRS)
62663 IF(WREM2.LT.0.10D0) GOTO 710
62664 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
62665 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
62666
62667C...Choose z, which gives Gamma. Shift z for heavy flavours.
62668 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
62669 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
62670 &MSTU(90).LT.8) THEN
62671 MSTU(90)=MSTU(90)+1
62672 MSTU(90+MSTU(90))=I
62673 PARU(90+MSTU(90))=Z
62674 ENDIF
62675 KFL1A=IABS(KFL(1))
62676 KFL2A=IABS(KFL(2))
62677 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62678 &MOD(KFL2A/1000,10)).GE.4) THEN
62679 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62680 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
62681 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
62682 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62683 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
62684 ENDIF
62685 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
62686
62687C.. MOPS baryon model modification
62688 XTMO3=(1D0-Z)*XTMO(JT)
62689 IF(IABS(KFL(3)).LE.10) NRVMO=0
62690 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
62691 GTSTMO=1D0
62692 PTSTMO=1D0
62693 RTSTMO=PYR(0)
62694 IF(IABS(KFL(JT)).LE.10)THEN
62695 XBMO=MIN(XTMO3,1D0-(2D-10))
62696 GBMO=GAM(3)
62697 PMMO=0D0
62698 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
62699 GTSTMO=1D0-PARF(192)**PGMO
62700 ELSE
62701 IF(IRANK(JT).EQ.1) THEN
62702 GBMO=GAM(JT)
62703 PMMO=0D0
62704 XBMO=1D0
62705 ENDIF
62706 IF(XBMO.LT.1D0-(1D-10))THEN
62707 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
62708 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
62709 PGMO=PGNMO
62710 ENDIF
62711 IF(MSTJ(12).GE.5)THEN
62712 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
62713 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
62714 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
62715 PMMO=PMNMO
62716 ENDIF
62717 ENDIF
62718
62719C.. MOPS Accepting popcorn system hadron.
62720 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
62721 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
62722 NRVMO=I-N-NR
62723 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
62724 CALL PYERRM(11,
62725 & '(PYSTRF:) no more memory left in PYJETS')
62726 IF(MSTU(21).GE.1) RETURN
62727 ENDIF
62728 IMO=I
62729 KFLMO=KFL(JT)
62730 PMQMO=PMQ(JT)
62731 PXMO=PX(JT)
62732 PYMO=PY(JT)
62733 GAMMO=GAM(JT)
62734 IRMO=IRANK(JT)
62735 XMO=XTMO(JT)
62736 DO 900 J=1,9
62737 IF(J.LE.5) THEN
62738 DO 890 LINE=1,I-N-NR
62739 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
62740 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
62741 890 CONTINUE
62742 ENDIF
62743 INMO(J)=IN(J)
62744 900 CONTINUE
62745 ENDIF
62746 ELSE
62747C..Reject popcorn system, flag=-1 if enforcing new one
62748 MSTU(121)=-1
62749 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
62750 ENDIF
62751 ENDIF
62752
62753
62754C..Lift restoring string outside MOPS block
62755 910 IF(MSTU(121).LT.0) THEN
62756 IF(MSTU(121).EQ.-2) MSTU(121)=0
62757 MSTU(90)=MU90MO
62758 NRVMO=0
62759 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
62760 I=IMO
62761 KFL(JT)=KFLMO
62762 PMQ(JT)=PMQMO
62763 PX(JT)=PXMO
62764 PY(JT)=PYMO
62765 GAM(JT)=GAMMO
62766 IRANK(JT)=IRMO
62767 XTMO(JT)=XMO
62768 DO 930 J=1,9
62769 IF(J.LE.5) THEN
62770 DO 920 LINE=1,I-N-NR
62771 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
62772 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
62773 920 CONTINUE
62774 ENDIF
62775 IN(J)=INMO(J)
62776 930 CONTINUE
62777 GOTO 880
62778 ENDIF
62779 XTMO(JT)=XTMO3
62780C.. MOPS end of modification
62781
62782 DO 940 J=1,3
62783 IN(J)=IN(3*JT+J)
62784 940 CONTINUE
62785
62786C...Stepping within or from 'low' string region easy.
62787 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62788 &P(IN(1),5)**2.GE.PR(JT)) THEN
62789 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
62790 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
62791 DO 950 J=1,4
62792 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
62793 950 CONTINUE
62794 GOTO 1040
62795 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62796 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62797 P(IN(JR)+2,JT)=1D0
62798 IN(JR)=IN(JR)+4*JS
62799 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62800 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62801 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62802 P(IN(JT)+2,JT)=0D0
62803 IN(JT)=IN(JT)+4*JS
62804 ENDIF
62805 ENDIF
62806
62807C...Find new transverse directions (i.e. spacelike string vectors).
62808 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
62809 &IN(1).GT.IN(2)) GOTO 710
62810 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
62811 DO 970 J=1,4
62812 DP(1,J)=P(IN(1),J)
62813 DP(2,J)=P(IN(2),J)
62814 DP(3,J)=0D0
62815 DP(4,J)=0D0
62816 970 CONTINUE
62817 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62818 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62819 DHC12=DFOUR(1,2)
62820 IF(DHC12.LE.1D-2) THEN
62821 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62822 P(IN(JT)+2,JT)=0D0
62823 IN(JT)=IN(JT)+4*JS
62824 GOTO 960
62825 ENDIF
62826 IN(3)=N+NR+4*NS+5
62827 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62828 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62829 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62830 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62831 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62832 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62833 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62834 DHCX1=DFOUR(3,1)/DHC12
62835 DHCX2=DFOUR(3,2)/DHC12
62836 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62837 DHCY1=DFOUR(4,1)/DHC12
62838 DHCY2=DFOUR(4,2)/DHC12
62839 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62840 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62841 DO 980 J=1,4
62842 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62843 P(IN(3),J)=DP(3,J)
62844 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62845 & DHCYX*DP(3,J))
62846 980 CONTINUE
62847C...Express pT with respect to new axes, if sensible.
62848 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
62849 & FOUR(IN(3*JT+3)+1,IN(3)))
62850 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
62851 & FOUR(IN(3*JT+3)+1,IN(3)+1))
62852 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62853 PX(3)=PXP
62854 PY(3)=PYP
62855 ENDIF
62856 ENDIF
62857
62858C...Sum up known four-momentum. Gives coefficients for m2 expression.
62859 DO 1010 J=1,4
62860 DHG(J)=0D0
62861 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
62862 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
62863 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
62864 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62865 990 CONTINUE
62866 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
62867 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62868 1000 CONTINUE
62869 1010 CONTINUE
62870 DHM(1)=FOUR(I,I)
62871 DHM(2)=2D0*FOUR(I,IN(1))
62872 DHM(3)=2D0*FOUR(I,IN(2))
62873 DHM(4)=2D0*FOUR(IN(1),IN(2))
62874
62875C...Find coefficients for Gamma expression.
62876 DO 1030 IN2=IN(1)+1,IN(2),4
62877 DO 1020 IN1=IN(1),IN2-1,4
62878 DHC=2D0*FOUR(IN1,IN2)
62879 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
62880 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
62881 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
62882 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62883 1020 CONTINUE
62884 1030 CONTINUE
62885
62886C...Solve (m2, Gamma) equation system for energies taken.
62887 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
62888 IF(ABS(DHS1).LT.1D-4) GOTO 710
62889 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
62890 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
62891 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
62892 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62893 &ABS(DHS1)-DHS2/DHS1)
62894 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
62895 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
62896 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
62897
62898C...Step to new region if necessary.
62899 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
62900 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62901 P(IN(JR)+2,JT)=1D0
62902 IN(JR)=IN(JR)+4*JS
62903 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62904 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62905 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62906 P(IN(JT)+2,JT)=0D0
62907 IN(JT)=IN(JT)+4*JS
62908 ENDIF
62909 GOTO 960
62910 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
62911 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62912 P(IN(JT)+2,JT)=0D0
62913 IN(JT)=IN(JT)+4*JS
62914 GOTO 960
62915 ENDIF
62916
62917C...Four-momentum of particle. Remaining quantities. Loop back.
62918 1040 DO 1050 J=1,4
62919 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
62920 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
62921 1050 CONTINUE
62922 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
62923 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
62924 &GOTO 200
62925 IF(P(I,4).LT.P(I,5)) GOTO 710
62926 KFL(JT)=-KFL(3)
62927 PMQ(JT)=PMQ(3)
62928 PX(JT)=-PX(3)
62929 PY(JT)=-PY(3)
62930 GAM(JT)=GAM(3)
62931 IF(IN(3).NE.IN(3*JT+3)) THEN
62932 DO 1060 J=1,4
62933 P(IN(3*JT+3),J)=P(IN(3),J)
62934 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
62935 1060 CONTINUE
62936 ENDIF
62937 DO 1070 JQ=1,2
62938 IN(3*JT+JQ)=IN(JQ)
62939 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62940 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
62941 1070 CONTINUE
62942 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62943 &IBARRK(JT)=0
62944 GOTO 870
62945
62946C...Final hadron: side, flavour, hadron, mass.
62947 1080 I=I+1
62948 K(I,1)=1
62949 K(I,3)=IE(JR)
62950 K(I,4)=0
62951 K(I,5)=0
62952 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
62953 IF(K(I,2).EQ.0) GOTO 710
62954 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
62955 &IBARRK(JT)=0
62956 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62957 &K(I,3)=IJUORI(JT)
62958 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62959 &K(I,3)=IJUORI(JR)
62960 P(I,5)=PYMASS(K(I,2))
62961 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62962
62963C...Final two hadrons: find common setup of four-vectors.
62964 JQ=1
62965 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
62966 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
62967 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
62968 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
62969 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
62970 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
62971 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
62972 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
62973 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
62974 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
62975 ENDIF
62976
62977C...Solve kinematics for final two hadrons, if possible.
62978 WREM2=2D0*DHR1*DHR2*DHC12
62979 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
62980 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
62981 IF(FD.GE.1D0) GOTO 710
62982 FA=WREM2+PR(JT)-PR(JR)
62983 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
62984 PREVCF=PARJ(42)
62985 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
62986 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
62987 FB=SIGN(FB,JS*(PYR(0)-PREV))
62988 KFL1A=IABS(KFL(1))
62989 KFL2A=IABS(KFL(2))
62990 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62991 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
62992 &4D0*WREM2*PR(JT))),DBLE(JS))
62993 DO 1090 J=1,4
62994 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
62995 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
62996 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
62997 P(I,J)=P(N+NRS,J)-P(I-1,J)
62998 1090 CONTINUE
62999 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
63000 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
63001 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
63002 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
63003 NTRYFN=NTRYFN+1
63004 IF(NTRYFN.LT.100) GOTO 140
63005 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
63006 ENDIF
63007
63008C...Mark jets as fragmented and give daughter pointers.
63009 N=I-NRS+1
63010 DO 1100 I=NSAV+1,NSAV+NP
63011 IM=K(I,3)
63012 K(IM,1)=K(IM,1)+10
63013 IF(MSTU(16).NE.2) THEN
63014 K(IM,4)=NSAV+1
63015 K(IM,5)=NSAV+1
63016 ELSE
63017 K(IM,4)=NSAV+2
63018 K(IM,5)=N
63019 ENDIF
63020 1100 CONTINUE
63021
63022C...Document string system. Move up particles.
63023 NSAV=NSAV+1
63024 K(NSAV,1)=11
63025 K(NSAV,2)=92
63026 K(NSAV,3)=IP
63027 K(NSAV,4)=NSAV+1
63028 K(NSAV,5)=N
63029 DO 1110 J=1,4
63030 P(NSAV,J)=DPS(J)
63031 V(NSAV,J)=V(IP,J)
63032 1110 CONTINUE
63033 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63034 V(NSAV,5)=0D0
63035 DO 1130 I=NSAV+1,N
63036 DO 1120 J=1,5
63037 K(I,J)=K(I+NRS-1,J)
63038 P(I,J)=P(I+NRS-1,J)
63039 V(I,J)=0D0
63040 1120 CONTINUE
63041 1130 CONTINUE
63042 MSTU91=MSTU(90)
63043 DO 1140 IZ=MSTU90+1,MSTU91
63044 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
63045 PARU9T(IZ)=PARU(90+IZ)
63046 1140 CONTINUE
63047 MSTU(90)=MSTU90
63048
63049C...Order particles in rank along the chain. Update mother pointer.
63050 DO 1160 I=NSAV+1,N
63051 DO 1150 J=1,5
63052 K(I-NSAV+N,J)=K(I,J)
63053 P(I-NSAV+N,J)=P(I,J)
63054 1150 CONTINUE
63055 1160 CONTINUE
63056 I1=NSAV
63057 DO 1190 I=N+1,2*N-NSAV
63058 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
63059 I1=I1+1
63060 DO 1170 J=1,5
63061 K(I1,J)=K(I,J)
63062 P(I1,J)=P(I,J)
63063 1170 CONTINUE
63064 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63065 DO 1180 IZ=MSTU90+1,MSTU91
63066 IF(MSTU9T(IZ).EQ.I) THEN
63067 MSTU(90)=MSTU(90)+1
63068 MSTU(90+MSTU(90))=I1
63069 PARU(90+MSTU(90))=PARU9T(IZ)
63070 ENDIF
63071 1180 CONTINUE
63072 1190 CONTINUE
63073 DO 1220 I=2*N-NSAV,N+1,-1
63074 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
63075 I1=I1+1
63076 DO 1200 J=1,5
63077 K(I1,J)=K(I,J)
63078 P(I1,J)=P(I,J)
63079 1200 CONTINUE
63080 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63081 DO 1210 IZ=MSTU90+1,MSTU91
63082 IF(MSTU9T(IZ).EQ.I) THEN
63083 MSTU(90)=MSTU(90)+1
63084 MSTU(90+MSTU(90))=I1
63085 PARU(90+MSTU(90))=PARU9T(IZ)
63086 ENDIF
63087 1210 CONTINUE
63088 1220 CONTINUE
63089
63090C...Boost back particle system. Set production vertices.
63091 IF(MBST.EQ.0) THEN
63092 MSTU(33)=1
63093 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
63094 & DPS(3)/DPS(4))
63095 ELSE
63096 DO 1230 I=NSAV+1,N
63097 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
63098 IF(P(I,3).GT.0D0) THEN
63099 HHPEZ=(P(I,4)+P(I,3))*HHBZ
63100 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
63101 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63102 ELSE
63103 HHPEZ=(P(I,4)-P(I,3))/HHBZ
63104 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
63105 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63106 ENDIF
63107 1230 CONTINUE
63108 ENDIF
63109 DO 1250 I=NSAV+1,N
63110 DO 1240 J=1,4
63111 V(I,J)=V(IP,J)
63112 1240 CONTINUE
63113 1250 CONTINUE
63114
63115 RETURN
63116 END
63117
63118C*********************************************************************
63119
63120C...PYJURF
63121C...From three given input vectors in PJU the boost VJU from
63122C...the "lab frame" to the junction rest frame is constructed.
63123
63124 SUBROUTINE PYJURF(PJU,VJU)
63125
63126C...Double precision and integer declarations.
63127 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63128 IMPLICIT INTEGER(I-N)
63129
63130C...Input, output and local arrays.
63131 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
63132 DATA TWOPI/6.283186D0/
63133
63134C...Calculate masses and other invariants.
63135 DO 100 J=1,4
63136 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63137 100 CONTINUE
63138 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
63139 PSUM(5)=SQRT(PSUM2)
63140 DO 120 I=1,3
63141 DO 110 J=1,3
63142 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
63143 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
63144 110 CONTINUE
63145 120 CONTINUE
63146
63147C...Pick I to be most massive parton and J to be the one closest to I.
63148 ITRY=0
63149 I=1
63150 IF(A(2,2).GT.A(1,1)) I=2
63151 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
63152 130 ITRY=ITRY+1
63153 J=1+MOD(I,3)
63154 K=1+MOD(J,3)
63155 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
63156 K=1+MOD(I,3)
63157 J=1+MOD(K,3)
63158 ENDIF
63159 PMI2=A(I,I)
63160 PMJ2=A(J,J)
63161 PMK2=A(K,K)
63162 AIJ=A(I,J)
63163 AIK=A(I,K)
63164 AJK=A(J,K)
63165
63166C...Trivial find new parton energies if all three partons are massless.
63167 IF(PMI2.LT.1D-4) THEN
63168 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
63169 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
63170 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
63171
63172C...Else find momentum range for parton I and values at extremes.
63173 ELSE
63174 PAIMIN=0D0
63175 PEIMIN=SQRT(PMI2)
63176 PEJMIN=AIJ/PEIMIN
63177 PEKMIN=AIK/PEIMIN
63178 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
63179 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
63180 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
63181 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
63182 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
63183 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
63184 HI=PEIMAX**2-0.25D0*PAIMAX**2
63185 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
63186 & 0.5D0*PAIMAX*AIJ)/HI
63187 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
63188 & 0.5D0*PAIMAX*AIK)/HI
63189 PEJMAX=SQRT(PAJMAX**2+PMJ2)
63190 PEKMAX=SQRT(PAKMAX**2+PMK2)
63191 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
63192
63193C...If unexpected values at upper endpoint then pick another parton.
63194 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
63195 I1=1+MOD(I,3)
63196 IF(A(I1,I1).GE.1D-4) THEN
63197 I=I1
63198 GOTO 130
63199 ENDIF
63200 ITRY=ITRY+1
63201 I1=1+MOD(I,3)
63202 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
63203 I=I1
63204 GOTO 130
63205 ENDIF
63206 ENDIF
63207
63208C..Start binary + linear search to find solution inside range.
63209 ITER=0
63210 ITMIN=0
63211 ITMAX=0
63212 PAI=0.5D0*(PAIMIN+PAIMAX)
63213 140 ITER=ITER+1
63214
63215C...Derive momentum of other two partons and distance to root.
63216 PEI=SQRT(PAI**2+PMI2)
63217 HI=PEI**2-0.25D0*PAI**2
63218 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
63219 PEJ=SQRT(PAJ**2+PMJ2)
63220 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
63221 PEK=SQRT(PAK**2+PMK2)
63222 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
63223
63224C...Pick next I momentum to explore, hopefully closer to root.
63225 IF(FNOW.GT.0D0) THEN
63226 PAIMIN=PAI
63227 FMIN=FNOW
63228 ITMIN=ITMIN+1
63229 ELSE
63230 PAIMAX=PAI
63231 FMAX=FNOW
63232 ITMAX=ITMAX+1
63233 ENDIF
63234 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
63235 & THEN
63236 PAI=0.5D0*(PAIMIN+PAIMAX)
63237 GOTO 140
63238 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
63239 & ABS(FNOW).GT.1D-12*PSUM2) THEN
63240 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
63241 GOTO 140
63242 ENDIF
63243 ENDIF
63244
63245C...Now know energies in junction rest frame.
63246 PENEW(I)=PEI
63247 PENEW(J)=PEJ
63248 PENEW(K)=PEK
63249
63250C...Boost (copy of) partons to their rest frame.
63251 VXCM=-PSUM(1)/PSUM(5)
63252 VYCM=-PSUM(2)/PSUM(5)
63253 VZCM=-PSUM(3)/PSUM(5)
63254 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
63255 DO 150 I=1,3
63256 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
63257 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
63258 PCM(I,1)=PJU(I,1)+FAC2*VXCM
63259 PCM(I,2)=PJU(I,2)+FAC2*VYCM
63260 PCM(I,3)=PJU(I,3)+FAC2*VZCM
63261 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
63262 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63263 150 CONTINUE
63264
63265C...Construct difference vectors and boost to junction rest frame.
63266 DO 160 J=1,3
63267 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
63268 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
63269 160 CONTINUE
63270 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
63271 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
63272 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
63273 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
63274 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
63275 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
63276 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
63277 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
63278 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
63279 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
63280 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
63281
63282C...Add two boosts, giving final result.
63283 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
63284 VJU(1)=VXJU+FCM*VXCM
63285 VJU(2)=VYJU+FCM*VYCM
63286 VJU(3)=VZJU+FCM*VZCM
63287 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
63288 VJU(5)=1D0
63289
63290C...In case of error in reconstruction: revert to CM frame of system.
63291 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63292 &(PCM(1,5)*PCM(2,5))
63293 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63294 &(PCM(1,5)*PCM(3,5))
63295 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63296 &(PCM(2,5)*PCM(3,5))
63297 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63298 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63299 DO 170 I=1,3
63300 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
63301 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
63302 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
63303 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
63304 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
63305 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
63306 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63307 170 CONTINUE
63308 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63309 &(PCM(1,5)*PCM(2,5))
63310 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63311 &(PCM(1,5)*PCM(3,5))
63312 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63313 &(PCM(2,5)*PCM(3,5))
63314 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63315 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63316 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
63317 VJU(1)=VXCM
63318 VJU(2)=VYCM
63319 VJU(3)=VZCM
63320 VJU(4)=GAMCM
63321 ENDIF
63322
63323 RETURN
63324 END
63325
63326C*********************************************************************
63327
63328C...PYINDF
63329C...Handles the fragmentation of a jet system (or a single
63330C...jet) according to independent fragmentation models.
63331
63332 SUBROUTINE PYINDF(IP)
63333
63334C...Double precision and integer declarations.
63335 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63336 IMPLICIT INTEGER(I-N)
63337 INTEGER PYK,PYCHGE,PYCOMP
63338C...Commonblocks.
63339 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63340 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63341 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63342 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
63343C...Local arrays.
63344 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
63345 &KFLO(2),PXO(2),PYO(2),WO(2)
63346
63347C.. MOPS error message
63348 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
63349 &' are not treated as expected in independent fragmentation')
63350
63351C...Reset counters. Identify parton system and take copy. Check flavour.
63352 NSAV=N
63353 MSTU90=MSTU(90)
63354 NJET=0
63355 KQSUM=0
63356 DO 100 J=1,5
63357 DPS(J)=0D0
63358 100 CONTINUE
63359 I=IP-1
63360 110 I=I+1
63361 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
63362 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
63363 IF(MSTU(21).GE.1) RETURN
63364 ENDIF
63365 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
63366 KC=PYCOMP(K(I,2))
63367 IF(KC.EQ.0) GOTO 110
63368 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
63369 IF(KQ.EQ.0) GOTO 110
63370 NJET=NJET+1
63371 IF(KQ.NE.2) KQSUM=KQSUM+KQ
63372 DO 120 J=1,5
63373 K(NSAV+NJET,J)=K(I,J)
63374 P(NSAV+NJET,J)=P(I,J)
63375 DPS(J)=DPS(J)+P(I,J)
63376 120 CONTINUE
63377 K(NSAV+NJET,3)=I
63378 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
63379 &K(I+1,1).EQ.2)) GOTO 110
63380 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
63381 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
63382 IF(MSTU(21).GE.1) RETURN
63383 ENDIF
63384
63385C...Boost copied system to CM frame. Find CM energy and sum flavours.
63386 IF(NJET.NE.1) THEN
63387 MSTU(33)=1
63388 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
63389 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
63390 ENDIF
63391 PECM=0D0
63392 DO 130 J=1,3
63393 NFI(J)=0
63394 130 CONTINUE
63395 DO 140 I=NSAV+1,NSAV+NJET
63396 PECM=PECM+P(I,4)
63397 KFA=IABS(K(I,2))
63398 IF(KFA.LE.3) THEN
63399 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
63400 ELSEIF(KFA.GT.1000) THEN
63401 KFLA=MOD(KFA/1000,10)
63402 KFLB=MOD(KFA/100,10)
63403 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
63404 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
63405 ENDIF
63406 140 CONTINUE
63407
63408C...Loop over attempts made. Reset counters.
63409 NTRY=0
63410 150 NTRY=NTRY+1
63411 IF(NTRY.GT.200) THEN
63412 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
63413 IF(MSTU(21).GE.1) RETURN
63414 ENDIF
63415 N=NSAV+NJET
63416 MSTU(90)=MSTU90
63417 DO 160 J=1,3
63418 NFL(J)=NFI(J)
63419 IFET(J)=0
63420 KFLF(J)=0
63421 160 CONTINUE
63422
63423C...Loop over jets to be fragmented.
63424 DO 230 IP1=NSAV+1,NSAV+NJET
63425 MSTJ(91)=0
63426 NSAV1=N
63427 MSTU91=MSTU(90)
63428
63429C...Initial flavour and momentum values. Jet along +z axis.
63430 KFLH=IABS(K(IP1,2))
63431 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
63432 KFLO(2)=0
63433 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
63434
63435C...Initial values for quark or diquark jet.
63436 170 IF(IABS(K(IP1,2)).NE.21) THEN
63437 NSTR=1
63438 KFLO(1)=K(IP1,2)
63439 CALL PYPTDI(0,PXO(1),PYO(1))
63440 WO(1)=WF
63441
63442C...Initial values for gluon treated like random quark jet.
63443 ELSEIF(MSTJ(2).LE.2) THEN
63444 NSTR=1
63445 IF(MSTJ(2).EQ.2) MSTJ(91)=1
63446 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63447 CALL PYPTDI(0,PXO(1),PYO(1))
63448 WO(1)=WF
63449
63450C...Initial values for gluon treated like quark-antiquark jet pair,
63451C...sharing energy according to Altarelli-Parisi splitting function.
63452 ELSE
63453 NSTR=2
63454 IF(MSTJ(2).EQ.4) MSTJ(91)=1
63455 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63456 KFLO(2)=-KFLO(1)
63457 CALL PYPTDI(0,PXO(1),PYO(1))
63458 PXO(2)=-PXO(1)
63459 PYO(2)=-PYO(1)
63460 WO(1)=WF*PYR(0)**(1D0/3D0)
63461 WO(2)=WF-WO(1)
63462 ENDIF
63463
63464C...Initial values for rank, flavour, pT and W+.
63465 DO 220 ISTR=1,NSTR
63466 180 I=N
63467 MSTU(90)=MSTU91
63468 IRANK=0
63469 KFL1=KFLO(ISTR)
63470 PX1=PXO(ISTR)
63471 PY1=PYO(ISTR)
63472 W=WO(ISTR)
63473
63474C...New hadron. Generate flavour and hadron species.
63475 190 I=I+1
63476 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
63477 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
63478 IF(MSTU(21).GE.1) RETURN
63479 ENDIF
63480 IRANK=IRANK+1
63481 K(I,1)=1
63482 K(I,3)=IP1
63483 K(I,4)=0
63484 K(I,5)=0
63485 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
63486 IF(K(I,2).EQ.0) GOTO 180
63487 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
63488 IF(PYR(0).GT.PARJ(19)) GOTO 200
63489 ENDIF
63490
63491C...Find hadron mass. Generate four-momentum.
63492 P(I,5)=PYMASS(K(I,2))
63493 CALL PYPTDI(KFL1,PX2,PY2)
63494 P(I,1)=PX1+PX2
63495 P(I,2)=PY1+PY2
63496 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
63497 CALL PYZDIS(KFL1,KFL2,PR,Z)
63498 MZSAV=0
63499 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
63500 MZSAV=1
63501 MSTU(90)=MSTU(90)+1
63502 MSTU(90+MSTU(90))=I
63503 PARU(90+MSTU(90))=Z
63504 ENDIF
63505 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
63506 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
63507 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
63508 & P(I,3).LE.0.001D0) THEN
63509 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
63510 P(I,3)=0.0001D0
63511 P(I,4)=SQRT(PR)
63512 Z=P(I,4)/W
63513 ENDIF
63514
63515C...Remaining flavour and momentum.
63516 KFL1=-KFL2
63517 PX1=-PX2
63518 PY1=-PY2
63519 W=(1D0-Z)*W
63520 DO 210 J=1,5
63521 V(I,J)=0D0
63522 210 CONTINUE
63523
63524C...Check if pL acceptable. Go back for new hadron if enough energy.
63525 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
63526 I=I-1
63527 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
63528 ENDIF
63529 IF(W.GT.PARJ(31)) GOTO 190
63530 N=I
63531 220 CONTINUE
63532 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
63533 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
63534
63535C...Rotate jet to new direction.
63536 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
63537 PHI=PYANGL(P(IP1,1),P(IP1,2))
63538 MSTU(33)=1
63539 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
63540 K(K(IP1,3),4)=NSAV1+1
63541 K(K(IP1,3),5)=N
63542
63543C...End of jet generation loop. Skip conservation in some cases.
63544 230 CONTINUE
63545 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
63546 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
63547
63548C...Subtract off produced hadron flavours, finished if zero.
63549 DO 240 I=NSAV+NJET+1,N
63550 KFA=IABS(K(I,2))
63551 KFLA=MOD(KFA/1000,10)
63552 KFLB=MOD(KFA/100,10)
63553 KFLC=MOD(KFA/10,10)
63554 IF(KFLA.EQ.0) THEN
63555 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
63556 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
63557 ELSE
63558 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
63559 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
63560 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
63561 ENDIF
63562 240 CONTINUE
63563 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63564 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63565 IF(NREQ.EQ.0) GOTO 320
63566
63567C...Take away flavour of low-momentum particles until enough freedom.
63568 NREM=0
63569 250 IREM=0
63570 P2MIN=PECM**2
63571 DO 260 I=NSAV+NJET+1,N
63572 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
63573 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
63574 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
63575 260 CONTINUE
63576 IF(IREM.EQ.0) GOTO 150
63577 K(IREM,1)=7
63578 KFA=IABS(K(IREM,2))
63579 KFLA=MOD(KFA/1000,10)
63580 KFLB=MOD(KFA/100,10)
63581 KFLC=MOD(KFA/10,10)
63582 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
63583 IF(K(IREM,1).EQ.8) GOTO 250
63584 IF(KFLA.EQ.0) THEN
63585 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
63586 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
63587 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
63588 ELSE
63589 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
63590 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
63591 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
63592 ENDIF
63593 NREM=NREM+1
63594 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63595 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63596 IF(NREQ.GT.NREM) GOTO 250
63597 DO 270 I=NSAV+NJET+1,N
63598 IF(K(I,1).EQ.8) K(I,1)=1
63599 270 CONTINUE
63600
63601C...Find combination of existing and new flavours for hadron.
63602 280 NFET=2
63603 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
63604 IF(NREQ.LT.NREM) NFET=1
63605 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
63606 DO 290 J=1,NFET
63607 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
63608 KFLF(J)=ISIGN(1,NFL(1))
63609 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
63610 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
63611 290 CONTINUE
63612 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
63613 &GOTO 280
63614 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
63615 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
63616 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
63617 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
63618 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
63619 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
63620 IF(NFET.LE.2) KFLF(3)=0
63621 IF(KFLF(3).NE.0) THEN
63622 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
63623 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
63624 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
63625 & KFLFC=KFLFC+ISIGN(2,KFLFC)
63626 ELSE
63627 KFLFC=KFLF(1)
63628 ENDIF
63629 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
63630 IF(KF.EQ.0) GOTO 280
63631 DO 300 J=1,MAX(2,NFET)
63632 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
63633 300 CONTINUE
63634
63635C...Store hadron at random among free positions.
63636 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
63637 DO 310 I=NSAV+NJET+1,N
63638 IF(K(I,1).EQ.7) NPOS=NPOS-1
63639 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
63640 K(I,1)=1
63641 K(I,2)=KF
63642 P(I,5)=PYMASS(K(I,2))
63643 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63644 310 CONTINUE
63645 NREM=NREM-1
63646 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63647 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63648 IF(NREM.GT.0) GOTO 280
63649
63650C...Compensate for missing momentum in global scheme (3 options).
63651 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
63652 DO 340 J=1,3
63653 PSI(J)=0D0
63654 DO 330 I=NSAV+NJET+1,N
63655 PSI(J)=PSI(J)+P(I,J)
63656 330 CONTINUE
63657 340 CONTINUE
63658 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
63659 PWS=0D0
63660 DO 350 I=NSAV+NJET+1,N
63661 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
63662 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63663 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63664 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
63665 350 CONTINUE
63666 DO 370 I=NSAV+NJET+1,N
63667 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
63668 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63669 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63670 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
63671 DO 360 J=1,3
63672 P(I,J)=P(I,J)-PSI(J)*PW/PWS
63673 360 CONTINUE
63674 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63675 370 CONTINUE
63676
63677C...Compensate for missing momentum withing each jet separately.
63678 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
63679 DO 390 I=N+1,N+NJET
63680 K(I,1)=0
63681 DO 380 J=1,5
63682 P(I,J)=0D0
63683 380 CONTINUE
63684 390 CONTINUE
63685 DO 410 I=NSAV+NJET+1,N
63686 IR1=K(I,3)
63687 IR2=N+IR1-NSAV
63688 K(IR2,1)=K(IR2,1)+1
63689 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63690 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63691 DO 400 J=1,3
63692 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
63693 400 CONTINUE
63694 P(IR2,4)=P(IR2,4)+P(I,4)
63695 P(IR2,5)=P(IR2,5)+PLS
63696 410 CONTINUE
63697 PSS=0D0
63698 DO 420 I=N+1,N+NJET
63699 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
63700 420 CONTINUE
63701 DO 440 I=NSAV+NJET+1,N
63702 IR1=K(I,3)
63703 IR2=N+IR1-NSAV
63704 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63705 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63706 DO 430 J=1,3
63707 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
63708 & PLS*P(IR1,J)
63709 430 CONTINUE
63710 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63711 440 CONTINUE
63712 ENDIF
63713
63714C...Scale momenta for energy conservation.
63715 IF(MOD(MSTJ(3),5).NE.0) THEN
63716 PMS=0D0
63717 PES=0D0
63718 PQS=0D0
63719 DO 450 I=NSAV+NJET+1,N
63720 PMS=PMS+P(I,5)
63721 PES=PES+P(I,4)
63722 PQS=PQS+P(I,5)**2/P(I,4)
63723 450 CONTINUE
63724 IF(PMS.GE.PECM) GOTO 150
63725 NECO=0
63726 460 NECO=NECO+1
63727 PFAC=(PECM-PQS)/(PES-PQS)
63728 PES=0D0
63729 PQS=0D0
63730 DO 480 I=NSAV+NJET+1,N
63731 DO 470 J=1,3
63732 P(I,J)=PFAC*P(I,J)
63733 470 CONTINUE
63734 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63735 PES=PES+P(I,4)
63736 PQS=PQS+P(I,5)**2/P(I,4)
63737 480 CONTINUE
63738 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
63739 ENDIF
63740
63741C...Origin of produced particles and parton daughter pointers.
63742 490 DO 500 I=NSAV+NJET+1,N
63743 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
63744 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
63745 500 CONTINUE
63746 DO 510 I=NSAV+1,NSAV+NJET
63747 I1=K(I,3)
63748 K(I1,1)=K(I1,1)+10
63749 IF(MSTU(16).NE.2) THEN
63750 K(I1,4)=NSAV+1
63751 K(I1,5)=NSAV+1
63752 ELSE
63753 K(I1,4)=K(I1,4)-NJET+1
63754 K(I1,5)=K(I1,5)-NJET+1
63755 IF(K(I1,5).LT.K(I1,4)) THEN
63756 K(I1,4)=0
63757 K(I1,5)=0
63758 ENDIF
63759 ENDIF
63760 510 CONTINUE
63761
63762C...Document independent fragmentation system. Remove copy of jets.
63763 NSAV=NSAV+1
63764 K(NSAV,1)=11
63765 K(NSAV,2)=93
63766 K(NSAV,3)=IP
63767 K(NSAV,4)=NSAV+1
63768 K(NSAV,5)=N-NJET+1
63769 DO 520 J=1,4
63770 P(NSAV,J)=DPS(J)
63771 V(NSAV,J)=V(IP,J)
63772 520 CONTINUE
63773 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63774 V(NSAV,5)=0D0
63775 DO 540 I=NSAV+NJET,N
63776 DO 530 J=1,5
63777 K(I-NJET+1,J)=K(I,J)
63778 P(I-NJET+1,J)=P(I,J)
63779 V(I-NJET+1,J)=V(I,J)
63780 530 CONTINUE
63781 540 CONTINUE
63782 N=N-NJET+1
63783 DO 550 IZ=MSTU90+1,MSTU(90)
63784 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
63785 550 CONTINUE
63786
63787C...Boost back particle system. Set production vertices.
63788 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
63789 &DPS(2)/DPS(4),DPS(3)/DPS(4))
63790 DO 570 I=NSAV+1,N
63791 DO 560 J=1,4
63792 V(I,J)=V(IP,J)
63793 560 CONTINUE
63794 570 CONTINUE
63795
63796 RETURN
63797 END
63798
63799C*********************************************************************
63800
63801C...PYDECY
63802C...Handles the decay of unstable particles.
63803
63804 SUBROUTINE PYDECY(IP)
63805
63806C...Double precision and integer declarations.
63807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63808 IMPLICIT INTEGER(I-N)
63809 INTEGER PYK,PYCHGE,PYCOMP
63810C...Commonblocks.
63811 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63812 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63813 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63814 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
63815 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
63816C...Local arrays.
63817 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
63818 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
63819 CHARACTER CIDC*4
63820 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
63821
63822C...Functions: momentum in two-particle decays and four-product.
63823 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
63824 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)
63825
63826C...Initial values.
63827 NTRY=0
63828 NSAV=N
63829 KFA=IABS(K(IP,2))
63830 KFS=ISIGN(1,K(IP,2))
63831 KC=PYCOMP(KFA)
63832 MSTJ(92)=0
63833
63834C...Choose lifetime and determine decay vertex.
63835 IF(K(IP,1).EQ.5) THEN
63836 V(IP,5)=0D0
63837 ELSEIF(K(IP,1).NE.4) THEN
63838 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
63839 ENDIF
63840 DO 100 J=1,4
63841 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
63842 100 CONTINUE
63843
63844C...Determine whether decay allowed or not.
63845 MOUT=0
63846 IF(MSTJ(22).EQ.2) THEN
63847 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
63848 ELSEIF(MSTJ(22).EQ.3) THEN
63849 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
63850 ELSEIF(MSTJ(22).EQ.4) THEN
63851 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
63852 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
63853 ENDIF
63854 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
63855 K(IP,1)=4
63856 RETURN
63857 ENDIF
63858
63859C...Interface to external tau decay library (for tau polarization).
63860 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
63861
63862C...Starting values for pointers and momenta.
63863 ITAU=IP
63864 DO 110 J=1,4
63865 PTAU(J)=P(ITAU,J)
63866 PCMTAU(J)=P(ITAU,J)
63867 110 CONTINUE
63868
63869C...Iterate to find position and code of mother of tau.
63870 IMTAU=ITAU
63871 120 IMTAU=K(IMTAU,3)
63872
63873 IF(IMTAU.EQ.0) THEN
63874C...If no known origin then impossible to do anything further.
63875 KFORIG=0
63876 IORIG=0
63877
63878 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
63879C...If tau -> tau + gamma then add gamma energy and loop.
63880 IF(K(K(IMTAU,4),2).EQ.22) THEN
63881 DO 130 J=1,4
63882 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
63883 130 CONTINUE
63884 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
63885 DO 140 J=1,4
63886 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
63887 140 CONTINUE
63888 ENDIF
63889 GOTO 120
63890
63891 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
63892C...If coming from weak decay of hadron then W is not stored in record,
63893C...but can be reconstructed by adding neutrino momentum.
63894 KFORIG=-ISIGN(24,K(ITAU,2))
63895 IORIG=0
63896 DO 160 II=K(IMTAU,4),K(IMTAU,5)
63897 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
63898 DO 150 J=1,4
63899 PCMTAU(J)=PCMTAU(J)+P(II,J)
63900 150 CONTINUE
63901 ENDIF
63902 160 CONTINUE
63903
63904 ELSE
63905C...If coming from resonance decay then find latest copy of this
63906C...resonance (may not completely agree).
63907 KFORIG=K(IMTAU,2)
63908 IORIG=IMTAU
63909 DO 170 II=IMTAU+1,IP-1
63910 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
63911 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
63912 170 CONTINUE
63913 DO 180 J=1,4
63914 PCMTAU(J)=P(IORIG,J)
63915 180 CONTINUE
63916 ENDIF
63917
63918C...Boost tau to rest frame of production process (where known)
63919C...and rotate it to sit along +z axis.
63920 DO 190 J=1,3
63921 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
63922 190 CONTINUE
63923 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
63924 & -DBETAU(2),-DBETAU(3))
63925 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
63926 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
63927 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
63928 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
63929
63930C...Call tau decay routine (if meaningful) and fill extra info.
63931 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63932 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
63933 DO 200 II=NSAV+1,NSAV+NDECAY
63934 K(II,1)=1
63935 K(II,3)=IP
63936 K(II,4)=0
63937 K(II,5)=0
63938 200 CONTINUE
63939 N=NSAV+NDECAY
63940 ENDIF
63941
63942C...Boost back decay tau and decay products.
63943 DO 210 J=1,4
63944 P(ITAU,J)=PTAU(J)
63945 210 CONTINUE
63946 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63947 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
63948 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
63949 & DBETAU(2),DBETAU(3))
63950
63951C...Skip past ordinary tau decay treatment.
63952 MMAT=0
63953 MBST=0
63954 ND=0
63955 GOTO 630
63956 ENDIF
63957 ENDIF
63958
63959C...B-Bbar mixing: flip sign of meson appropriately.
63960 MMIX=0
63961 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
63962 XBBMIX=PARJ(76)
63963 IF(KFA.EQ.531) XBBMIX=PARJ(77)
63964 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
63965 IF(MMIX.EQ.1) KFS=-KFS
63966 ENDIF
63967
63968C...Check existence of decay channels. Particle/antiparticle rules.
63969 KCA=KC
63970 IF(MDCY(KC,2).GT.0) THEN
63971 MDMDCY=MDME(MDCY(KC,2),2)
63972 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
63973 ENDIF
63974 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
63975 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
63976 RETURN
63977 ENDIF
63978 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
63979 IF(KCHG(KC,3).EQ.0) THEN
63980 KFSP=1
63981 KFSN=0
63982 IF(PYR(0).GT.0.5D0) KFS=-KFS
63983 ELSEIF(KFS.GT.0) THEN
63984 KFSP=1
63985 KFSN=0
63986 ELSE
63987 KFSP=0
63988 KFSN=1
63989 ENDIF
63990
63991C...Sum branching ratios of allowed decay channels.
63992 220 NOPE=0
63993 BRSU=0D0
63994 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
63995 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
63996 & KFSN*MDME(IDL,1).NE.3) GOTO 230
63997 IF(MDME(IDL,2).GT.100) GOTO 230
63998 NOPE=NOPE+1
63999 BRSU=BRSU+BRAT(IDL)
64000 230 CONTINUE
64001 IF(NOPE.EQ.0) THEN
64002 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
64003 RETURN
64004 ENDIF
64005
64006C...Select decay channel among allowed ones.
64007 240 RBR=BRSU*PYR(0)
64008 IDL=MDCY(KCA,2)-1
64009 250 IDL=IDL+1
64010 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64011 &KFSN*MDME(IDL,1).NE.3) THEN
64012 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64013 ELSEIF(MDME(IDL,2).GT.100) THEN
64014 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64015 ELSE
64016 IDC=IDL
64017 RBR=RBR-BRAT(IDL)
64018 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
64019 ENDIF
64020
64021C...Start readout of decay channel: matrix element, reset counters.
64022 MMAT=MDME(IDC,2)
64023 260 NTRY=NTRY+1
64024 IF(MOD(NTRY,200).EQ.0) THEN
64025 WRITE(CIDC,'(I4)') IDC
64026C...Do not print warning for some well-known special cases.
64027 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
64028 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
64029 & CIDC)
64030 GOTO 240
64031 ENDIF
64032 IF(NTRY.GT.1000) THEN
64033 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64034 IF(MSTU(21).GE.1) RETURN
64035 ENDIF
64036 I=N
64037 NP=0
64038 NQ=0
64039 MBST=0
64040 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
64041 DO 270 J=1,4
64042 PV(1,J)=0D0
64043 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
64044 270 CONTINUE
64045 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
64046 PV(1,5)=P(IP,5)
64047 PS=0D0
64048 PSQ=0D0
64049 MREM=0
64050 MHADDY=0
64051 IF(KFA.GT.80) MHADDY=1
64052C.. Random flavour and popcorn system memory.
64053 IRNDMO=0
64054 JTMO=0
64055 MSTU(121)=0
64056 MSTU(125)=10
64057
64058C...Read out decay products. Convert to standard flavour code.
64059 JTMAX=5
64060 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
64061 DO 280 JT=1,JTMAX
64062 IF(JT.LE.5) KP=KFDP(IDC,JT)
64063 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
64064 IF(KP.EQ.0) GOTO 280
64065 KPA=IABS(KP)
64066 KCP=PYCOMP(KPA)
64067 IF(KPA.GT.80) MHADDY=1
64068 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
64069 KFP=KP
64070 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
64071 KFP=KFS*KP
64072 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
64073 KFP=-KFS*MOD(KFA/10,10)
64074 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
64075 KFP=KFS*(100*MOD(KFA/10,100)+3)
64076 ELSEIF(KPA.EQ.81) THEN
64077 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
64078 ELSEIF(KP.EQ.82) THEN
64079 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
64080 IF(KFP.EQ.0) GOTO 260
64081 KFP=-KFP
64082 IRNDMO=1
64083 MSTJ(93)=1
64084 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
64085 ELSEIF(KP.EQ.-82) THEN
64086 KFP=MSTU(124)
64087 ENDIF
64088 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
64089
64090C...Add decay product to event record or to quark flavour list.
64091 KFPA=IABS(KFP)
64092 KQP=KCHG(KCP,2)
64093 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
64094 NQ=NQ+1
64095 KFLO(NQ)=KFP
64096C...set rndmflav popcorn system pointer
64097 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
64098 MSTJ(93)=2
64099 PSQ=PSQ+PYMASS(KFLO(NQ))
64100 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
64101 & MOD(NQ,2).EQ.1) THEN
64102 NQ=NQ-1
64103 PS=PS-P(I,5)
64104 K(I,1)=1
64105 KFI=K(I,2)
64106 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
64107 IF(K(I,2).EQ.0) GOTO 260
64108 MSTJ(93)=1
64109 P(I,5)=PYMASS(K(I,2))
64110 PS=PS+P(I,5)
64111 ELSE
64112 I=I+1
64113 NP=NP+1
64114 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
64115 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
64116 K(I,1)=1+MOD(NQ,2)
64117 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
64118 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
64119 K(I,2)=KFP
64120 K(I,3)=IP
64121 K(I,4)=0
64122 K(I,5)=0
64123 P(I,5)=PYMASS(KFP)
64124 PS=PS+P(I,5)
64125 ENDIF
64126 280 CONTINUE
64127
64128C...Check masses for resonance decays.
64129 IF(MHADDY.EQ.0) THEN
64130 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
64131 ENDIF
64132
64133C...Choose decay multiplicity in phase space model.
64134 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
64135 PSP=PS
64136 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
64137 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
64138 300 NTRY=NTRY+1
64139C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
64140 IF(IRNDMO.EQ.0) THEN
64141 MSTU(121)=0
64142 JTMO=0
64143 ELSEIF(IRNDMO.EQ.1) THEN
64144 IRNDMO=2
64145 ELSE
64146 GOTO 260
64147 ENDIF
64148 IF(NTRY.GT.1000) THEN
64149 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64150 IF(MSTU(21).GE.1) RETURN
64151 ENDIF
64152 IF(MMAT.LE.20) THEN
64153 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
64154 & SIN(PARU(2)*PYR(0))
64155 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
64156 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
64157 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
64158 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
64159 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
64160 ELSE
64161 ND=MMAT-20
64162 ENDIF
64163C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
64164 MSTU(125)=ND-NQ/2
64165 IF(MSTU(121).GT.MSTU(125)) GOTO 300
64166
64167C...Form hadrons from flavour content.
64168 DO 310 JT=1,NQ
64169 KFL1(JT)=KFLO(JT)
64170 310 CONTINUE
64171 IF(ND.EQ.NP+NQ/2) GOTO 330
64172 DO 320 I=N+NP+1,N+ND-NQ/2
64173C.. Stick to started popcorn system, else pick side at random
64174 JT=JTMO
64175 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
64176 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
64177 IF(K(I,2).EQ.0) GOTO 300
64178 MSTU(125)=MSTU(125)-1
64179 JTMO=0
64180 IF(MSTU(121).GT.0) JTMO=JT
64181 KFL1(JT)=-KFL2
64182 320 CONTINUE
64183 330 JT=2
64184 JT2=3
64185 JT3=4
64186 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
64187 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
64188 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
64189 IF(JT.EQ.3) JT2=2
64190 IF(JT.EQ.4) JT3=2
64191 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
64192 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
64193 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
64194 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
64195
64196C...Check that sum of decay product masses not too large.
64197 PS=PSP
64198 DO 340 I=N+NP+1,N+ND
64199 K(I,1)=1
64200 K(I,3)=IP
64201 K(I,4)=0
64202 K(I,5)=0
64203 P(I,5)=PYMASS(K(I,2))
64204 PS=PS+P(I,5)
64205 340 CONTINUE
64206 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
64207
64208C...Rescale energy to subtract off spectator quark mass.
64209 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
64210 & .AND.NP.GE.3) THEN
64211 PS=PS-P(N+NP,5)
64212 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
64213 DO 350 J=1,5
64214 P(N+NP,J)=PQT*PV(1,J)
64215 PV(1,J)=(1D0-PQT)*PV(1,J)
64216 350 CONTINUE
64217 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64218 ND=NP-1
64219 MREM=1
64220
64221C...Fully specified final state: check mass broadening effects.
64222 ELSE
64223 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
64224 ND=NP
64225 ENDIF
64226
64227C...Determine position of grandmother, number of sisters.
64228 NM=0
64229 KFAS=0
64230 MSGN=0
64231 IF(MMAT.EQ.3) THEN
64232 IM=K(IP,3)
64233 IF(IM.LT.0.OR.IM.GE.IP) IM=0
64234 IF(IM.NE.0) KFAM=IABS(K(IM,2))
64235 IF(IM.NE.0) THEN
64236 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
64237 IF(K(IL,3).EQ.IM) NM=NM+1
64238 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
64239 360 CONTINUE
64240 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
64241 & MOD(KFAM/1000,10).NE.0) NM=0
64242 IF(NM.EQ.2) THEN
64243 KFAS=IABS(K(ISIS,2))
64244 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
64245 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
64246 ENDIF
64247 ENDIF
64248 ENDIF
64249
64250C...Kinematics of one-particle decays.
64251 IF(ND.EQ.1) THEN
64252 DO 370 J=1,4
64253 P(N+1,J)=P(IP,J)
64254 370 CONTINUE
64255 GOTO 630
64256 ENDIF
64257
64258C...Calculate maximum weight ND-particle decay.
64259 PV(ND,5)=P(N+ND,5)
64260 IF(ND.GE.3) THEN
64261 WTMAX=1D0/WTCOR(ND-2)
64262 PMAX=PV(1,5)-PS+P(N+ND,5)
64263 PMIN=0D0
64264 DO 380 IL=ND-1,1,-1
64265 PMAX=PMAX+P(N+IL,5)
64266 PMIN=PMIN+P(N+IL+1,5)
64267 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
64268 380 CONTINUE
64269 ENDIF
64270
64271C...Find virtual gamma mass in Dalitz decay.
64272 390 IF(ND.EQ.2) THEN
64273 ELSEIF(MMAT.EQ.2) THEN
64274 PMES=4D0*PMAS(11,1)**2
64275 PMRHO2=PMAS(131,1)**2
64276 PGRHO2=PMAS(131,2)**2
64277 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
64278 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
64279 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
64280 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
64281 IF(WT.LT.PYR(0)) GOTO 400
64282 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
64283
64284C...M-generator gives weight. If rejected, try again.
64285 ELSE
64286 410 RORD(1)=1D0
64287 DO 440 IL1=2,ND-1
64288 RSAV=PYR(0)
64289 DO 420 IL2=IL1-1,1,-1
64290 IF(RSAV.LE.RORD(IL2)) GOTO 430
64291 RORD(IL2+1)=RORD(IL2)
64292 420 CONTINUE
64293 430 RORD(IL2+1)=RSAV
64294 440 CONTINUE
64295 RORD(ND)=0D0
64296 WT=1D0
64297 DO 450 IL=ND-1,1,-1
64298 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
64299 & (PV(1,5)-PS)
64300 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64301 450 CONTINUE
64302 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
64303 ENDIF
64304
64305C...Perform two-particle decays in respective CM frame.
64306 460 DO 480 IL=1,ND-1
64307 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64308 UE(3)=2D0*PYR(0)-1D0
64309 PHI=PARU(2)*PYR(0)
64310 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
64311 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
64312 DO 470 J=1,3
64313 P(N+IL,J)=PA*UE(J)
64314 PV(IL+1,J)=-PA*UE(J)
64315 470 CONTINUE
64316 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
64317 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
64318 480 CONTINUE
64319
64320C...Lorentz transform decay products to lab frame.
64321 DO 490 J=1,4
64322 P(N+ND,J)=PV(ND,J)
64323 490 CONTINUE
64324 DO 530 IL=ND-1,1,-1
64325 DO 500 J=1,3
64326 BE(J)=PV(IL,J)/PV(IL,4)
64327 500 CONTINUE
64328 GA=PV(IL,4)/PV(IL,5)
64329 DO 520 I=N+IL,N+ND
64330 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64331 DO 510 J=1,3
64332 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64333 510 CONTINUE
64334 P(I,4)=GA*(P(I,4)+BEP)
64335 520 CONTINUE
64336 530 CONTINUE
64337
64338C...Check that no infinite loop in matrix element weight.
64339 NTRY=NTRY+1
64340 IF(NTRY.GT.800) GOTO 560
64341
64342C...Matrix elements for omega and phi decays.
64343 IF(MMAT.EQ.1) THEN
64344 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
64345 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
64346 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
64347 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
64348
64349C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
64350 ELSEIF(MMAT.EQ.2) THEN
64351 FOUR12=FOUR(N+1,N+2)
64352 FOUR13=FOUR(N+1,N+3)
64353 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
64354 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
64355 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
64356
64357C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
64358C...V vector), of form cos**2(theta02) in V1 rest frame, and for
64359C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
64360 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
64361 FOUR10=FOUR(IP,IM)
64362 FOUR12=FOUR(IP,N+1)
64363 FOUR02=FOUR(IM,N+1)
64364 PMS1=P(IP,5)**2
64365 PMS0=P(IM,5)**2
64366 PMS2=P(N+1,5)**2
64367 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
64368 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
64369 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
64370 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
64371 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
64372 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
64373
64374C...Matrix element for "onium" -> g + g + g or gamma + g + g.
64375 ELSEIF(MMAT.EQ.4) THEN
64376 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64377 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
64378 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
64379 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
64380 & ((1D0-HX3)/(HX1*HX2))**2
64381 IF(WT.LT.2D0*PYR(0)) GOTO 390
64382 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
64383 & GOTO 390
64384
64385C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
64386 ELSEIF(MMAT.EQ.41) THEN
64387 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64388 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
64389 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
64390 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
64391
64392C...Matrix elements for weak decays (only semileptonic for c and b)
64393 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64394 & .AND.ND.EQ.3) THEN
64395 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
64396 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
64397 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64398 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
64399 DO 550 J=1,4
64400 P(N+NP+1,J)=0D0
64401 DO 540 IS=N+3,N+NP
64402 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
64403 540 CONTINUE
64404 550 CONTINUE
64405 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
64406 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
64407 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64408 ENDIF
64409
64410C...Scale back energy and reattach spectator.
64411 560 IF(MREM.EQ.1) THEN
64412 DO 570 J=1,5
64413 PV(1,J)=PV(1,J)/(1D0-PQT)
64414 570 CONTINUE
64415 ND=ND+1
64416 MREM=0
64417 ENDIF
64418
64419C...Low invariant mass for system with spectator quark gives particle,
64420C...not two jets. Readjust momenta accordingly.
64421 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
64422 MSTJ(93)=1
64423 PM2=PYMASS(K(N+2,2))
64424 MSTJ(93)=1
64425 PM3=PYMASS(K(N+3,2))
64426 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
64427 & (PARJ(32)+PM2+PM3)**2) GOTO 630
64428 K(N+2,1)=1
64429 KFTEMP=K(N+2,2)
64430 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
64431 IF(K(N+2,2).EQ.0) GOTO 260
64432 P(N+2,5)=PYMASS(K(N+2,2))
64433 PS=P(N+1,5)+P(N+2,5)
64434 PV(2,5)=P(N+2,5)
64435 MMAT=0
64436 ND=2
64437 GOTO 460
64438 ELSEIF(MMAT.EQ.44) THEN
64439 MSTJ(93)=1
64440 PM3=PYMASS(K(N+3,2))
64441 MSTJ(93)=1
64442 PM4=PYMASS(K(N+4,2))
64443 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
64444 & (PARJ(32)+PM3+PM4)**2) GOTO 600
64445 K(N+3,1)=1
64446 KFTEMP=K(N+3,2)
64447 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
64448 IF(K(N+3,2).EQ.0) GOTO 260
64449 P(N+3,5)=PYMASS(K(N+3,2))
64450 DO 580 J=1,3
64451 P(N+3,J)=P(N+3,J)+P(N+4,J)
64452 580 CONTINUE
64453 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)
64454 HA=P(N+1,4)**2-P(N+2,4)**2
64455 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
64456 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
64457 & (P(N+1,3)-P(N+2,3))**2
64458 HD=(PV(1,4)-P(N+3,4))**2
64459 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
64460 HF=HD*HC-HB**2
64461 HG=HD*HC-HA*HB
64462 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
64463 DO 590 J=1,3
64464 PCOR=HH*(P(N+1,J)-P(N+2,J))
64465 P(N+1,J)=P(N+1,J)+PCOR
64466 P(N+2,J)=P(N+2,J)-PCOR
64467 590 CONTINUE
64468 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)
64469 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)
64470 ND=ND-1
64471 ENDIF
64472
64473C...Check invariant mass of W jets. May give one particle or start over.
64474 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64475 &.AND.IABS(K(N+1,2)).LT.10) THEN
64476 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
64477 MSTJ(93)=1
64478 PM1=PYMASS(K(N+1,2))
64479 MSTJ(93)=1
64480 PM2=PYMASS(K(N+2,2))
64481 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
64482 KFLDUM=INT(1.5D0+PYR(0))
64483 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
64484 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
64485 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
64486 PSM=PYMASS(KF1)+PYMASS(KF2)
64487 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
64488 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
64489 IF(MMAT.EQ.48) GOTO 390
64490 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
64491 K(N+1,1)=1
64492 KFTEMP=K(N+1,2)
64493 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
64494 IF(K(N+1,2).EQ.0) GOTO 260
64495 P(N+1,5)=PYMASS(K(N+1,2))
64496 K(N+2,2)=K(N+3,2)
64497 P(N+2,5)=P(N+3,5)
64498 PS=P(N+1,5)+P(N+2,5)
64499 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64500 PV(2,5)=P(N+3,5)
64501 MMAT=0
64502 ND=2
64503 GOTO 460
64504 ENDIF
64505
64506C...Phase space decay of partons from W decay.
64507 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
64508 KFLO(1)=K(N+1,2)
64509 KFLO(2)=K(N+2,2)
64510 K(N+1,1)=K(N+3,1)
64511 K(N+1,2)=K(N+3,2)
64512 DO 620 J=1,5
64513 PV(1,J)=P(N+1,J)+P(N+2,J)
64514 P(N+1,J)=P(N+3,J)
64515 620 CONTINUE
64516 PV(1,5)=PMR
64517 N=N+1
64518 NP=0
64519 NQ=2
64520 PS=0D0
64521 MSTJ(93)=2
64522 PSQ=PYMASS(KFLO(1))
64523 MSTJ(93)=2
64524 PSQ=PSQ+PYMASS(KFLO(2))
64525 MMAT=11
64526 GOTO 290
64527 ENDIF
64528
64529C...Boost back for rapidly moving particle.
64530 630 N=N+ND
64531 IF(MBST.EQ.1) THEN
64532 DO 640 J=1,3
64533 BE(J)=P(IP,J)/P(IP,4)
64534 640 CONTINUE
64535 GA=P(IP,4)/P(IP,5)
64536 DO 660 I=NSAV+1,N
64537 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64538 DO 650 J=1,3
64539 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64540 650 CONTINUE
64541 P(I,4)=GA*(P(I,4)+BEP)
64542 660 CONTINUE
64543 ENDIF
64544
64545C...Fill in position of decay vertex.
64546 DO 680 I=NSAV+1,N
64547 DO 670 J=1,4
64548 V(I,J)=VDCY(J)
64549 670 CONTINUE
64550 V(I,5)=0D0
64551 680 CONTINUE
64552
64553C...Set up for parton shower evolution from jets.
64554 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
64555 K(NSAV+1,1)=3
64556 K(NSAV+2,1)=3
64557 K(NSAV+3,1)=3
64558 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64559 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64560 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64561 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64562 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64563 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64564 MSTJ(92)=-(NSAV+1)
64565 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
64566 K(NSAV+2,1)=3
64567 K(NSAV+3,1)=3
64568 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64569 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
64570 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
64571 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64572 MSTJ(92)=NSAV+2
64573 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64574 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
64575 K(NSAV+1,1)=3
64576 K(NSAV+2,1)=3
64577 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64578 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
64579 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
64580 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64581 MSTJ(92)=NSAV+1
64582 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64583 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
64584 MSTJ(92)=NSAV+1
64585 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
64586 & THEN
64587 K(NSAV+1,1)=3
64588 K(NSAV+2,1)=3
64589 K(NSAV+3,1)=3
64590 KCP=PYCOMP(K(NSAV+1,2))
64591 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
64592 JCON=4
64593 IF(KQP.LT.0) JCON=5
64594 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
64595 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
64596 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
64597 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
64598 MSTJ(92)=NSAV+1
64599 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
64600 K(NSAV+1,1)=3
64601 K(NSAV+3,1)=3
64602 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
64603 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64604 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64605 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
64606 MSTJ(92)=NSAV+1
64607 ENDIF
64608
64609C...Mark decayed particle; special option for B-Bbar mixing.
64610 IF(K(IP,1).EQ.5) K(IP,1)=15
64611 IF(K(IP,1).LE.10) K(IP,1)=11
64612 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
64613 K(IP,4)=NSAV+1
64614 K(IP,5)=N
64615
64616 RETURN
64617 END
64618
64619
64620C*********************************************************************
64621
64622C...PYDCYK
64623C...Handles flavour production in the decay of unstable particles
64624C...and small string clusters.
64625
64626 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
64627
64628C...Double precision and integer declarations.
64629 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64630 IMPLICIT INTEGER(I-N)
64631 INTEGER PYK,PYCHGE,PYCOMP
64632C...Commonblocks.
64633 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64634 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64635 SAVE /PYDAT1/,/PYDAT2/
64636
64637
64638C.. Call PYKFDI directly if no popcorn option is on
64639 IF(MSTJ(12).LT.2) THEN
64640 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64641 MSTU(124)=KFL3
64642 RETURN
64643 ENDIF
64644
64645 KFL3=0
64646 KF=0
64647 IF(KFL1.EQ.0) RETURN
64648 KF1A=IABS(KFL1)
64649 KF2A=IABS(KFL2)
64650
64651 NSTO=130
64652 NMAX=MIN(MSTU(125),10)
64653
64654C.. Identify rank 0 cluster qq
64655 IRANK=1
64656 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
64657
64658 IF(KF2A.GT.0)THEN
64659C.. Join jets: Fails if store not empty
64660 IF(MSTU(121).GT.0) THEN
64661 MSTU(121)=0
64662 RETURN
64663 ENDIF
64664 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64665 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
64666C.. Pick popcorn meson from store, return same qq, decrease store
64667 KF=MSTU(NSTO+MSTU(121))
64668 KFL3=-KFL1
64669 MSTU(121)=MSTU(121)-1
64670 ELSE
64671C.. Generate new flavour. Then done if no diquark is generated
64672 100 CALL PYKFDI(KFL1,0,KFL3,KF)
64673 IF(MSTU(121).EQ.-1) GOTO 100
64674 MSTU(124)=KFL3
64675 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
64676
64677C.. Simple case if no dynamical popcorn suppressions are considered
64678 IF(MSTJ(12).LT.4) THEN
64679 IF(MSTU(121).EQ.0) RETURN
64680 NMES=1
64681 KFPREV=-KFL3
64682 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64683C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
64684 IF(IABS(KFL3).LE.10)THEN
64685 KFL3=-KFPREV
64686 RETURN
64687 ENDIF
64688 GOTO 120
64689 ENDIF
64690
64691C test output qq against fake Gamma, then return if no popcorn.
64692 GB=2D0
64693 IF(IRANK.NE.0)THEN
64694 CALL PYZDIS(1,2103,5D0,Z)
64695 GB=5D0*(1D0-Z)/Z
64696 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
64697 MSTU(121)=0
64698 GOTO 100
64699 ENDIF
64700 ENDIF
64701 IF(MSTU(121).EQ.0) RETURN
64702
64703C..Set store size memory. Pick fake dynamical variables of qq.
64704 NMES=MSTU(121)
64705 CALL PYPTDI(1,PX3,PY3)
64706 X=1D0
64707 POPM=0D0
64708 G=GB
64709 POPG=GB
64710
64711C.. Pick next popcorn meson, test with fake dynamical variables
64712 110 KFPREV=-KFL3
64713 PX1=-PX3
64714 PY1=-PY3
64715 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64716 IF(MSTU(121).EQ.-1) GOTO 100
64717 CALL PYPTDI(KFL3,PX3,PY3)
64718 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
64719 CALL PYZDIS(KFPREV,KFL3,PM,Z)
64720 G=(1D0-Z)*(G+PM/Z)
64721 X=(1D0-Z)*X
64722
64723 PTST=1D0
64724 GTST=1D0
64725 RTST=PYR(0)
64726 IF(MSTJ(12).GT.4)THEN
64727 POPMN=SQRT((1D0-X)*(G/X-GB))
64728 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64729 PTST=EXP((POPM-POPMN)*PARF(193))
64730 POPM=POPMN
64731 ENDIF
64732 IF(IRANK.NE.0)THEN
64733 POPGN=X*GB
64734 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
64735 POPG=POPGN
64736 ENDIF
64737 IF(RTST.GT.PTST*GTST)THEN
64738 MSTU(121)=0
64739 IF(RTST.GT.PTST) MSTU(121)=-1
64740 GOTO 100
64741 ENDIF
64742
64743C.. Store meson
64744 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
64745 IF(MSTU(121).GT.0) GOTO 110
64746
64747C.. Test accepted system size. If OK set global popcorn size variable.
64748 IF(NMES.GT.NMAX)THEN
64749 KF=0
64750 KFL3=0
64751 RETURN
64752 ENDIF
64753 MSTU(121)=NMES
64754 ENDIF
64755
64756 RETURN
64757 END
64758
64759C********************************************************************
64760
64761C...PYKFDI
64762C...Generates a new flavour pair and combines off a hadron
64763
64764 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
64765
64766C...Double precision and integer declarations.
64767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64768 IMPLICIT INTEGER(I-N)
64769 INTEGER PYK,PYCHGE,PYCOMP
64770C...Commonblocks.
64771 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64772 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64773 SAVE /PYDAT1/,/PYDAT2/
64774C...Local arrays.
64775 DIMENSION PD(7)
64776
64777 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
64778
64779C...Default flavour values. Input consistency checks.
64780 KF1A=IABS(KFL1)
64781 KF2A=IABS(KFL2)
64782 KFL3=0
64783 KF=0
64784 IF(KF1A.EQ.0) RETURN
64785 IF(KF2A.NE.0)THEN
64786 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
64787 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
64788 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
64789 ENDIF
64790
64791C...Check if tabulated flavour probabilities are to be used.
64792 IF(MSTJ(15).EQ.1) THEN
64793 IF(MSTJ(12).GE.5) CALL PYERRM(29,
64794 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
64795 & ' together with MSTJ(12)>=5 modification')
64796 KTAB1=-1
64797 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
64798 KFL1A=MOD(KF1A/1000,10)
64799 KFL1B=MOD(KF1A/100,10)
64800 KFL1S=MOD(KF1A,10)
64801 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
64802 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
64803 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
64804 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
64805 KTAB2=0
64806 IF(KF2A.NE.0) THEN
64807 KTAB2=-1
64808 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
64809 KFL2A=MOD(KF2A/1000,10)
64810 KFL2B=MOD(KF2A/100,10)
64811 KFL2S=MOD(KF2A,10)
64812 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
64813 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
64814 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
64815 ENDIF
64816 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
64817 ENDIF
64818
64819C.. Recognize rank 0 diquark case
64820 100 IRANK=1
64821 KFDIQ=MAX(KF1A,KF2A)
64822 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
64823
64824C.. Join two flavours to meson or baryon. Test for popcorn.
64825 IF(KF2A.GT.0)THEN
64826 MBARY=0
64827 IF(KFDIQ.GT.10) THEN
64828 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
64829 & CALL PYNMES(KFDIQ)
64830 IF(MSTU(121).NE.0) THEN
64831 MSTU(121)=0
64832 RETURN
64833 ENDIF
64834 MBARY=2
64835 ENDIF
64836 KFQOLD=KF1A
64837 KFQVER=KF2A
64838 GOTO 130
64839 ENDIF
64840
64841C.. Separate incoming flavours, curtain flavour consistency check
64842 KFIN=KFL1
64843 KFQOLD=KF1A
64844 KFQPOP=KF1A/10000
64845 IF(KF1A.GT.10)THEN
64846 KFIN=-KFL1
64847 KFL1A=MOD(KF1A/1000,10)
64848 KFL1B=MOD(KF1A/100,10)
64849 IF(IRANK.EQ.0)THEN
64850 QAWT=1D0
64851 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
64852 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
64853 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
64854 ENDIF
64855 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
64856 MSTU(121)=0
64857 RETURN
64858 ENDIF
64859 KFQOLD=KFL1A+KFL1B-KFQPOP
64860 ENDIF
64861
64862C...Meson/baryon choice. Set number of mesons if starting a popcorn
64863C...system.
64864 110 MBARY=0
64865 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
64866 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
64867 MBARY=1
64868 CALL PYNMES(0)
64869 ENDIF
64870 ELSEIF(KF1A.GT.10)THEN
64871 MBARY=2
64872 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
64873 IF(MSTU(121).GT.0) MBARY=-1
64874 ENDIF
64875
64876C..x->H+q: Choose single vertex quark. Jump to form hadron.
64877 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
64878 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
64879 KFL3=ISIGN(KFQVER,-KFIN)
64880 GOTO 130
64881 ENDIF
64882
64883C..x->H+qq: (IDW=proper PARF position for diquark weights)
64884 IDW=160
64885 IF(MBARY.EQ.1)THEN
64886 IF(MSTU(121).EQ.0) IDW=150
64887 SQWT=PARF(IDW+1)
64888 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
64889 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
64890C.. Shift to s-curtain parameters if needed
64891 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
64892 PARF(194)=PARF(138)*PARF(139)
64893 PARF(193)=PARJ(8)+PARJ(9)
64894 ENDIF
64895 ENDIF
64896
64897C.. x->H+qq: Get vertex quark
64898 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64899 IDW=MSTU(122)
64900 MSTU(121)=MSTU(121)-1
64901 IF(IDW.EQ.170) THEN
64902 IF(MSTU(121).EQ.0)THEN
64903 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
64904 ELSE
64905 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
64906 ENDIF
64907 ELSE
64908 IF(MSTU(121).EQ.0)THEN
64909 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
64910 ELSE
64911 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
64912 ENDIF
64913 ENDIF
64914 IPOS=200+30*IPOS+1
64915
64916 IMES=-1
64917 RMES=PYR(0)*PARF(194)
64918 120 IMES=IMES+1
64919 RMES=RMES-PARF(IPOS+IMES)
64920 IF(IMES.EQ.30) THEN
64921 MSTU(121)=-1
64922 KF=-111
64923 RETURN
64924 ENDIF
64925 IF(RMES.GT.0D0) GOTO 120
64926 KMUL=IMES/5
64927 KFJ=2*KMUL+1
64928 IF(KMUL.EQ.2) KFJ=10003
64929 IF(KMUL.EQ.3) KFJ=10001
64930 IF(KMUL.EQ.4) KFJ=20003
64931 IF(KMUL.EQ.5) KFJ=5
64932 IDIAG=0
64933 KFQVER=MOD(IMES,5)+1
64934 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
64935 IF(KFQVER.GT.3)THEN
64936 IDIAG=KFQVER-3
64937 KFQVER=KFQOLD
64938 ENDIF
64939 ELSE
64940 IF(MBARY.EQ.-1) IDW=170
64941 SQWT=PARF(IDW+2)
64942 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
64943 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
64944 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
64945 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
64946 KFQVER=KFQPOP
64947 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
64948 ENDIF
64949 ENDIF
64950
64951C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
64952 KFLDS=3
64953 IF(KFQPOP.NE.KFQVER)THEN
64954 SWT=PARF(IDW+7)
64955 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
64956 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
64957 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
64958 ENDIF
64959 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
64960 & +10000*KFQPOP
64961 KFL3=ISIGN(KFDIQ,KFIN)
64962
64963C..x->M+y: flavour for meson.
64964 130 IF(MBARY.LE.0)THEN
64965 KFLA=MAX(KFQOLD,KFQVER)
64966 KFLB=MIN(KFQOLD,KFQVER)
64967 KFS=ISIGN(1,KFL1)
64968 IF(KFLA.NE.KFQOLD) KFS=-KFS
64969C... Form meson, with spin and flavour mixing for diagonal states.
64970 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64971 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
64972 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
64973 RETURN
64974 ENDIF
64975 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
64976 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
64977 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
64978 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
64979 IF(PYR(0).LT.PARJ(14)) KMUL=2
64980 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
64981 RMUL=PYR(0)
64982 IF(RMUL.LT.PARJ(15)) KMUL=3
64983 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
64984 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
64985 ENDIF
64986 KFLS=3
64987 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
64988 IF(KMUL.EQ.5) KFLS=5
64989 IF(KFLA.NE.KFLB)THEN
64990 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
64991 ELSE
64992 RMIX=PYR(0)
64993 IMIX=2*KFLA+10*KMUL
64994 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
64995 & INT(RMIX+PARF(IMIX)))+KFLS
64996 IF(KFLA.GE.4) KF=110*KFLA+KFLS
64997 ENDIF
64998 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
64999 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
65000
65001C..Optional extra suppression of eta and eta'.
65002C..Allow shift to qq->B+q in old version (set IRANK to 0)
65003 IF(KF.EQ.221.OR.KF.EQ.331)THEN
65004 IF(PYR(0).GT.PARJ(25+KF/300))THEN
65005 IF(KF2A.GT.0) GOTO 130
65006 IF(MSTJ(12).LT.4) IRANK=0
65007 GOTO 110
65008 ENDIF
65009 ENDIF
65010 MSTU(121)=0
65011
65012C.. x->B+y: Flavour for baryon
65013 ELSE
65014 KFLA=KFQVER
65015 IF(KF1A.LE.10) KFLA=KFQOLD
65016 KFLB=MOD(KFDIQ/1000,10)
65017 KFLC=MOD(KFDIQ/100,10)
65018 KFLDS=MOD(KFDIQ,10)
65019 KFLD=MAX(KFLA,KFLB,KFLC)
65020 KFLF=MIN(KFLA,KFLB,KFLC)
65021 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65022
65023C... SU(6) factors for formation of baryon.
65024 KBARY=3
65025 KDMAX=5
65026 KFLG=KFLB
65027 IF(KFLB.NE.KFLC)THEN
65028 KBARY=2*KFLDS-1
65029 KDMAX=1+KFLDS/2
65030 IF(KFLB.GT.2) KDMAX=KDMAX+2
65031 ENDIF
65032 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
65033 KBARY=KBARY+1
65034 KFLG=KFLA
65035 ENDIF
65036
65037 SU6MAX=PARF(140+KDMAX)
65038 SU6DEC=PARJ(18)
65039 SU6S =PARF(146)
65040 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
65041 SU6MAX=1D0
65042 SU6DEC=1D0
65043 SU6S =1D0
65044 ENDIF
65045 SU6OCT=PARF(60+KBARY)
65046 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
65047 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
65048 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
65049 ELSE
65050 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
65051 ENDIF
65052 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
65053
65054C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
65055 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
65056 MSTU(121)=0
65057 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
65058 GOTO 110
65059 ENDIF
65060
65061C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
65062 KSIG=1
65063 KFLS=2
65064 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
65065 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
65066 KSIG=KFLDS/3
65067 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
65068 ENDIF
65069 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
65070 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
65071 ENDIF
65072 RETURN
65073
65074C...Use tabulated probabilities to select new flavour and hadron.
65075 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
65076 KT3L=1
65077 KT3U=6
65078 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
65079 KT3L=1
65080 KT3U=6
65081 ELSEIF(KTAB2.EQ.0) THEN
65082 KT3L=1
65083 KT3U=22
65084 ELSE
65085 KT3L=KTAB2
65086 KT3U=KTAB2
65087 ENDIF
65088 RFL=0D0
65089 DO 160 KTS=0,2
65090 DO 150 KT3=KT3L,KT3U
65091 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
65092 150 CONTINUE
65093 160 CONTINUE
65094 RFL=PYR(0)*RFL
65095 DO 180 KTS=0,2
65096 KTABS=KTS
65097 DO 170 KT3=KT3L,KT3U
65098 KTAB3=KT3
65099 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
65100 IF(RFL.LE.0D0) GOTO 190
65101 170 CONTINUE
65102 180 CONTINUE
65103 190 CONTINUE
65104
65105C...Reconstruct flavour of produced quark/diquark.
65106 IF(KTAB3.LE.6) THEN
65107 KFL3A=KTAB3
65108 KFL3B=0
65109 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
65110 ELSE
65111 KFL3A=1
65112 IF(KTAB3.GE.8) KFL3A=2
65113 IF(KTAB3.GE.11) KFL3A=3
65114 IF(KTAB3.GE.16) KFL3A=4
65115 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
65116 KFL3=1000*KFL3A+100*KFL3B+1
65117 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
65118 & KFL3+2
65119 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
65120 ENDIF
65121
65122C...Reconstruct meson code.
65123 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
65124 &KFL3B.NE.0)) THEN
65125 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65126 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
65127 KF=110+2*KTABS+1
65128 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
65129 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65130 & 25*KTABS)) KF=330+2*KTABS+1
65131 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
65132 KFLA=MAX(KTAB1,KTAB3)
65133 KFLB=MIN(KTAB1,KTAB3)
65134 KFS=ISIGN(1,KFL1)
65135 IF(KFLA.NE.KF1A) KFS=-KFS
65136 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65137 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
65138 KFS=ISIGN(1,KFL1)
65139 IF(KFL1A.EQ.KFL3A) THEN
65140 KFLA=MAX(KFL1B,KFL3B)
65141 KFLB=MIN(KFL1B,KFL3B)
65142 IF(KFLA.NE.KFL1B) KFS=-KFS
65143 ELSEIF(KFL1A.EQ.KFL3B) THEN
65144 KFLA=KFL3A
65145 KFLB=KFL1B
65146 KFS=-KFS
65147 ELSEIF(KFL1B.EQ.KFL3A) THEN
65148 KFLA=KFL1A
65149 KFLB=KFL3B
65150 ELSEIF(KFL1B.EQ.KFL3B) THEN
65151 KFLA=MAX(KFL1A,KFL3A)
65152 KFLB=MIN(KFL1A,KFL3A)
65153 IF(KFLA.NE.KFL1A) KFS=-KFS
65154 ELSE
65155 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
65156 GOTO 100
65157 ENDIF
65158 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65159
65160C...Reconstruct baryon code.
65161 ELSE
65162 IF(KTAB1.GE.7) THEN
65163 KFLA=KFL3A
65164 KFLB=KFL1A
65165 KFLC=KFL1B
65166 ELSE
65167 KFLA=KFL1A
65168 KFLB=KFL3A
65169 KFLC=KFL3B
65170 ENDIF
65171 KFLD=MAX(KFLA,KFLB,KFLC)
65172 KFLF=MIN(KFLA,KFLB,KFLC)
65173 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65174 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
65175 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
65176 ENDIF
65177
65178C...Check that constructed flavour code is an allowed one.
65179 IF(KFL2.NE.0) KFL3=0
65180 KC=PYCOMP(KF)
65181 IF(KC.EQ.0) THEN
65182 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
65183 & 'failed')
65184 GOTO 100
65185 ENDIF
65186
65187 RETURN
65188 END
65189
65190C*********************************************************************
65191
65192C...PYNMES
65193C...Generates number of popcorn mesons and stores some relevant
65194C...parameters.
65195
65196 SUBROUTINE PYNMES(KFDIQ)
65197
65198C...Double precision and integer declarations.
65199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65200 IMPLICIT INTEGER(I-N)
65201 INTEGER PYK,PYCHGE,PYCOMP
65202C...Commonblocks.
65203 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65204 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65205 SAVE /PYDAT1/,/PYDAT2/
65206
65207 MSTU(121)=0
65208 IF(MSTJ(12).LT.2) RETURN
65209
65210C..Old version: Get 1 or 0 popcorn mesons
65211 IF(MSTJ(12).LT.5)THEN
65212 POPWT=PARF(131)
65213 IF(KFDIQ.NE.0) THEN
65214 KFDIQA=IABS(KFDIQ)
65215 KFA=MOD(KFDIQA/1000,10)
65216 KFB=MOD(KFDIQA/100,10)
65217 KFS=MOD(KFDIQA,10)
65218 POPWT=PARF(132)
65219 IF(KFA.EQ.3) POPWT=PARF(133)
65220 IF(KFB.EQ.3) POPWT=PARF(134)
65221 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
65222 ENDIF
65223 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
65224 RETURN
65225 ENDIF
65226
65227C..New version: Store popcorn- or rank 0 diquark parameters
65228 MSTU(122)=170
65229 PARF(193)=PARJ(8)
65230 PARF(194)=PARF(139)
65231 IF(KFDIQ.NE.0) THEN
65232 MSTU(122)=180
65233 PARF(193)=PARJ(10)
65234 PARF(194)=PARF(140)
65235 ENDIF
65236 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
65237 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
65238 & '(PYNMES:) Neglecting too large popcorn possibility')
65239 RETURN
65240 ENDIF
65241
65242C..New version: Get number of popcorn mesons
65243 100 RTST=PYR(0)
65244 MSTU(121)=-1
65245 110 MSTU(121)=MSTU(121)+1
65246 RTST=RTST/PARF(194)
65247 IF(RTST.LT.1D0) GOTO 110
65248 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
65249 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
65250 RETURN
65251 END
65252
65253C***************************************************************
65254
65255C...PYKFIN
65256C...Precalculates a set of diquark and popcorn weights.
65257
65258 SUBROUTINE PYKFIN
65259
65260C...Double precision and integer declarations.
65261 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65262 IMPLICIT INTEGER(I-N)
65263 INTEGER PYK,PYCHGE,PYCOMP
65264C...Commonblocks.
65265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65267 SAVE /PYDAT1/,/PYDAT2/
65268
65269 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
65270
65271
65272 MSTU(123)=1
65273C..Diquark indices for dimensional variables
65274 IUD1=1
65275 IUU1=2
65276 IUS0=3
65277 ISU0=4
65278 IUS1=5
65279 ISU1=6
65280 ISS1=7
65281
65282C.. *** SU(6) factors **
65283C..Modify with decuplet- (and Sigma/Lambda-) suppression.
65284 PARF(146)=1D0
65285 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
65286 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
65287 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
65288 DO 100 I=1,6
65289 SU6(I)=PARF(60+I)
65290 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
65291 100 CONTINUE
65292 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
65293 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
65294 DO 110 I=1,6
65295 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
65296 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
65297 110 CONTINUE
65298
65299C..SU(6)max q q' s,c,b
65300 SU6MUD =MAX(SU6(1) , SU6(8) )
65301 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
65302 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
65303 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
65304 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
65305 SU6M(IUS0)=SU6M(ISU0)
65306 SU6M(ISS1)=SU6M(IUU1)
65307 SU6M(IUS1)=SU6M(ISU1)
65308
65309C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
65310 PARF(141)=SU6MUD
65311 PARF(142)=SU6M(IUD1)
65312 PARF(143)=SU6M(ISU0)
65313 PARF(144)=SU6M(ISU1)
65314 PARF(145)=SU6M(ISS1)
65315
65316C..diquark SU(6) survival =
65317C..sum over quark (quark tunnel weight)*(SU(6)).
65318 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
65319 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
65320 DMB(IUS0)=DMB(ISU0)
65321 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
65322 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
65323 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
65324 DMB(IUS1)=DMB(ISU1)
65325 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
65326
65327C.. *** Tunneling factors for Diquark production***
65328C.. T: half a curtain pair = sqrt(curtain pair factor)
65329 IF(MSTJ(12).GE.5) THEN
65330 PMUD0=PYMASS(2101)
65331 PMUD1=PYMASS(2103)-PMUD0
65332 PMUS0=PYMASS(3201)-PMUD0
65333 PMUS1=PYMASS(3203)-PMUS0-PMUD0
65334 PMSS1=PYMASS(3303)-PMUS0-PMUD0
65335 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
65336 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
65337 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
65338 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
65339 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
65340 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
65341 QBB(IUD1)=QBB(IUU1)
65342 ELSE
65343 PAR2M=SQRT(PARJ(2))
65344 PAR3M=SQRT(PARJ(3))
65345 PAR4M=SQRT(PARJ(4))
65346 QBB(ISU0)=PAR2M*PAR3M
65347 QBB(IUS0)=PAR3M
65348 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
65349 QBB(IUU1)=PAR4M
65350 QBB(ISU1)=PAR4M*QBB(ISU0)
65351 QBB(IUS1)=PAR4M*QBB(IUS0)
65352 QBB(IUD1)=PAR4M
65353 ENDIF
65354
65355C.. tau: spin*(vertex factor)*(T = half-curtain factor)
65356 QBM(ISU0)=QBB(ISU0)
65357 QBM(IUS0)=PARJ(2)*QBB(IUS0)
65358 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
65359 QBM(IUU1)=6D0*QBB(IUU1)
65360 QBM(ISU1)=3D0*QBB(ISU1)
65361 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
65362 QBM(IUD1)=3D0*QBB(IUD1)
65363
65364C.. Combine T and tau to diquark weight for q-> B+B+..
65365 DO 120 I=1,7
65366 QBB(I)=QBB(I)*QBM(I)
65367 120 CONTINUE
65368
65369 IF(MSTJ(12).GE.5)THEN
65370C..New version: tau for rank 0 diquark.
65371 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
65372 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
65373 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
65374 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
65375 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
65376 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
65377 DMB(7+IUD1)=DMB(7+IUU1)/2D0
65378
65379C..New version: curtain flavour ratios.
65380C.. s/u for q->B+M+...
65381C.. s/u for rank 0 diquark: su -> ...M+B+...
65382C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65383 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65384 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65385 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
65386 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
65387 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
65388 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
65389 ELSE
65390C..Old version: reset unused rank 0 diquark weights and
65391C.. unused diquark SU(6) survival weights
65392 DO 130 I=1,7
65393 IF(MSTJ(12).LT.3) DMB(I)=1D0
65394 DMB(7+I)=1D0
65395 130 CONTINUE
65396
65397C..Old version: Shuffle PARJ(7) into tau
65398 QBM(IUS0)=QBM(IUS0)*PARJ(7)
65399 QBM(ISS1)=QBM(ISS1)*PARJ(7)
65400 QBM(IUS1)=QBM(IUS1)*PARJ(7)
65401
65402C..Old version: curtain flavour ratios.
65403C.. s/u for q->B+M+...
65404C.. s/u for rank 0 diquark: su -> ...M+B+...
65405C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65406 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65407 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65408 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
65409 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
65410 ENDIF
65411
65412C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
65413C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
65414 DO 140 I=1,7
65415 DMB(7+I)=DMB(7+I)*DMB(I)
65416 DMB(I)=DMB(I)*QBM(I)
65417 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
65418 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
65419 140 CONTINUE
65420
65421C.. *** Popcorn factors ***
65422
65423 IF(MSTJ(12).LT.5)THEN
65424C.. Old version: Resulting popcorn weights.
65425 PARF(138)=PARJ(6)
65426 WS=PARF(135)*PARF(138)
65427 WQ=WU*PARJ(5)/3D0
65428 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
65429 PARF(133)=WQ*
65430 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
65431 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
65432 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
65433 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
65434 & (1D0+QBB(IUD1)+QBB(IUU1)+
65435 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
65436 ELSE
65437C..New version: Store weights for popcorn mesons,
65438C..get prel. popcorn weights.
65439 DO 150 IPOS=201,1400
65440 PARF(IPOS)=0D0
65441 150 CONTINUE
65442 DO 160 I=138,140
65443 PARF(I)=0D0
65444 160 CONTINUE
65445 IPOS=200
65446 PARF(193)=PARJ(8)
65447 DO 240 MR=0,7,7
65448 IF(MR.EQ.7) PARF(193)=PARJ(10)
65449 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
65450 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65451 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65452 DO 230 NMES=0,1
65453 IF(NMES.EQ.1) SQWT=PARJ(2)
65454 DO 220 KFQPOP=1,4
65455 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
65456 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
65457 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
65458 QQWT=0.5D0
65459 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
65460 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
65461 ENDIF
65462 DO 210 KFQOLD =1,5
65463 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
65464 IF(NMES.EQ.1) THEN
65465 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
65466 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
65467 ENDIF
65468 WTTOT=0D0
65469 WTFAIL=0D0
65470 DO 190 KMUL=0,5
65471 PJWT=PARJ(12+KMUL)
65472 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
65473 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
65474 IF(PJWT.LE.0D0) GOTO 190
65475 IF(PJWT.GT.1D0) PJWT=1D0
65476 IMES=5*KMUL
65477 IMIX=2*KFQOLD+10*KMUL
65478 KFJ=2*KMUL+1
65479 IF(KMUL.EQ.2) KFJ=10003
65480 IF(KMUL.EQ.3) KFJ=10001
65481 IF(KMUL.EQ.4) KFJ=20003
65482 IF(KMUL.EQ.5) KFJ=5
65483 DO 180 KFQVER =1,3
65484 KFLA=MAX(KFQOLD,KFQVER)
65485 KFLB=MIN(KFQOLD,KFQVER)
65486 SWT=PARJ(11+KFLA/3+KFLA/4)
65487 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
65488 SWT=SWT*PJWT
65489 QWT=SQWT/(2D0+SQWT)
65490 IF(KFQVER.LT.3)THEN
65491 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
65492 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
65493 ENDIF
65494 IF(KFQVER.NE.KFQOLD)THEN
65495 IMES=IMES+1
65496 KFM=100*KFLA+10*KFLB+KFJ
65497 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65498 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
65499 WTTOT=WTTOT+PARF(IPOS+IMES)
65500 ELSE
65501 DO 170 ID=3,5
65502 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
65503 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
65504 IF(ID.EQ.5) DWT=PARF(IMIX)
65505 KFM=110*(ID-2)+KFJ
65506 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65507 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
65508 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
65509 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
65510 PARF(IPOS+5*KMUL+ID)=
65511 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
65512 ENDIF
65513 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
65514 170 CONTINUE
65515 ENDIF
65516 180 CONTINUE
65517 190 CONTINUE
65518 DO 200 IMES=1,30
65519 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
65520 200 CONTINUE
65521 IF(MR.EQ.7) PARF(140)=
65522 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
65523 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
65524 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
65525 IPOS=IPOS+30
65526 210 CONTINUE
65527 220 CONTINUE
65528 230 CONTINUE
65529 240 CONTINUE
65530 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
65531 MSTU(121)=0
65532
65533 ENDIF
65534
65535C..Recombine diquark weights to flavour and spin ratios
65536 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
65537 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
65538 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
65539 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
65540 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
65541 PARF(155)=QBB(ISU1)/QBB(ISU0)
65542 PARF(156)=QBB(IUS1)/QBB(IUS0)
65543 PARF(157)=QBB(IUD1)
65544
65545 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
65546 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
65547 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
65548 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
65549 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
65550 PARF(165)=QBM(ISU1)/QBM(ISU0)
65551 PARF(166)=QBM(IUS1)/QBM(IUS0)
65552 PARF(167)=QBM(IUD1)
65553
65554 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
65555 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
65556 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
65557 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
65558 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
65559 PARF(175)=DMB(ISU1)/DMB(ISU0)
65560 PARF(176)=DMB(IUS1)/DMB(IUS0)
65561 PARF(177)=DMB(IUD1)
65562
65563 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
65564 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
65565 PARF(187)=DMB(7+IUD1)
65566
65567 RETURN
65568 END
65569
65570
65571C*********************************************************************
65572
65573C...PYPTDI
65574C...Generates transverse momentum according to a Gaussian.
65575
65576 SUBROUTINE PYPTDI(KFL,PX,PY)
65577
65578C...Double precision and integer declarations.
65579 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65580 IMPLICIT INTEGER(I-N)
65581 INTEGER PYK,PYCHGE,PYCOMP
65582C...Commonblocks.
65583 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65584 SAVE /PYDAT1/
65585
65586C...Generate p_T and azimuthal angle, gives p_x and p_y.
65587 KFLA=IABS(KFL)
65588 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
65589 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
65590 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
65591 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
65592 PHI=PARU(2)*PYR(0)
65593 PX=PT*COS(PHI)
65594 PY=PT*SIN(PHI)
65595
65596 RETURN
65597 END
65598
65599C*********************************************************************
65600
65601C...PYZDIS
65602C...Generates the longitudinal splitting variable z.
65603
65604 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
65605
65606C...Double precision and integer declarations.
65607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65608 IMPLICIT INTEGER(I-N)
65609 INTEGER PYK,PYCHGE,PYCOMP
65610C...Commonblocks.
65611 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65612 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65613 SAVE /PYDAT1/,/PYDAT2/
65614
65615C...Check if heavy flavour fragmentation.
65616 KFLA=IABS(KFL1)
65617 KFLB=IABS(KFL2)
65618 KFLH=KFLA
65619 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
65620
65621C...Lund symmetric scaling function: determine parameters of shape.
65622 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
65623 &MSTJ(11).GE.4) THEN
65624 FA=PARJ(41)
65625 IF(MSTJ(91).EQ.1) FA=PARJ(43)
65626 IF(KFLB.GE.10) FA=FA+PARJ(45)
65627 FBB=PARJ(42)
65628 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
65629 FB=FBB*PR
65630 FC=1D0
65631 IF(KFLA.GE.10) FC=FC-PARJ(45)
65632 IF(KFLB.GE.10) FC=FC+PARJ(45)
65633 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
65634 FRED=PARJ(46)
65635 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
65636 FC=FC+FRED*FBB*PARF(100+KFLH)**2
65637 ENDIF
65638 MC=1
65639 IF(ABS(FC-1D0).GT.0.01D0) MC=2
65640
65641C...Determine position of maximum. Special cases for a = 0 or a = c.
65642 IF(FA.LT.0.02D0) THEN
65643 MA=1
65644 ZMAX=1D0
65645 IF(FC.GT.FB) ZMAX=FB/FC
65646 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
65647 MA=2
65648 ZMAX=FB/(FB+FC)
65649 ELSE
65650 MA=3
65651 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
65652 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
65653 ENDIF
65654
65655C...Subdivide z range if distribution very peaked near endpoint.
65656 MMAX=2
65657 IF(ZMAX.LT.0.1D0) THEN
65658 MMAX=1
65659 ZDIV=2.75D0*ZMAX
65660 IF(MC.EQ.1) THEN
65661 FINT=1D0-LOG(ZDIV)
65662 ELSE
65663 ZDIVC=ZDIV**(1D0-FC)
65664 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
65665 ENDIF
65666 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
65667 MMAX=3
65668 FSCB=SQRT(4D0+(FC/FB)**2)
65669 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
65670 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
65671 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
65672 FINT=1D0+FB*(1D0-ZDIV)
65673 ENDIF
65674
65675C...Choice of z, preweighted for peaks at low or high z.
65676 100 Z=PYR(0)
65677 FPRE=1D0
65678 IF(MMAX.EQ.1) THEN
65679 IF(FINT*PYR(0).LE.1D0) THEN
65680 Z=ZDIV*Z
65681 ELSEIF(MC.EQ.1) THEN
65682 Z=ZDIV**Z
65683 FPRE=ZDIV/Z
65684 ELSE
65685 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
65686 FPRE=(ZDIV/Z)**FC
65687 ENDIF
65688 ELSEIF(MMAX.EQ.3) THEN
65689 IF(FINT*PYR(0).LE.1D0) THEN
65690 Z=ZDIV+LOG(Z)/FB
65691 FPRE=EXP(FB*(Z-ZDIV))
65692 ELSE
65693 Z=ZDIV+Z*(1D0-ZDIV)
65694 ENDIF
65695 ENDIF
65696
65697C...Weighting according to correct formula.
65698 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
65699 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
65700 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
65701 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
65702 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
65703
65704C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
65705 ELSE
65706 FC=PARJ(50+MAX(1,KFLH))
65707 IF(MSTJ(91).EQ.1) FC=PARJ(59)
65708 110 Z=PYR(0)
65709 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
65710 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
65711 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
65712 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
65713 & GOTO 110
65714 ELSE
65715 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
65716 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
65717 ENDIF
65718 ENDIF
65719
65720 RETURN
65721 END
65722
65723C*********************************************************************
65724
65725C...PYSHOW
65726C...Generates timelike parton showers from given partons.
65727
65728 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
65729
65730C...Double precision and integer declarations.
65731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65732 IMPLICIT INTEGER(I-N)
65733 INTEGER PYK,PYCHGE,PYCOMP
65734C...Parameter statement to help give large particle numbers.
65735 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65736 &KEXCIT=4000000,KDIMEN=5000000)
65737 PARAMETER (MAXNUR=1000)
65738C...Commonblocks.
65739 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65742 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65743 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65744 COMMON/PYINT1/MINT(400),VINT(400)
65745 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
65746C...Local arrays.
65747 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
65748 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
65749 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
65750 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
65751 &IREF(1000)
65752
65753C...Check that QMAX not too low.
65754 IF(MSTJ(41).LE.0) THEN
65755 RETURN
65756 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
65757 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
65758 ELSE
65759 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
65760 & RETURN
65761 ENDIF
65762
65763C...Store positions of shower initiating partons.
65764 MPSPD=0
65765 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
65766 NPA=1
65767 IPA(1)=IP1
65768 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
65769 & MSTU(32))) THEN
65770 NPA=2
65771 IPA(1)=IP1
65772 IPA(2)=IP2
65773 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
65774 & .AND.IP2.GE.-80) THEN
65775 NPA=IABS(IP2)
65776 DO 100 I=1,NPA
65777 IPA(I)=IP1+I-1
65778 100 CONTINUE
65779 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
65780 &IP2.EQ.-100) THEN
65781 MPSPD=1
65782 NPA=2
65783 IPA(1)=IP1+6
65784 IPA(2)=IP1+7
65785 ELSE
65786 CALL PYERRM(12,
65787 & '(PYSHOW:) failed to reconstruct showering system')
65788 IF(MSTU(21).GE.1) RETURN
65789 ENDIF
65790
65791C...Send off to PYPTFS for pT-ordered evolution if requested,
65792C...if at least 2 partons, and without predefined shower branchings.
65793 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
65794 &MPSPD.EQ.0) THEN
65795 NPART=NPA
65796 DO 110 II=1,NPART
65797 IPART(II)=IPA(II)
65798 PTPART(II)=0.5D0*QMAX
65799 110 CONTINUE
65800 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
65801 RETURN
65802 ENDIF
65803
65804C...Initialization of cutoff masses etc.
65805 DO 120 IFL=0,40
65806 ISCOL(IFL)=0
65807 ISCHG(IFL)=0
65808 KSH(IFL)=0
65809 120 CONTINUE
65810 ISCOL(21)=1
65811 KSH(21)=1
65812 PMTH(1,21)=PYMASS(21)
65813 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
65814 PMTH(3,21)=2D0*PMTH(2,21)
65815 PMTH(4,21)=PMTH(3,21)
65816 PMTH(5,21)=PMTH(3,21)
65817 PMTH(1,22)=PYMASS(22)
65818 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
65819 PMTH(3,22)=2D0*PMTH(2,22)
65820 PMTH(4,22)=PMTH(3,22)
65821 PMTH(5,22)=PMTH(3,22)
65822 PMQTH1=PARJ(82)
65823 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
65824 PMQT1E=MIN(PMQTH1,PARJ(90))
65825 PMQTH2=PMTH(2,21)
65826 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
65827 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
65828 DO 130 IFL=1,5
65829 ISCOL(IFL)=1
65830 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
65831 KSH(IFL)=1
65832 PMTH(1,IFL)=PYMASS(IFL)
65833 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
65834 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
65835 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65836 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65837 130 CONTINUE
65838 DO 140 IFL=11,15,2
65839 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
65840 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
65841 PMTH(1,IFL)=PYMASS(IFL)
65842 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
65843 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
65844 PMTH(4,IFL)=PMTH(3,IFL)
65845 PMTH(5,IFL)=PMTH(3,IFL)
65846 140 CONTINUE
65847 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
65848 ALAMS=PARJ(81)**2
65849 ALFM=LOG(PT2MIN/ALAMS)
65850
65851C...Check on phase space available for emission.
65852 IREJ=0
65853 DO 150 J=1,5
65854 PS(J)=0D0
65855 150 CONTINUE
65856 PM=0D0
65857 KFLA(2)=0
65858 DO 170 I=1,NPA
65859 KFLA(I)=IABS(K(IPA(I),2))
65860 PMA(I)=P(IPA(I),5)
65861C...Special cutoff masses for initial partons (may be a heavy quark,
65862C...squark, ..., and need not be on the mass shell).
65863 IR=30+I
65864 IF(NPA.LE.1) IREF(I)=IR
65865 IF(NPA.GE.2) IREF(I+1)=IR
65866 ISCOL(IR)=0
65867 ISCHG(IR)=0
65868 KSH(IR)=0
65869 IF(KFLA(I).LE.8) THEN
65870 ISCOL(IR)=1
65871 IF(MSTJ(41).GE.2) ISCHG(IR)=1
65872 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
65873 & KFLA(I).EQ.17) THEN
65874 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
65875 ELSEIF(KFLA(I).EQ.21) THEN
65876 ISCOL(IR)=1
65877 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
65878 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
65879 ISCOL(IR)=1
65880 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
65881 ISCOL(IR)=1
65882C...QUARKONIA+++
65883C...same for QQ~[3S18]
65884 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
65885 & KFLA(I).EQ.9900553)) THEN
65886 ISCOL(IR)=1
65887C...QUARKONIA---
65888 ENDIF
65889 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
65890 PMTH(1,IR)=PMA(I)
65891 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
65892 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
65893 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
65894 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65895 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65896 ELSEIF(ISCOL(IR).EQ.1) THEN
65897 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
65898 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
65899 PMTH(4,IR)=PMTH(3,IR)
65900 PMTH(5,IR)=PMTH(3,IR)
65901 ELSEIF(ISCHG(IR).EQ.1) THEN
65902 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
65903 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
65904 PMTH(4,IR)=PMTH(3,IR)
65905 PMTH(5,IR)=PMTH(3,IR)
65906 ENDIF
65907 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
65908 PM=PM+PMA(I)
65909 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
65910 DO 160 J=1,4
65911 PS(J)=PS(J)+P(IPA(I),J)
65912 160 CONTINUE
65913 170 CONTINUE
65914 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
65915 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
65916 IF(NPA.EQ.1) PS(5)=PS(4)
65917 IF(PS(5).LE.PM+PMQT1E) RETURN
65918
65919C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
65920 KFSRCE=0
65921 IF(IP2.LE.0) THEN
65922 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
65923 KFSRCE=IABS(K(K(IP1,3),2))
65924 ELSE
65925 IPAR1=MAX(1,K(IP1,3))
65926 IPAR2=MAX(1,K(IP2,3))
65927 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
65928 & KFSRCE=IABS(K(K(IPAR1,3),2))
65929 ENDIF
65930 ITYPES=0
65931 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
65932 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
65933 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
65934 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
65935 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
65936 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
65937 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
65938 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
65939
65940C...Identify two primary showerers.
65941 ITYPE1=0
65942 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
65943 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
65944 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
65945 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
65946 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
65947 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
65948 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
65949 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
65950 ITYPE2=0
65951 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
65952 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
65953 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
65954 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
65955 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
65956 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
65957 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
65958 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
65959
65960C...Order of showerers. Presence of gluino.
65961 ITYPMN=MIN(ITYPE1,ITYPE2)
65962 ITYPMX=MAX(ITYPE1,ITYPE2)
65963 IORD=1
65964 IF(ITYPE1.GT.ITYPE2) IORD=2
65965 IGLUI=0
65966 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
65967
65968C...Check if 3-jet matrix elements to be used.
65969 M3JC=0
65970 ALPHA=0.5D0
65971 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
65972 IF(MSTJ(38).NE.0) THEN
65973 M3JC=MSTJ(38)
65974 ALPHA=PARJ(80)
65975 MSTJ(38)=0
65976 ELSEIF(MSTJ(47).GE.6) THEN
65977 M3JC=MSTJ(47)
65978 ELSE
65979 ICLASS=1
65980 ICOMBI=4
65981
65982C...Vector/axial vector -> q + qbar; q -> q + V.
65983 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
65984 & ITYPES.EQ.3)) THEN
65985 ICLASS=2
65986 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
65987 ICOMBI=1
65988 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
65989 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
65990C...gamma*/Z0: assume e+e- initial state if unknown.
65991 EI=-1D0
65992 IF(KFSRCE.EQ.23) THEN
65993 IANNFL=K(K(IP1,3),3)
65994 IF(IANNFL.NE.0) THEN
65995 KANNFL=IABS(K(IANNFL,2))
65996 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
65997 ENDIF
65998 ENDIF
65999 AI=SIGN(1D0,EI+0.1D0)
66000 VI=AI-4D0*EI*PARU(102)
66001 EF=KCHG(KFLA(1),1)/3D0
66002 AF=SIGN(1D0,EF+0.1D0)
66003 VF=AF-4D0*EF*PARU(102)
66004 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66005 SH=PS(5)**2
66006 SQMZ=PMAS(23,1)**2
66007 SQWZ=PS(5)*PMAS(23,2)
66008 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66009 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66010 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66011 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66012 ICOMBI=3
66013 ALPHA=VECT/(VECT+AXIV)
66014 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66015 ICOMBI=4
66016 ENDIF
66017C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66018 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66019 ICLASS=2
66020 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66021 & ITYPES.EQ.1)) THEN
66022 ICLASS=3
66023
66024C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66025 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66026 ICLASS=4
66027 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66028 ICOMBI=1
66029 ELSEIF(KFSRCE.EQ.36) THEN
66030 ICOMBI=2
66031 ENDIF
66032 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66033 & ITYPES.EQ.1)) THEN
66034 ICLASS=5
66035
66036C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66037 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66038 & ITYPES.EQ.3)) THEN
66039 ICLASS=6
66040 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66041 & ITYPES.EQ.2)) THEN
66042 ICLASS=7
66043 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66044 ICLASS=8
66045 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66046 & ITYPES.EQ.2)) THEN
66047 ICLASS=9
66048
66049C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66050 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66051 & ITYPES.EQ.5)) THEN
66052 ICLASS=10
66053 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66054 & ITYPES.EQ.2)) THEN
66055 ICLASS=11
66056 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66057 & ITYPES.EQ.1)) THEN
66058 ICLASS=12
66059
66060C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66061 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66062 ICLASS=13
66063 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66064 & ITYPES.EQ.2)) THEN
66065 ICLASS=14
66066 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66067 & ITYPES.EQ.1)) THEN
66068 ICLASS=15
66069
66070C...g -> ~g + ~g (eikonal approximation).
66071 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66072 ICLASS=16
66073 ENDIF
66074 M3JC=5*ICLASS+ICOMBI
66075 ENDIF
66076 ENDIF
66077
66078C...Find if interference with initial state partons.
66079 MIIS=0
66080 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
66081 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
66082 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
66083 &MIIS=MSTJ(50)-3
66084 IF(MIIS.NE.0) THEN
66085 DO 190 I=1,2
66086 KCII(I)=0
66087 KCA=PYCOMP(KFLA(I))
66088 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
66089 NIIS(I)=0
66090 IF(KCII(I).NE.0) THEN
66091 DO 180 J=1,2
66092 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
66093 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
66094 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
66095 NIIS(I)=NIIS(I)+1
66096 IIIS(I,NIIS(I))=ICSI
66097 ENDIF
66098 180 CONTINUE
66099 ENDIF
66100 190 CONTINUE
66101 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
66102 ENDIF
66103
66104C...Boost interfering initial partons to rest frame
66105C...and reconstruct their polar and azimuthal angles.
66106 IF(MIIS.NE.0) THEN
66107 DO 210 I=1,2
66108 DO 200 J=1,5
66109 K(N+I,J)=K(IPA(I),J)
66110 P(N+I,J)=P(IPA(I),J)
66111 V(N+I,J)=0D0
66112 200 CONTINUE
66113 210 CONTINUE
66114 DO 230 I=3,2+NIIS(1)
66115 DO 220 J=1,5
66116 K(N+I,J)=K(IIIS(1,I-2),J)
66117 P(N+I,J)=P(IIIS(1,I-2),J)
66118 V(N+I,J)=0D0
66119 220 CONTINUE
66120 230 CONTINUE
66121 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66122 DO 240 J=1,5
66123 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
66124 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
66125 V(N+I,J)=0D0
66126 240 CONTINUE
66127 250 CONTINUE
66128 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
66129 & -PS(2)/PS(4),-PS(3)/PS(4))
66130 PHI=PYANGL(P(N+1,1),P(N+1,2))
66131 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
66132 THE=PYANGL(P(N+1,3),P(N+1,1))
66133 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
66134 DO 260 I=3,2+NIIS(1)
66135 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
66136 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
66137 260 CONTINUE
66138 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66139 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
66140 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
66141 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
66142 270 CONTINUE
66143 ENDIF
66144
66145C...Boost 3 or more partons to their rest frame.
66146 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
66147 &-PS(2)/PS(4),-PS(3)/PS(4))
66148
66149C...Define imagined single initiator of shower for parton system.
66150 NS=N
66151 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
66152 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66153 IF(MSTU(21).GE.1) RETURN
66154 ENDIF
66155 280 N=NS
66156 IF(NPA.GE.2) THEN
66157 K(N+1,1)=11
66158 K(N+1,2)=21
66159 K(N+1,3)=0
66160 K(N+1,4)=0
66161 K(N+1,5)=0
66162 P(N+1,1)=0D0
66163 P(N+1,2)=0D0
66164 P(N+1,3)=0D0
66165 P(N+1,4)=PS(5)
66166 P(N+1,5)=PS(5)
66167 V(N+1,5)=PS(5)**2
66168 N=N+1
66169 IREF(1)=21
66170 ENDIF
66171
66172C...Loop over partons that may branch.
66173 NEP=NPA
66174 IM=NS
66175 IF(NPA.EQ.1) IM=NS-1
66176 290 IM=IM+1
66177 IF(N.GT.NS) THEN
66178 IF(IM.GT.N) GOTO 600
66179 KFLM=IABS(K(IM,2))
66180 IR=IREF(IM-NS)
66181 IF(KSH(IR).EQ.0) GOTO 290
66182 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
66183 IGM=K(IM,3)
66184 ELSE
66185 IGM=-1
66186 ENDIF
66187 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
66188 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66189 IF(MSTU(21).GE.1) RETURN
66190 ENDIF
66191
66192C...Position of aunt (sister to branching parton).
66193C...Origin and flavour of daughters.
66194 IAU=0
66195 IF(IGM.GT.0) THEN
66196 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
66197 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
66198 ENDIF
66199 IF(IGM.GE.0) THEN
66200 K(IM,4)=N+1
66201 DO 300 I=1,NEP
66202 K(N+I,3)=IM
66203 300 CONTINUE
66204 ELSE
66205 K(N+1,3)=IPA(1)
66206 ENDIF
66207 IF(IGM.LE.0) THEN
66208 DO 310 I=1,NEP
66209 K(N+I,2)=K(IPA(I),2)
66210 310 CONTINUE
66211 ELSEIF(KFLM.NE.21) THEN
66212 K(N+1,2)=K(IM,2)
66213 K(N+2,2)=K(IM,5)
66214 IREF(N+1-NS)=IREF(IM-NS)
66215 IREF(N+2-NS)=IABS(K(N+2,2))
66216 ELSEIF(K(IM,5).EQ.21) THEN
66217 K(N+1,2)=21
66218 K(N+2,2)=21
66219 IREF(N+1-NS)=21
66220 IREF(N+2-NS)=21
66221 ELSE
66222 K(N+1,2)=K(IM,5)
66223 K(N+2,2)=-K(IM,5)
66224 IREF(N+1-NS)=IABS(K(N+1,2))
66225 IREF(N+2-NS)=IABS(K(N+2,2))
66226 ENDIF
66227
66228C...Reset flags on daughters and tries made.
66229 DO 320 IP=1,NEP
66230 K(N+IP,1)=3
66231 K(N+IP,4)=0
66232 K(N+IP,5)=0
66233 KFLD(IP)=IABS(K(N+IP,2))
66234 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
66235 ITRY(IP)=0
66236 ISL(IP)=0
66237 ISI(IP)=0
66238 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
66239 320 CONTINUE
66240 ISLM=0
66241
66242C...Maximum virtuality of daughters.
66243 IF(IGM.LE.0) THEN
66244 DO 330 I=1,NPA
66245 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
66246 P(N+I,5)=MIN(QMAX,PS(5))
66247 IR=IREF(N+I-NS)
66248 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
66249 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
66250 330 CONTINUE
66251 ELSE
66252 IF(MSTJ(43).LE.2) PEM=V(IM,2)
66253 IF(MSTJ(43).GE.3) PEM=P(IM,4)
66254 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
66255 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
66256 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
66257 ENDIF
66258 DO 340 I=1,NEP
66259 PMSD(I)=P(N+I,5)
66260 IF(ISI(I).EQ.1) THEN
66261 IR=IREF(N+I-NS)
66262 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
66263 ENDIF
66264 V(N+I,5)=P(N+I,5)**2
66265 340 CONTINUE
66266
66267C...Choose one of the daughters for evolution.
66268 350 INUM=0
66269 IF(NEP.EQ.1) INUM=1
66270 DO 360 I=1,NEP
66271 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
66272 360 CONTINUE
66273 DO 370 I=1,NEP
66274 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
66275 IR=IREF(N+I-NS)
66276 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
66277 ENDIF
66278 370 CONTINUE
66279 IF(INUM.EQ.0) THEN
66280 RMAX=0D0
66281 DO 380 I=1,NEP
66282 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
66283 RPM=P(N+I,5)/PMSD(I)
66284 IR=IREF(N+I-NS)
66285 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
66286 RMAX=RPM
66287 INUM=I
66288 ENDIF
66289 ENDIF
66290 380 CONTINUE
66291 ENDIF
66292
66293C...Cancel choice of predetermined daughter already treated.
66294 INUM=MAX(1,INUM)
66295 INUMT=INUM
66296 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
66297 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
66298 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
66299 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
66300 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
66301 ENDIF
66302
66303C...Store information on choice of evolving daughter.
66304 IEP(1)=N+INUM
66305 DO 390 I=2,NEP
66306 IEP(I)=IEP(I-1)+1
66307 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
66308 390 CONTINUE
66309 DO 400 I=1,NEP
66310 KFL(I)=IABS(K(IEP(I),2))
66311 400 CONTINUE
66312 ITRY(INUM)=ITRY(INUM)+1
66313 IF(ITRY(INUM).GT.200) THEN
66314 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
66315 IF(MSTU(21).GE.1) RETURN
66316 ENDIF
66317 Z=0.5D0
66318 IR=IREF(IEP(1)-NS)
66319 IF(KSH(IR).EQ.0) GOTO 450
66320 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
66321
66322C...Check if evolution already predetermined for daughter.
66323 IPSPD=0
66324 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
66325 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
66326 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
66327 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
66328 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
66329 ENDIF
66330 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
66331 ISSET(INUM)=0
66332 IF(IPSPD.NE.0) ISSET(INUM)=1
66333 ENDIF
66334
66335C...Select side for interference with initial state partons.
66336 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
66337 III=IEP(1)-NS-1
66338 ISII(III)=0
66339 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
66340 ISII(III)=1
66341 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
66342 IF(PYR(0).GT.0.5D0) ISII(III)=1
66343 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
66344 ISII(III)=1
66345 IF(PYR(0).GT.0.5D0) ISII(III)=2
66346 ENDIF
66347 ENDIF
66348
66349C...Calculate allowed z range.
66350 IF(NEP.EQ.1) THEN
66351 PMED=PS(4)
66352 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66353 PMED=P(IM,5)
66354 ELSE
66355 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
66356 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
66357 ENDIF
66358 IF(MOD(MSTJ(43),2).EQ.1) THEN
66359 ZC=PMTH(2,21)/PMED
66360 ZCE=PMTH(2,22)/PMED
66361 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
66362 ELSE
66363 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
66364 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
66365 PMTMPE=PMTH(2,22)
66366 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
66367 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
66368 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
66369 ENDIF
66370 ZC=MIN(ZC,0.491D0)
66371 ZCE=MIN(ZCE,0.49991D0)
66372 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
66373 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
66374 P(IEP(1),5)=PMTH(1,IR)
66375 V(IEP(1),5)=P(IEP(1),5)**2
66376 GOTO 450
66377 ENDIF
66378
66379C...Integral of Altarelli-Parisi z kernel for QCD.
66380C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
66381 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
66382 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
66383C...QUARKONIA+++
66384C...Evolution of QQ~[3S18] state if MSTP(148)=1.
66385 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
66386 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66387 FBR=6D0*LOG((1D0-ZC)/ZC)
66388C...QUARKONIA---
66389 ELSEIF(MSTJ(49).EQ.0) THEN
66390 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
66391 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
66392
66393C...Integral of Altarelli-Parisi z kernel for scalar gluon.
66394 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
66395 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
66396 ELSEIF(MSTJ(49).EQ.1) THEN
66397 FBR=(1D0-2D0*ZC)/3D0
66398 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
66399
66400C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
66401 ELSEIF(KFL(1).EQ.21) THEN
66402 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
66403 ELSE
66404 FBR=2D0*LOG((1D0-ZC)/ZC)
66405 ENDIF
66406
66407C...Reset QCD probability for colourless.
66408 IF(ISCOL(IR).EQ.0) FBR=0D0
66409
66410C...Integral of Altarelli-Parisi kernel for photon emission.
66411 FBRE=0D0
66412 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
66413 IF(KFL(1).LE.18) THEN
66414 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
66415 ENDIF
66416 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
66417 ENDIF
66418
66419C...Inner veto algorithm starts. Find maximum mass for evolution.
66420 410 PMS=V(IEP(1),5)
66421 IF(IGM.GE.0) THEN
66422 PM2=0D0
66423 DO 420 I=2,NEP
66424 PM=P(IEP(I),5)
66425 IRI=IREF(IEP(I)-NS)
66426 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
66427 PM2=PM2+PM
66428 420 CONTINUE
66429 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
66430 ENDIF
66431
66432C...Select mass for daughter in QCD evolution.
66433 B0=27D0/6D0
66434 DO 430 IFF=4,MSTJ(45)
66435 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
66436 430 CONTINUE
66437C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66438 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
66439C...Already predetermined choice.
66440 IF(IPSPD.NE.0) THEN
66441 PMSQCD=P(IPSPD,5)**2
66442 ELSEIF(FBR.LT.1D-3) THEN
66443 PMSQCD=0D0
66444 ELSEIF(MSTJ(44).LE.0) THEN
66445 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
66446 ELSEIF(MSTJ(44).EQ.1) THEN
66447 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
66448 ELSE
66449 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
66450 ENDIF
66451C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66452 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
66453 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
66454 V(IEP(1),5)=PMSQCD
66455 MCE=1
66456
66457C...Select mass for daughter in QED evolution.
66458 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
66459C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66460 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
66461 IF(FBRE.LT.1D-3) THEN
66462 PMSQED=0D0
66463 ELSE
66464 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
66465 & (PARU(101)*FBRE)))
66466 ENDIF
66467C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66468 PMSQED=PMSQED+PMTH(1,IR)**2
66469 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
66470 & PMTH(2,IR)**2
66471 IF(PMSQED.GT.PMSQCD) THEN
66472 V(IEP(1),5)=PMSQED
66473 MCE=2
66474 ENDIF
66475 ENDIF
66476
66477C...Check whether daughter mass below cutoff.
66478 P(IEP(1),5)=SQRT(V(IEP(1),5))
66479 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
66480 P(IEP(1),5)=PMTH(1,IR)
66481 V(IEP(1),5)=P(IEP(1),5)**2
66482 GOTO 450
66483 ENDIF
66484
66485C...Already predetermined choice of z, and flavour in g -> qqbar.
66486 IF(IPSPD.NE.0) THEN
66487 IPSGD1=K(IPSPD,4)
66488 IPSGD2=K(IPSPD,5)
66489 PMSGD1=P(IPSGD1,5)**2
66490 PMSGD2=P(IPSGD2,5)**2
66491 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
66492 & 4D0*PMSGD1*PMSGD2))
66493 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
66494 & PMSGD1+PMSGD2)/ALAMPS
66495 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
66496 IF(KFL(1).NE.21) THEN
66497 K(IEP(1),5)=21
66498 ELSE
66499 K(IEP(1),5)=IABS(K(IPSGD1,2))
66500 ENDIF
66501
66502C...Select z value of branching: q -> qgamma.
66503 ELSEIF(MCE.EQ.2) THEN
66504 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
66505 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66506 K(IEP(1),5)=22
66507
66508C...QUARKONIA+++
66509C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
66510 ELSEIF(MSTJ(49).EQ.0.AND.
66511 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66512 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66513C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
66514 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
66515 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66516 K(IEP(1),5)=21
66517C...QUARKONIA---
66518
66519C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
66520 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
66521 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66522C...Only do z weighting when no ME correction afterwards.
66523 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66524 K(IEP(1),5)=21
66525 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
66526 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66527 IF(PYR(0).GT.0.5D0) Z=1D0-Z
66528 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66529 K(IEP(1),5)=21
66530 ELSEIF(MSTJ(49).NE.1) THEN
66531 Z=PYR(0)
66532 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
66533 KFLB=1+INT(MSTJ(45)*PYR(0))
66534 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66535 IF(PMQ.GE.1D0) GOTO 410
66536 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
66537 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
66538 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
66539 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
66540 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
66541 ELSE
66542 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
66543 ENDIF
66544 K(IEP(1),5)=KFLB
66545
66546C...Ditto for scalar gluon model.
66547 ELSEIF(KFL(1).NE.21) THEN
66548 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
66549 K(IEP(1),5)=21
66550 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
66551 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66552 K(IEP(1),5)=21
66553 ELSE
66554 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66555 KFLB=1+INT(MSTJ(45)*PYR(0))
66556 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66557 IF(PMQ.GE.1D0) GOTO 410
66558 K(IEP(1),5)=KFLB
66559 ENDIF
66560
66561C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
66562 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
66563 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66564 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66565 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
66566 ELSE
66567 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
66568 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
66569 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
66570 IF(PT2APP.LT.PT2MIN) GOTO 410
66571 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
66572 ENDIF
66573 ENDIF
66574
66575C...Check if z consistent with chosen m.
66576 IF(KFL(1).EQ.21) THEN
66577 IRGD1=IABS(K(IEP(1),5))
66578 IRGD2=IRGD1
66579 ELSE
66580 IRGD1=IR
66581 IRGD2=IABS(K(IEP(1),5))
66582 ENDIF
66583 IF(NEP.EQ.1) THEN
66584 PED=PS(4)
66585 ELSEIF(NEP.GE.3) THEN
66586 PED=P(IEP(1),4)
66587 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66588 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
66589 ELSE
66590 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
66591 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
66592 ENDIF
66593 IF(MOD(MSTJ(43),2).EQ.1) THEN
66594 PMQTH3=0.5D0*PARJ(82)
66595 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66596 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
66597 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
66598 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
66599 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66600 & 4D0*PMQ1*PMQ2)))
66601 ZH=1D0+PMQ1-PMQ2
66602 ELSE
66603 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
66604 ZH=1D0
66605 ENDIF
66606 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66607 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66608 ELSEIF(IPSPD.NE.0) THEN
66609 ELSE
66610 ZL=0.5D0*(ZH-ZD)
66611 ZU=0.5D0*(ZH+ZD)
66612 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
66613 ENDIF
66614 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
66615 &(1D0-ZU)))
66616 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66617
66618C...Width suppression for q -> q + g.
66619 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
66620 IF(IGM.EQ.0) THEN
66621 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
66622 ELSE
66623 EGLU=PMED*(1D0-Z)
66624 ENDIF
66625 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
66626 IF(MSTJ(40).EQ.1) THEN
66627 IF(CHI.LT.PYR(0)) GOTO 410
66628 ELSEIF(MSTJ(40).EQ.2) THEN
66629 IF(1D0-CHI.LT.PYR(0)) GOTO 410
66630 ENDIF
66631 ENDIF
66632
66633C...Three-jet matrix element correction.
66634 IF(M3JC.GE.1) THEN
66635 WME=1D0
66636 WSHOW=1D0
66637
66638C...QED matrix elements: only for massless case so far.
66639 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
66640 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66641 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66642 X3=(1D0-X1)+(1D0-X2)
66643 KI1=K(IPA(INUM),2)
66644 KI2=K(IPA(3-INUM),2)
66645 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
66646 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
66647 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
66648 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
66649 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66650 ELSEIF(MCE.EQ.2) THEN
66651
66652C...QCD matrix elements, including mass effects.
66653 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
66654 PS1ME=V(IEP(1),5)
66655 PM1ME=PMTH(1,IR)
66656 M3JCC=M3JC
66657 IF(IR.GE.31.AND.IGM.EQ.0) THEN
66658C...QCD ME: original parton, first branching.
66659 PM2ME=PMTH(1,63-IR)
66660 ECMME=PS(5)
66661 ELSEIF(IR.GE.31) THEN
66662C...QCD ME: original parton, subsequent branchings.
66663 PM2ME=PMTH(1,63-IR)
66664 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66665 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66666 ELSEIF(K(IM,2).EQ.21) THEN
66667C...QCD ME: secondary partons, first branching.
66668 PM2ME=PM1ME
66669 ZMME=V(IM,1)
66670 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
66671 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
66672 & 4D0*PS1ME*PM2ME**2))
66673 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
66674 & V(IM,5)
66675 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66676 M3JCC=66
66677 ELSE
66678C...QCD ME: secondary partons, subsequent branchings.
66679 PM2ME=PM1ME
66680 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66681 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66682 M3JCC=66
66683 ENDIF
66684C...Construct ME variables.
66685 R1ME=PM1ME/ECMME
66686 R2ME=PM2ME/ECMME
66687 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
66688 X2=1D0+R2ME**2-PS1ME/ECMME**2
66689C...Call ME, with right order important for two inequivalent showerers.
66690 IF(IR.EQ.IORD+30) THEN
66691 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
66692 ELSE
66693 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
66694 ENDIF
66695C...Split up total ME when two radiating partons.
66696 ISPRAD=1
66697 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
66698 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
66699 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
66700 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
66701 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
66702 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66703 & MAX(1D-10,2D0-X1-X2)
66704C...Evaluate shower rate to be compared with.
66705 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
66706 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66707 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
66708 ELSEIF(MSTJ(49).NE.1) THEN
66709
66710C...Toy model scalar theory matrix elements; no mass effects.
66711 ELSE
66712 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66713 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66714 X3=(1D0-X1)+(1D0-X2)
66715 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
66716 WME=X3**2
66717 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
66718 & PARJ(171)
66719 ENDIF
66720
66721 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
66722 ENDIF
66723
66724C...Impose angular ordering by rejection of nonordered emission.
66725 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
66726 PEMAO=V(IM,1)*P(IM,4)
66727 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
66728 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
66729 MAOD=0
66730 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
66731 & .OR.MSTJ(42).EQ.7)) THEN
66732 MAOD=0
66733 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
66734 & .OR.MSTJ(42).EQ.6)) THEN
66735 MAOD=1
66736 PMDAO=PMTH(2,K(IEP(1),5))
66737 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
66738 ELSE
66739 MAOD=1
66740 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
66741 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
66742 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
66743 ENDIF
66744 MAOM=1
66745 IAOM=IM
66746 440 IF(K(IAOM,5).EQ.22) THEN
66747 IAOM=K(IAOM,3)
66748 IF(K(IAOM,3).LE.NS) MAOM=0
66749 IF(MAOM.EQ.1) GOTO 440
66750 ENDIF
66751 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
66752 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
66753 IF(THE2ID.LT.THE2IM) GOTO 410
66754 ENDIF
66755 ENDIF
66756
66757C...Impose user-defined maximum angle at first branching.
66758 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
66759 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
66760 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
66761 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66762 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
66763 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66764 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66765 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
66766 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66767 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
66768 ENDIF
66769 ENDIF
66770
66771C...Impose angular constraint in first branching from interference
66772C...with initial state partons.
66773 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
66774 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
66775 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
66776 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
66777 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
66778 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
66779 ENDIF
66780 ENDIF
66781
66782C...End of inner veto algorithm. Check if only one leg evolved so far.
66783 450 V(IEP(1),1)=Z
66784 ISL(1)=0
66785 ISL(2)=0
66786 IF(NEP.EQ.1) GOTO 490
66787 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
66788 DO 460 I=1,NEP
66789 IR=IREF(N+I-NS)
66790 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
66791 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
66792 ENDIF
66793 460 CONTINUE
66794
66795C...Check if chosen multiplet m1,m2,z1,z2 is physical.
66796 IF(NEP.GE.3) THEN
66797 PMSUM=0D0
66798 DO 470 I=1,NEP
66799 PMSUM=PMSUM+P(N+I,5)
66800 470 CONTINUE
66801 IF(PMSUM.GE.PS(5)) GOTO 350
66802 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
66803 DO 480 I1=N+1,N+2
66804 IRDA=IREF(I1-NS)
66805 IF(KSH(IRDA).EQ.0) GOTO 480
66806 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
66807 IF(IRDA.EQ.21) THEN
66808 IRGD1=IABS(K(I1,5))
66809 IRGD2=IRGD1
66810 ELSE
66811 IRGD1=IRDA
66812 IRGD2=IABS(K(I1,5))
66813 ENDIF
66814 I2=2*N+3-I1
66815 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66816 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
66817 ELSE
66818 IF(I1.EQ.N+1) ZM=V(IM,1)
66819 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
66820 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
66821 & 4D0*V(N+1,5)*V(N+2,5))
66822 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
66823 & V(IM,5)
66824 ENDIF
66825 IF(MOD(MSTJ(43),2).EQ.1) THEN
66826 PMQTH3=0.5D0*PARJ(82)
66827 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66828 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
66829 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
66830 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
66831 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66832 & 4D0*PMQ1*PMQ2)))
66833 ZH=1D0+PMQ1-PMQ2
66834 ELSE
66835 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
66836 ZH=1D0
66837 ENDIF
66838 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
66839 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66840 ELSE
66841 ZL=0.5D0*(ZH-ZD)
66842 ZU=0.5D0*(ZH+ZD)
66843 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66844 & ISSET(1).EQ.0) THEN
66845 ISL(1)=1
66846 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66847 & ISSET(2).EQ.0) THEN
66848 ISL(2)=1
66849 ENDIF
66850 ENDIF
66851 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
66852 & ZL*(1D0-ZU)))
66853 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66854 480 CONTINUE
66855 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
66856 ISL(3-ISLM)=0
66857 ISLM=3-ISLM
66858 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
66859 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
66860 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
66861 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
66862 IF(ISL(1).EQ.1) ISL(2)=0
66863 IF(ISL(1).EQ.0) ISLM=1
66864 IF(ISL(2).EQ.0) ISLM=2
66865 ENDIF
66866 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
66867 ENDIF
66868 IRD1=IREF(N+1-NS)
66869 IRD2=IREF(N+2-NS)
66870 IF(IGM.GT.0) THEN
66871 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
66872 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
66873 PMQ1=V(N+1,5)/V(IM,5)
66874 PMQ2=V(N+2,5)/V(IM,5)
66875 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
66876 & 4D0*PMQ1*PMQ2)))
66877 ZH=1D0+PMQ1-PMQ2
66878 ZL=0.5D0*(ZH-ZD)
66879 ZU=0.5D0*(ZH+ZD)
66880 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
66881 ENDIF
66882 ENDIF
66883
66884C...Accepted branch. Construct four-momentum for initial partons.
66885 490 MAZIP=0
66886 MAZIC=0
66887 IF(NEP.EQ.1) THEN
66888 P(N+1,1)=0D0
66889 P(N+1,2)=0D0
66890 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
66891 & P(N+1,5))))
66892 P(N+1,4)=P(IPA(1),4)
66893 V(N+1,2)=P(N+1,4)
66894 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
66895 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
66896 P(N+1,1)=0D0
66897 P(N+1,2)=0D0
66898 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
66899 P(N+1,4)=PED1
66900 P(N+2,1)=0D0
66901 P(N+2,2)=0D0
66902 P(N+2,3)=-P(N+1,3)
66903 P(N+2,4)=P(IM,5)-PED1
66904 V(N+1,2)=P(N+1,4)
66905 V(N+2,2)=P(N+2,4)
66906 ELSEIF(NEP.GE.3) THEN
66907C...Rescale all momenta for energy conservation.
66908 LOOP=0
66909 PES=0D0
66910 PQS=0D0
66911 DO 510 I=1,NEP
66912 DO 500 J=1,4
66913 P(N+I,J)=P(IPA(I),J)
66914 500 CONTINUE
66915 PES=PES+P(N+I,4)
66916 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66917 510 CONTINUE
66918 520 LOOP=LOOP+1
66919 FAC=(PS(5)-PQS)/(PES-PQS)
66920 PES=0D0
66921 PQS=0D0
66922 DO 540 I=1,NEP
66923 DO 530 J=1,3
66924 P(N+I,J)=FAC*P(N+I,J)
66925 530 CONTINUE
66926 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)
66927 V(N+I,2)=P(N+I,4)
66928 PES=PES+P(N+I,4)
66929 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66930 540 CONTINUE
66931 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
66932
66933C...Construct transverse momentum for ordinary branching in shower.
66934 ELSE
66935 ZM=V(IM,1)
66936 LOOPPT=0
66937 550 LOOPPT=LOOPPT+1
66938 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
66939 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
66940 IF(PZM.LE.0D0) THEN
66941 PTS=0D0
66942 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
66943 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66944 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
66945 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
66946 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
66947 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
66948 ELSE
66949 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
66950 ENDIF
66951 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
66952 ZM=0.05D0+0.9D0*ZM
66953 GOTO 550
66954 ELSEIF(PTS.LT.0D0) THEN
66955 GOTO 280
66956 ENDIF
66957 PT=SQRT(MAX(0D0,PTS))
66958
66959C...Global statistics.
66960 MINT(353)=MINT(353)+1
66961 VINT(353)=VINT(353)+PT
66962 IF (MINT(353).EQ.1) VINT(358)=PT
66963
66964C...Find coefficient of azimuthal asymmetry due to gluon polarization.
66965 HAZIP=0D0
66966 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
66967 & .AND.IAU.NE.0) THEN
66968 IF(K(IGM,3).NE.0) MAZIP=1
66969 ZAU=V(IGM,1)
66970 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
66971 IF(MAZIP.EQ.0) ZAU=0D0
66972 IF(K(IGM,2).NE.21) THEN
66973 HAZIP=2D0*ZAU/(1D0+ZAU**2)
66974 ELSE
66975 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
66976 ENDIF
66977 IF(K(N+1,2).NE.21) THEN
66978 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
66979 ELSE
66980 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
66981 ENDIF
66982 ENDIF
66983
66984C...Find coefficient of azimuthal asymmetry due to soft gluon
66985C...interference.
66986 HAZIC=0D0
66987 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
66988 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
66989 IF(K(IGM,3).NE.0) MAZIC=N+1
66990 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
66991 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
66992 & ZM.GT.0.5D0) MAZIC=N+2
66993 IF(K(IAU,2).EQ.22) MAZIC=0
66994 ZS=ZM
66995 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
66996 ZGM=V(IGM,1)
66997 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
66998 IF(MAZIC.EQ.0) ZGM=1D0
66999 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
67000 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
67001 HAZIC=MIN(0.95D0,HAZIC)
67002 ENDIF
67003 ENDIF
67004
67005C...Construct energies for ordinary branching in shower.
67006 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
67007 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67008 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67009 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67010 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67011 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
67012 P(N+1,4)=PEM*V(IM,1)
67013 ELSE
67014 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
67015 & SQRT(PMLS)*ZM)/V(IM,5)
67016 ENDIF
67017
67018C...Already predetermined choice of phi angle or not
67019 PHI=PARU(2)*PYR(0)
67020 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
67021 IPSPD=IP1+IM-NS-2
67022 IF(K(IPSPD,4).GT.0) THEN
67023 IPSGD1=K(IPSPD,4)
67024 IF(IM.EQ.NS+2) THEN
67025 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67026 ELSE
67027 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
67028 ENDIF
67029 ENDIF
67030 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
67031 IPSPD=IP1+IM-NS-2
67032 IF(K(IPSPD,4).GT.0) THEN
67033 IPSGD1=K(IPSPD,4)
67034 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
67035 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
67036 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
67037 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
67038 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67039 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
67040 ENDIF
67041 ENDIF
67042
67043C...Construct momenta for ordinary branching in shower.
67044 P(N+1,1)=PT*COS(PHI)
67045 P(N+1,2)=PT*SIN(PHI)
67046 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67047 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67048 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67049 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67050 ELSEIF(PZM.GT.0D0) THEN
67051 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
67052 & 2D0*PEM*P(N+1,4))/PZM
67053 ELSE
67054 P(N+1,3)=0D0
67055 ENDIF
67056 P(N+2,1)=-P(N+1,1)
67057 P(N+2,2)=-P(N+1,2)
67058 P(N+2,3)=PZM-P(N+1,3)
67059 P(N+2,4)=PEM-P(N+1,4)
67060 IF(MSTJ(43).LE.2) THEN
67061 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
67062 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
67063 ENDIF
67064 ENDIF
67065
67066C...Rotate and boost daughters.
67067 IF(IGM.GT.0) THEN
67068 IF(MSTJ(43).LE.2) THEN
67069 BEX=P(IGM,1)/P(IGM,4)
67070 BEY=P(IGM,2)/P(IGM,4)
67071 BEZ=P(IGM,3)/P(IGM,4)
67072 GA=P(IGM,4)/P(IGM,5)
67073 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
67074 & P(IM,4))
67075 ELSE
67076 BEX=0D0
67077 BEY=0D0
67078 BEZ=0D0
67079 GA=1D0
67080 GABEP=0D0
67081 ENDIF
67082 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
67083 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
67084 IF(PTIMB.GT.1D-4) THEN
67085 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
67086 ELSE
67087 PHI=0D0
67088 ENDIF
67089 DO 570 I=N+1,N+2
67090 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
67091 & SIN(THE)*COS(PHI)*P(I,3)
67092 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
67093 & SIN(THE)*SIN(PHI)*P(I,3)
67094 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
67095 DP(4)=P(I,4)
67096 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
67097 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
67098 P(I,1)=DP(1)+DGABP*BEX
67099 P(I,2)=DP(2)+DGABP*BEY
67100 P(I,3)=DP(3)+DGABP*BEZ
67101 P(I,4)=GA*(DP(4)+DBP)
67102 570 CONTINUE
67103 ENDIF
67104
67105C...Weight with azimuthal distribution, if required.
67106 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
67107 DO 580 J=1,3
67108 DPT(1,J)=P(IM,J)
67109 DPT(2,J)=P(IAU,J)
67110 DPT(3,J)=P(N+1,J)
67111 580 CONTINUE
67112 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
67113 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
67114 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
67115 DO 590 J=1,3
67116 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
67117 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
67118 590 CONTINUE
67119 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
67120 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
67121 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
67122 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
67123 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
67124 IF(MAZIP.NE.0) THEN
67125 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
67126 & GOTO 560
67127 ENDIF
67128 IF(MAZIC.NE.0) THEN
67129 IF(MAZIC.EQ.N+2) CAD=-CAD
67130 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
67131 & .LT.PYR(0)) GOTO 560
67132 ENDIF
67133 ENDIF
67134 ENDIF
67135
67136C...Azimuthal anisotropy due to interference with initial state partons.
67137 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
67138 &K(N+2,2).EQ.21)) THEN
67139 III=IM-NS-1
67140 IF(ISII(III).GE.1) THEN
67141 IAZIID=N+1
67142 IF(K(N+1,2).NE.21) IAZIID=N+2
67143 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67144 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
67145 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
67146 IF(III.EQ.2) THEIID=PARU(1)-THEIID
67147 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
67148 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
67149 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
67150 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
67151 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
67152 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
67153 & .LT.PYR(0)) GOTO 560
67154 ENDIF
67155 ENDIF
67156
67157C...Continue loop over partons that may branch, until none left.
67158 IF(IGM.GE.0) K(IM,1)=14
67159 N=N+NEP
67160 NEP=2
67161 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
67162 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
67163 IF(MSTU(21).GE.1) N=NS
67164 IF(MSTU(21).GE.1) RETURN
67165 ENDIF
67166 GOTO 290
67167
67168C...Set information on imagined shower initiator.
67169 600 IF(NPA.GE.2) THEN
67170 K(NS+1,1)=11
67171 K(NS+1,2)=94
67172 K(NS+1,3)=IP1
67173 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
67174 K(NS+1,4)=NS+2
67175 K(NS+1,5)=NS+1+NPA
67176 IIM=1
67177 ELSE
67178 IIM=0
67179 ENDIF
67180
67181C...Reconstruct string drawing information.
67182 DO 610 I=NS+1+IIM,N
67183 KQ=KCHG(PYCOMP(K(I,2)),2)
67184 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
67185 K(I,1)=1
67186 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
67187 & IABS(K(I,2)).LE.18) THEN
67188 K(I,1)=1
67189 ELSEIF(K(I,1).LE.10) THEN
67190 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
67191 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
67192 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
67193 ID1=MOD(K(I,4),MSTU(5))
67194 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
67195 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
67196 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
67197 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
67198 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67199 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
67200 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67201 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
67202 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
67203 K(ID2,5)=K(ID2,5)+MSTU(5)*I
67204 ELSE
67205 ID1=MOD(K(I,4),MSTU(5))
67206 ID2=ID1+1
67207 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67208 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
67209 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
67210 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67211 K(ID1,5)=K(ID1,5)+MSTU(5)*I
67212 ELSE
67213 K(ID1,4)=0
67214 K(ID1,5)=0
67215 ENDIF
67216 K(ID2,4)=0
67217 K(ID2,5)=0
67218 ENDIF
67219 610 CONTINUE
67220
67221C...Transformation from CM frame.
67222 IF(NPA.EQ.1) THEN
67223 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
67224 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
67225 MSTU(33)=1
67226 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
67227 ELSEIF(NPA.EQ.2) THEN
67228 BEX=PS(1)/PS(4)
67229 BEY=PS(2)/PS(4)
67230 BEZ=PS(3)/PS(4)
67231 GA=PS(4)/PS(5)
67232 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
67233 & /(1D0+GA)-P(IPA(1),4))
67234 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
67235 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
67236 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
67237 MSTU(33)=1
67238 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
67239 ELSE
67240 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
67241 & PS(3)/PS(4))
67242 MSTU(33)=1
67243 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
67244 ENDIF
67245
67246C...Decay vertex of shower.
67247 DO 630 I=NS+1,N
67248 DO 620 J=1,5
67249 V(I,J)=V(IP1,J)
67250 620 CONTINUE
67251 630 CONTINUE
67252
67253C...Delete trivial shower, else connect initiators.
67254 IF(N.LE.NS+NPA+IIM) THEN
67255 N=NS
67256 ELSE
67257 DO 640 IP=1,NPA
67258 K(IPA(IP),1)=14
67259 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
67260 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
67261 K(NS+IIM+IP,3)=IPA(IP)
67262 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
67263 IF(K(NS+IIM+IP,1).NE.1) THEN
67264 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
67265 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
67266 ENDIF
67267 640 CONTINUE
67268 ENDIF
67269
67270 RETURN
67271 END
67272
67273C*********************************************************************
67274
67275C...PYPTFS
67276C...Generates pT-ordered timelike final-state parton showers.
67277
67278C...MODE defines how to find radiators and recoilers.
67279C... = 0 : based on colour flow between undecayed partons.
67280C... = 1 : for IPART <= NPARTD only consider primary partons,
67281C... whether decayed or not; else as above.
67282C... = 2 : based on common history, whether decayed or not.
67283
67284 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
67285
67286C...Double precision and integer declarations.
67287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67288 IMPLICIT INTEGER(I-N)
67289 INTEGER PYK,PYCHGE,PYCOMP
67290C...Parameter statement to help give large particle numbers.
67291 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67292 &KEXCIT=4000000,KDIMEN=5000000)
67293C...Parameter statement for maximum size of showers.
67294 PARAMETER (MAXNUR=1000)
67295C...Commonblocks.
67296 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
67297 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67298 COMMON/PYCTAG/NCT,MCT(4000,2)
67299 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67300 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67301 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
67302 COMMON/PYINT1/MINT(400),VINT(400)
67303 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
67304 &/PYINT1/
67305C...Local arrays.
67306 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
67307 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
67308 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
67309 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
67310C...Statement functions.
67311 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
67312 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
67313
67314C...Initial values. Check that valid system.
67315 PTGEN=0D0
67316 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
67317 &MSTJ(41).NE.12) RETURN
67318 IF(NPART.LE.0) THEN
67319 CALL PYERRM(2,'(PYPTFS:) showering system too small')
67320 RETURN
67321 ENDIF
67322 PT2CMX=PTMAX**2
67323
67324C...Mass thresholds and Lambda for QCD evolution.
67325 PMB=PMAS(5,1)
67326 PMC=PMAS(4,1)
67327 ALAM5=PARJ(81)
67328 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
67329 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
67330 PMBS=PMB**2
67331 PMCS=PMC**2
67332 ALAM5S=ALAM5**2
67333 ALAM4S=ALAM4**2
67334 ALAM3S=ALAM3**2
67335
67336C...Cutoff scale for QCD evolution. Starting pT2.
67337 NFLAV=MAX(0,MIN(5,MSTJ(45)))
67338 PT0C=0.5D0*PARJ(82)
67339 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
67340
67341C...Parameters for QED evolution.
67342 AEM2PI=PARU(101)/PARU(2)
67343 PT0EQ=0.5D0*PARJ(83)
67344 PT0EL=0.5D0*PARJ(90)
67345
67346C...Reset. Remove irrelevant colour tags.
67347 NEVOL=0
67348 DO 100 J=1,4
67349 PSUM(J)=0D0
67350 100 CONTINUE
67351 DO 110 I=MINT(84)+1,N
67352 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
67353 K(I,5)=0
67354 MCT(I,2)=0
67355 ENDIF
67356 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
67357 K(I,4)=0
67358 MCT(I,1)=0
67359 ENDIF
67360 110 CONTINUE
67361 NPARTS=NPART
67362
67363C...Begin loop to set up showering partons. Sum four-momenta.
67364 DO 210 IP=1,NPART
67365 I=IPART(IP)
67366 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
67367 IF(K(I,1).GT.10) GOTO 210
67368 ELSEIF(K(I,3).GT.MINT(84)) THEN
67369 IF(K(I,3).GT.MINT(84)+2) GOTO 210
67370 ELSE
67371 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
67372 ENDIF
67373 DO 120 J=1,4
67374 PSUM(J)=PSUM(J)+P(I,J)
67375 120 CONTINUE
67376
67377C...Find colour and charge, but skip diquarks.
67378 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
67379 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
67380 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
67381
67382C...Either colour or anticolour charge radiates; for gluon both.
67383 DO 160 JSGCOL=1,-1,-2
67384 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
67385 JCOL=4+(1-JSGCOL)/2
67386 JCOLR=9-JCOL
67387
67388C...Basic info about radiating parton.
67389 NEVOL=NEVOL+1
67390 IPOS(NEVOL)=I
67391 IFLG(NEVOL)=0
67392 ISCOL(NEVOL)=JSGCOL
67393 ISCHG(NEVOL)=0
67394 PTSCA(NEVOL)=PTPART(IP)
67395
67396C...Begin search for colour recoiler when MODE = 0 or 1.
67397 IF(MODE.LE.1) THEN
67398C...Find sister with matching anticolour to the radiating parton.
67399 IROLD=I
67400 IRNEW=K(IROLD,JCOL)/MSTU(5)
67401 MOVE=1
67402
67403C...The following will add MCT colour tracing for unprepped events
67404C...If not done, trace Les Houches colour tags for this dipole
67405C IF (MCT(I,JCOL-3).EQ.0) THEN
67406C CALL PYCTTR(I,JCOL,INEW)
67407C...Clean up mother/daughter 'read' tags set by PYCTTR
67408C DO 125 IR=1,N
67409C K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
67410C K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
67411C 125 CONTINUE
67412C ENDIF
67413
67414C...Skip radiation off loose colour ends.
67415 130 IF(IRNEW.EQ.0) THEN
67416 NEVOL=NEVOL-1
67417 GOTO 160
67418
67419C...Optionally skip radiation on dipole to beam remnant.
67420 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
67421 NEVOL=NEVOL-1
67422 GOTO 160
67423
67424C...For now always skip radiation on dipole to junction.
67425 ELSEIF(K(IRNEW,2).EQ.88) THEN
67426 NEVOL=NEVOL-1
67427 GOTO 160
67428
67429C...For MODE=1: if reached primary then done.
67430 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
67431 & IRNEW.LE.NPARTD) THEN
67432
67433C...If sister stable and points back then done.
67434 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67435 & THEN
67436 IF(K(IRNEW,1).LT.10) THEN
67437
67438C...If sister unstable then go to her daughter.
67439 ELSE
67440 IROLD=IRNEW
67441 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67442 MOVE=2
67443 GOTO 130
67444 ENDIF
67445
67446C...If found mother then look for aunt.
67447 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67448 & IROLD) THEN
67449 IROLD=IRNEW
67450 IRNEW=K(IROLD,JCOL)/MSTU(5)
67451 GOTO 130
67452
67453C...If daughter stable then done.
67454 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67455 & THEN
67456 IF(K(IRNEW,1).LT.10) THEN
67457
67458C...If daughter unstable then go to granddaughter.
67459 ELSE
67460 IROLD=IRNEW
67461 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67462 MOVE=2
67463 GOTO 130
67464 ENDIF
67465
67466C...If daughter points to another daughter then done or move up.
67467 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67468 & IROLD) THEN
67469 IF(K(IRNEW,1).LT.10) THEN
67470 ELSE
67471 IROLD=IRNEW
67472 IRNEW=K(IRNEW,JCOL)/MSTU(5)
67473 MOVE=1
67474 GOTO 130
67475 ENDIF
67476 ENDIF
67477
67478C...Begin search for colour recoiler when MODE = 2.
67479 ELSE
67480 IROLD=I
67481 IRNEW=K(IROLD,JCOL)/MSTU(5)
67482 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
67483C...Step up to mother if radiating parton already branched.
67484 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
67485 IROLD=IRNEW
67486 IRNEW=K(IROLD,JCOL)/MSTU(5)
67487 GOTO 140
67488C...Pick sister by history if no anticolour available.
67489 ELSE
67490 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67491 IRNEW=IROLD-1
67492 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
67493 & THEN
67494 IRNEW=IROLD+1
67495C...Last resort: pick at random among other primaries.
67496 ELSE
67497 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67498 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67499 ENDIF
67500 ENDIF
67501 ENDIF
67502C...Trace down if sister branched.
67503 150 IF(K(IRNEW,1).GT.10) THEN
67504 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67505 GOTO 150
67506 ENDIF
67507 ENDIF
67508
67509C...Now found other end of colour dipole.
67510 IREC(NEVOL)=IRNEW
67511 ENDIF
67512 160 CONTINUE
67513
67514C...Also electrical charge may radiate; so far only quarks and leptons.
67515 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
67516 & IABS(K(I,2)).LE.18) THEN
67517
67518C...Basic info about radiating parton.
67519 NEVOL=NEVOL+1
67520 IPOS(NEVOL)=I
67521 IFLG(NEVOL)=0
67522 ISCOL(NEVOL)=0
67523 ISCHG(NEVOL)=KCHA
67524 PTSCA(NEVOL)=PTPART(IP)
67525
67526C...Pick nearest (= smallest invariant mass) charged particle
67527C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
67528 IF(MODE.LE.1) THEN
67529 IRNEW=0
67530 PM2MIN=VINT(2)
67531 DO 170 IP2=1,NPART+N-MINT(53)
67532 IF(IP2.EQ.IP) GOTO 170
67533 IF(IP2.LE.NPART) THEN
67534 I2=IPART(IP2)
67535 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
67536 IF(K(I2,1).GT.10) GOTO 170
67537 ELSEIF(K(I2,3).GT.MINT(84)) THEN
67538 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
67539 ELSE
67540 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
67541 ENDIF
67542 ELSE
67543 I2=MINT(53)+IP2-NPART
67544 ENDIF
67545 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
67546 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
67547 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
67548 IF(PM2INV.LT.PM2MIN) THEN
67549 IRNEW=I2
67550 PM2MIN=PM2INV
67551 ENDIF
67552 170 CONTINUE
67553 IF(IRNEW.EQ.0) THEN
67554 NEVOL=NEVOL-1
67555 GOTO 210
67556 ENDIF
67557
67558C...Begin search for charge recoiler when MODE = 2.
67559 ELSE
67560 IROLD=I
67561C...Pick sister by history; step up if parton already branched.
67562 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
67563 IROLD=K(IROLD,3)
67564 GOTO 180
67565 ENDIF
67566 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67567 IRNEW=IROLD-1
67568 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
67569 IRNEW=IROLD+1
67570C...Last resort: pick at random among other primaries.
67571 ELSE
67572 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67573 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67574 ENDIF
67575C...Trace down if sister branched.
67576 190 IF(K(IRNEW,1).GT.10) THEN
67577 DO 200 IR=IRNEW+1,N
67578 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
67579 IRNEW=IR
67580 GOTO 190
67581 ENDIF
67582 200 CONTINUE
67583 ENDIF
67584 ENDIF
67585 IREC(NEVOL)=IRNEW
67586 ENDIF
67587
67588C...End loop to set up showering partons. System invariant mass.
67589 210 CONTINUE
67590 IF(NEVOL.LE.0) RETURN
67591 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
67592
67593C...Check if 3-jet matrix elements to be used.
67594 M3JC=0
67595 ALPHA=0.5D0
67596 NMESYS=0
67597 IF(MSTJ(47).GE.1) THEN
67598
67599C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
67600 KFSRCE=0
67601 IPART1=K(IPART(1),3)
67602 IPART2=K(IPART(2),3)
67603 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
67604 KFSRCE=IABS(K(IPART1,2))
67605 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
67606 IPART1=K(IPART1,3)
67607 GOTO 220
67608 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
67609 IPART2=K(IPART2,3)
67610 GOTO 220
67611 ENDIF
67612 ITYPES=0
67613 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
67614 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
67615 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
67616 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
67617 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
67618 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
67619 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
67620 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
67621
67622C...Identify two primary showerers.
67623 KFLA1=IABS(K(IPART(1),2))
67624 ITYPE1=0
67625 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
67626 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
67627 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
67628 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
67629 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
67630 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
67631 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
67632 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
67633 KFLA2=IABS(K(IPART(2),2))
67634 ITYPE2=0
67635 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
67636 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
67637 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
67638 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
67639 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
67640 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
67641 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
67642 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
67643
67644C...Order of showerers. Presence of gluino.
67645 ITYPMN=MIN(ITYPE1,ITYPE2)
67646 ITYPMX=MAX(ITYPE1,ITYPE2)
67647 IORD=1
67648 IF(ITYPE1.GT.ITYPE2) IORD=2
67649 IGLUI=0
67650 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
67651
67652C...Require exactly two primary showerers for ME corrections.
67653 NPRIM=0
67654 IF(IPART1.GT.0) THEN
67655 DO 230 I=1,N
67656 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
67657 230 CONTINUE
67658 ENDIF
67659 IF(NPRIM.NE.2) THEN
67660
67661C...Predetermined and default matrix element kinds.
67662 ELSEIF(MSTJ(38).NE.0) THEN
67663 M3JC=MSTJ(38)
67664 ALPHA=PARJ(80)
67665 MSTJ(38)=0
67666 ELSEIF(MSTJ(47).GE.6) THEN
67667 M3JC=MSTJ(47)
67668 ELSE
67669 ICLASS=1
67670 ICOMBI=4
67671
67672C...Vector/axial vector -> q + qbar; q -> q + V.
67673 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
67674 & ITYPES.EQ.3)) THEN
67675 ICLASS=2
67676 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
67677 ICOMBI=1
67678 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
67679 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
67680C...gamma*/Z0: assume e+e- initial state if unknown.
67681 EI=-1D0
67682 IF(KFSRCE.EQ.23) THEN
67683 IANNFL=IPART1
67684 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67685 IF(IANNFL.GT.0) THEN
67686 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67687 ENDIF
67688 IF(IANNFL.NE.0) THEN
67689 KANNFL=IABS(K(IANNFL,2))
67690 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
67691 ENDIF
67692 ENDIF
67693 AI=SIGN(1D0,EI+0.1D0)
67694 VI=AI-4D0*EI*PARU(102)
67695 EF=KCHG(KFLA1,1)/3D0
67696 AF=SIGN(1D0,EF+0.1D0)
67697 VF=AF-4D0*EF*PARU(102)
67698 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
67699 SH=PSUM(5)**2
67700 SQMZ=PMAS(23,1)**2
67701 SQWZ=PSUM(5)*PMAS(23,2)
67702 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
67703 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
67704 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
67705 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
67706 ICOMBI=3
67707 ALPHA=VECT/(VECT+AXIV)
67708 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
67709 ICOMBI=4
67710 ENDIF
67711C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
67712 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
67713 ICLASS=2
67714 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67715 & ITYPES.EQ.1)) THEN
67716 ICLASS=3
67717
67718C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
67719 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
67720 ICLASS=4
67721 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
67722 ICOMBI=1
67723 ELSEIF(KFSRCE.EQ.36) THEN
67724 ICOMBI=2
67725 ENDIF
67726 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67727 & ITYPES.EQ.1)) THEN
67728 ICLASS=5
67729
67730C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
67731 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67732 & ITYPES.EQ.3)) THEN
67733 ICLASS=6
67734 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67735 & ITYPES.EQ.2)) THEN
67736 ICLASS=7
67737 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
67738 ICLASS=8
67739 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67740 & ITYPES.EQ.2)) THEN
67741 ICLASS=9
67742
67743C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
67744 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67745 & ITYPES.EQ.5)) THEN
67746 ICLASS=10
67747 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67748 & ITYPES.EQ.2)) THEN
67749 ICLASS=11
67750 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67751 & ITYPES.EQ.1)) THEN
67752 ICLASS=12
67753
67754C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
67755 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
67756 ICLASS=13
67757 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67758 & ITYPES.EQ.2)) THEN
67759 ICLASS=14
67760 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67761 & ITYPES.EQ.1)) THEN
67762 ICLASS=15
67763
67764C...g -> ~g + ~g (eikonal approximation).
67765 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
67766 ICLASS=16
67767 ENDIF
67768 M3JC=5*ICLASS+ICOMBI
67769 ENDIF
67770
67771C...Store pair that together define matrix element treatment.
67772 IF(M3JC.NE.0) THEN
67773 NMESYS=1
67774 MESYS(NMESYS,0)=M3JC
67775 MESYS(NMESYS,1)=IPART(1)
67776 MESYS(NMESYS,2)=IPART(2)
67777 ENDIF
67778
67779C...Store qqbar or l+l- pairs for QED radiation.
67780 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
67781 NMESYS=NMESYS+1
67782 MESYS(NMESYS,0)=101
67783 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
67784 MESYS(NMESYS,1)=IPART(1)
67785 MESYS(NMESYS,2)=IPART(2)
67786 ENDIF
67787
67788C...Store other qqbar/l+l- pairs from g/gamma branchings.
67789 DO 270 I1=1,N
67790 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
67791 I1M=K(I1,3)
67792 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
67793 I1M=K(I1M,3)
67794 GOTO 240
67795 ENDIF
67796C...Move up this check to avoid out-of-bounds.
67797 IF(I1M.EQ.0) GOTO 270
67798 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
67799 DO 260 I2=I1+1,N
67800 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
67801 I2M=K(I2,3)
67802 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
67803 I2M=K(I2M,3)
67804 GOTO 250
67805 ENDIF
67806 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
67807 NMESYS=NMESYS+1
67808 MESYS(NMESYS,0)=66
67809 MESYS(NMESYS,1)=I1
67810 MESYS(NMESYS,2)=I2
67811 NMESYS=NMESYS+1
67812 MESYS(NMESYS,0)=102
67813 MESYS(NMESYS,1)=I1
67814 MESYS(NMESYS,2)=I2
67815 ENDIF
67816 260 CONTINUE
67817 270 CONTINUE
67818 ENDIF
67819
67820C..Loopback point for counting number of emissions.
67821 NGEN=0
67822 280 NGEN=NGEN+1
67823
67824C...Begin loop to evolve all existing partons, if required.
67825 290 IMX=0
67826 PT2MX=0D0
67827 DO 360 IEVOL=1,NEVOL
67828 IF(IFLG(IEVOL).EQ.0) THEN
67829
67830C...Basic info on radiator and recoil.
67831 I=IPOS(IEVOL)
67832 IR=IREC(IEVOL)
67833 SHT=SHAT(I,IR)
67834 PM2I=P(I,5)**2
67835 PM2R=P(IR,5)**2
67836
67837C...Invariant mass of "dipole".Starting value for pT evolution.
67838 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
67839 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
67840
67841C...Case of evolution by QCD branching.
67842 IF(ISCOL(IEVOL).NE.0) THEN
67843
67844C...Parton-by-parton maximum scale from initial conditions.
67845 IF(MSTP(72).EQ.0) THEN
67846 DO 300 IPRT=1,NPARTS
67847 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
67848 300 CONTINUE
67849 ENDIF
67850
67851C...If kinematically impossible then do not evolve.
67852 IF(PT2.LT.PT2CMN) THEN
67853 IFLG(IEVOL)=-1
67854 GOTO 360
67855 ENDIF
67856
67857C...Check if part of system for which ME corrections should be applied.
67858 IMESYS=0
67859 DO 310 IME=1,NMESYS
67860 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67861 & MESYS(IME,0).LT.100) IMESYS=IME
67862 310 CONTINUE
67863
67864C...Special flag for colour octet states.
67865 MOCT=0
67866 IF(K(I,2).EQ.21) MOCT=1
67867 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
67868
67869C...Upper estimate for matrix element weighting and colour factor.
67870C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
67871 WTPSGL=2D0
67872 COLFAC=4D0/3D0
67873 IF(MOCT.GE.1) COLFAC=3D0/2D0
67874 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
67875 WTPSQQ=0.5D0*0.5D0*NFLAV
67876
67877C...Determine overestimated z range: switch at c and b masses.
67878 320 IZRG=1
67879 PT2MNE=PT2CMN
67880 B0=27D0/6D0
67881 ALAMS=ALAM3S
67882 IF(PT2.GT.1.01D0*PMCS) THEN
67883 IZRG=2
67884 PT2MNE=PMCS
67885 B0=25D0/6D0
67886 ALAMS=ALAM4S
67887 ENDIF
67888 IF(PT2.GT.1.01D0*PMBS) THEN
67889 IZRG=3
67890 PT2MNE=PMBS
67891 B0=23D0/6D0
67892 ALAMS=ALAM5S
67893 ENDIF
67894 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
67895 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
67896
67897C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
67898 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
67899 EVCOEF=EVEMGL
67900 IF(MOCT.EQ.1) THEN
67901 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
67902 EVCOEF=EVCOEF+EVEMQQ
67903 ENDIF
67904
67905C...Pick pT2 (in overestimated z range).
67906 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
67907
67908C...Loopback if crossed c/b mass thresholds.
67909 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
67910 PT2=PMBS
67911 GOTO 320
67912 ENDIF
67913 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
67914 PT2=PMCS
67915 GOTO 320
67916 ENDIF
67917
67918C...Finish if below lower cutoff.
67919 IF(PT2.LT.PT2CMN) THEN
67920 IFLG(IEVOL)=-1
67921 GOTO 360
67922 ENDIF
67923
67924C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
67925 IFLAG=1
67926 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
67927
67928C...Pick z: dz/(1-z) or dz.
67929 IF(IFLAG.EQ.1) THEN
67930 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
67931 ELSE
67932 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
67933 ENDIF
67934
67935C...Loopback if outside allowed range for given pT2.
67936 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
67937 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
67938 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
67939 PM2=PM2I+PT2/(Z*(1D0-Z))
67940 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
67941
67942C...No weighting for primary partons; to be done later on.
67943 IF(IMESYS.GT.0) THEN
67944
67945C...Weighting of q->qg/X->Xg branching.
67946 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
67947 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
67948
67949C...Weighting of g->gg branching.
67950 ELSEIF(IFLAG.EQ.1) THEN
67951 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
67952
67953C...Flavour choice and weighting of g->qqbar branching.
67954 ELSE
67955 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
67956 PMQ=PMAS(KFQ,1)
67957 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
67958 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
67959 IF(WTME.LT.PYR(0)) GOTO 330
67960 IFLAG=10+KFQ
67961 ENDIF
67962
67963C...Case of evolution by QED branching.
67964 ELSEIF(ISCHG(IEVOL).NE.0) THEN
67965
67966C...If kinematically impossible then do not evolve.
67967 PT2EMN=PT0EQ**2
67968 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
67969 IF(PT2.LT.PT2EMN) THEN
67970 IFLG(IEVOL)=-1
67971 GOTO 360
67972 ENDIF
67973
67974C...Check if part of system for which ME corrections should be applied.
67975 IMESYS=0
67976 DO 340 IME=1,NMESYS
67977 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67978 & MESYS(IME,0).GT.100) IMESYS=IME
67979 340 CONTINUE
67980
67981C...Charge. Matrix element weighting factor.
67982 CHG=ISCHG(IEVOL)/3D0
67983 WTPSGA=2D0
67984
67985C...Determine overestimated z range. Find evolution coefficient.
67986 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
67987 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
67988 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
67989
67990C...Pick pT2 (in overestimated z range).
67991 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
67992
67993C...Finish if below lower cutoff.
67994 IF(PT2.LT.PT2EMN) THEN
67995 IFLG(IEVOL)=-1
67996 GOTO 360
67997 ENDIF
67998
67999C...Pick z: dz/(1-z).
68000 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
68001
68002C...Loopback if outside allowed range for given pT2.
68003 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
68004 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
68005 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
68006 PM2=PM2I+PT2/(Z*(1D0-Z))
68007 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
68008
68009C...Weighting by branching kernel, except if ME weighting later.
68010 IF(IMESYS.EQ.0) THEN
68011 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
68012 ENDIF
68013 IFLAG=3
68014 ENDIF
68015
68016C...Save acceptable branching.
68017 IFLG(IEVOL)=IFLAG
68018 IMESAV(IEVOL)=IMESYS
68019 PT2SAV(IEVOL)=PT2
68020 ZSAV(IEVOL)=Z
68021 SHTSAV(IEVOL)=SHT
68022 ENDIF
68023
68024C...Check if branching has highest pT.
68025 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
68026 IMX=IEVOL
68027 PT2MX=PT2SAV(IEVOL)
68028 ENDIF
68029 360 CONTINUE
68030
68031C...Finished if no more branchings to be done.
68032 IF(IMX.EQ.0) GOTO 480
68033
68034C...Restore info on hardest branching to be processed.
68035 I=IPOS(IMX)
68036 IR=IREC(IMX)
68037 KCOL=ISCOL(IMX)
68038 KCHA=ISCHG(IMX)
68039 IMESYS=IMESAV(IMX)
68040 PT2=PT2SAV(IMX)
68041 Z=ZSAV(IMX)
68042 SHT=SHTSAV(IMX)
68043 PM2I=P(I,5)**2
68044 PM2R=P(IR,5)**2
68045 PM2=PM2I+PT2/(Z*(1D0-Z))
68046
68047C...Special flag for colour octet states.
68048 MOCT=0
68049 IF(K(I,2).EQ.21) MOCT=1
68050 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
68051
68052C...Restore further info for g->qqbar branching.
68053 KFQ=0
68054 IF(IFLG(IMX).GT.10) THEN
68055 KFQ=IFLG(IMX)-10
68056 PMQ=PMAS(KFQ,1)
68057 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
68058 ENDIF
68059
68060C...For branching g include azimuthal asymmetries from polarization.
68061 ASYPOL=0D0
68062 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
68063C...Trace grandmother via intermediate recoil copies.
68064 KFGM=0
68065 IM=I
68066 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
68067 & K(IM,3).GT.0) THEN
68068 IM=K(IM,3)
68069 IF(IM.GT.MINT(84)) GOTO 370
68070 ENDIF
68071 IGM=K(IM,3)
68072 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
68073 & KFGM=IABS(K(IGM,2))
68074C...Define approximate energy sharing by identifying aunt.
68075 IAU=IM+1
68076 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
68077 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
68078 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
68079C...Coefficient from gluon production.
68080 IF(KFGM.LE.6) THEN
68081 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
68082 ELSE
68083 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
68084 ENDIF
68085C...Coefficient from gluon decay.
68086 IF(KFQ.EQ.0) THEN
68087 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
68088 ELSE
68089 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
68090 ENDIF
68091 ENDIF
68092 ENDIF
68093
68094C...Create new slots for branching products and recoil.
68095 INEW=N+1
68096 IGNEW=N+2
68097 IRNEW=N+3
68098 N=N+3
68099
68100C...Set status, flavour and mother of new ones.
68101 K(INEW,1)=K(I,1)
68102 K(IGNEW,1)=3
68103 IF(KCHA.NE.0) K(IGNEW,1)=1
68104 K(IRNEW,1)=K(IR,1)
68105 IF(KFQ.EQ.0) THEN
68106 K(INEW,2)=K(I,2)
68107 K(IGNEW,2)=21
68108 IF(KCHA.NE.0) K(IGNEW,2)=22
68109 ELSE
68110 K(INEW,2)=-ISIGN(KFQ,KCOL)
68111 K(IGNEW,2)=-K(INEW,2)
68112 ENDIF
68113 K(IRNEW,2)=K(IR,2)
68114 K(INEW,3)=I
68115 K(IGNEW,3)=I
68116 K(IRNEW,3)=IR
68117
68118C...Find rest frame and angles of branching+recoil.
68119 DO 380 J=1,5
68120 P(INEW,J)=P(I,J)
68121 P(IGNEW,J)=0D0
68122 P(IRNEW,J)=P(IR,J)
68123 380 CONTINUE
68124 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
68125 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
68126 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
68127 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
68128 PHI=PYANGL(P(INEW,1),P(INEW,2))
68129 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
68130
68131C...Derive kinematics of branching: generics (like g->gg).
68132 DO 390 J=1,4
68133 P(INEW,J)=0D0
68134 P(IRNEW,J)=0D0
68135 390 CONTINUE
68136 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
68137 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
68138 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
68139 PTCOR=SQRT(MAX(0D0,PT2COR))
68140 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
68141 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
68142C...Specific kinematics reduction for q->qg with m_q > 0.
68143 IF(MOCT.NE.1) THEN
68144 PTCOR=(1D0-PM2I/PM2)*PTCOR
68145 PZN=PZN+PM2I*PZG/PM2
68146 PZG=(1D0-PM2I/PM2)*PZG
68147C...Specific kinematics reduction for g->qqbar with m_q > 0.
68148 ELSEIF(KFQ.NE.0) THEN
68149 P(INEW,5)=PMQ
68150 P(IGNEW,5)=PMQ
68151 PTCOR=ROOTQQ*PTCOR
68152 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
68153 PZG=PZM-PZN
68154 ENDIF
68155
68156C...Pick phi and construct kinematics of branching.
68157 400 PHIROT=PARU(2)*PYR(0)
68158 P(INEW,1)=PTCOR*COS(PHIROT)
68159 P(INEW,2)=PTCOR*SIN(PHIROT)
68160 P(INEW,3)=PZN
68161 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
68162 P(IGNEW,1)=-P(INEW,1)
68163 P(IGNEW,2)=-P(INEW,2)
68164 P(IGNEW,3)=PZG
68165 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
68166 P(IRNEW,1)=0D0
68167 P(IRNEW,2)=0D0
68168 P(IRNEW,3)=-PZM
68169 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
68170
68171C...Boost branching system to lab frame.
68172 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
68173
68174C...Renew choice of phi angle according to polarization asymmetry.
68175 IF(ABS(ASYPOL).GT.1D-3) THEN
68176 DO 410 J=1,3
68177 DPT(1,J)=P(I,J)
68178 DPT(2,J)=P(IAU,J)
68179 DPT(3,J)=P(INEW,J)
68180 410 CONTINUE
68181 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
68182 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
68183 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
68184 DO 420 J=1,3
68185 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
68186 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
68187 420 CONTINUE
68188 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
68189 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
68190 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
68191 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
68192 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
68193 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
68194 & GOTO 400
68195 ENDIF
68196 ENDIF
68197
68198C...Matrix element corrections for primary partons when requested.
68199 IF(IMESYS.GT.0) THEN
68200 M3JC=MESYS(IMESYS,0)
68201
68202C...Identify recoiling partner and set up three-body kinematics.
68203 IRP=MESYS(IMESYS,1)
68204 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
68205 IF(IRP.EQ.IR) IRP=IRNEW
68206 DO 430 J=1,4
68207 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
68208 430 CONTINUE
68209 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
68210 & PSUM(3)**2))
68211 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
68212 & PSUM(3)*P(INEW,3))/PSUM(5)**2
68213 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
68214 & PSUM(3)*P(IRP,3))/PSUM(5)**2
68215 X3=2D0-X1-X2
68216 R1ME=P(INEW,5)/PSUM(5)
68217 R2ME=P(IRP,5)/PSUM(5)
68218
68219C...Matrix elements for gluon emission.
68220 IF(M3JC.LT.100) THEN
68221
68222C...Call ME, with right order important for two inequivalent showerers.
68223 IF(MESYS(IMESYS,IORD).EQ.I) THEN
68224 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
68225 ELSE
68226 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
68227 ENDIF
68228
68229C...Split up total ME when two radiating partons.
68230 ISPRAD=1
68231 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
68232 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
68233 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
68234 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
68235 & MAX(1D-10,2D0-X1-X2)
68236
68237C...Evaluate shower rate.
68238 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68239 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68240 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
68241
68242C...Matrix elements for photon emission: still rather primitive.
68243 ELSE
68244
68245C...For generic charge combination currently only massless expression.
68246 IF(M3JC.EQ.101) THEN
68247 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
68248 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
68249 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
68250 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
68251
68252C...For flavour neutral system assume vector source and include masses.
68253 ELSE
68254 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
68255 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
68256 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68257 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68258 ENDIF
68259 ENDIF
68260
68261C...Perform weighting with W_ME/W_PS.
68262 IF(WME.LT.PYR(0)*WPS) THEN
68263 N=N-3
68264 IFLG(IMX)=0
68265 PT2CMX=PT2
68266 GOTO 290
68267 ENDIF
68268 ENDIF
68269
68270C...Now for sure accepted branching. Save highest pT.
68271 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
68272
68273C...Update status for obsolete ones. Bookkkep the moved original parton
68274C...and new daughter (arbitrary choice for g->gg or g->qqbar).
68275C...Do not bookkeep radiated photon, since it cannot radiate further.
68276 K(I,1)=K(I,1)+10
68277 K(IR,1)=K(IR,1)+10
68278 DO 440 IP=1,NPART
68279 IF(IPART(IP).EQ.I) IPART(IP)=INEW
68280 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
68281 440 CONTINUE
68282 IF(KCHA.EQ.0) THEN
68283 NPART=NPART+1
68284 IPART(NPART)=IGNEW
68285 ENDIF
68286
68287C...Initialize colour flow of branching.
68288C...Use both old and new style colour tags for flexibility.
68289 K(INEW,4)=0
68290 K(IGNEW,4)=0
68291 K(INEW,5)=0
68292 K(IGNEW,5)=0
68293 JCOLP=4+(1-KCOL)/2
68294 JCOLN=9-JCOLP
68295 MCT(INEW,1)=0
68296 MCT(INEW,2)=0
68297 MCT(IGNEW,1)=0
68298 MCT(IGNEW,2)=0
68299 MCT(IRNEW,1)=0
68300 MCT(IRNEW,2)=0
68301
68302C...Trivial colour flow for l->lgamma and q->qgamma.
68303 IF(IABS(KCHA).EQ.3) THEN
68304 K(I,4)=INEW
68305 K(I,5)=IGNEW
68306 ELSEIF(KCHA.NE.0) THEN
68307 IF(K(I,4).NE.0) THEN
68308 K(I,4)=K(I,4)+INEW
68309 K(INEW,4)=MSTU(5)*I
68310 MCT(INEW,1)=MCT(I,1)
68311 ENDIF
68312 IF(K(I,5).NE.0) THEN
68313 K(I,5)=K(I,5)+INEW
68314 K(INEW,5)=MSTU(5)*I
68315 MCT(INEW,2)=MCT(I,2)
68316 ENDIF
68317
68318C...Set colour flow for q->qg and g->gg.
68319 ELSEIF(KFQ.EQ.0) THEN
68320 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68321 K(IGNEW,JCOLP)=MSTU(5)*I
68322 K(INEW,JCOLP)=MSTU(5)*IGNEW
68323 K(IGNEW,JCOLN)=MSTU(5)*INEW
68324 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68325 NCT=NCT+1
68326 MCT(INEW,JCOLP-3)=NCT
68327 MCT(IGNEW,JCOLN-3)=NCT
68328 IF(MOCT.GE.1) THEN
68329 K(I,JCOLN)=K(I,JCOLN)+INEW
68330 K(INEW,JCOLN)=MSTU(5)*I
68331 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68332 ENDIF
68333
68334C...Set colour flow for g->qqbar.
68335 ELSE
68336 K(I,JCOLN)=K(I,JCOLN)+INEW
68337 K(INEW,JCOLN)=MSTU(5)*I
68338 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68339 K(IGNEW,JCOLP)=MSTU(5)*I
68340 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68341 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68342 ENDIF
68343
68344C...Daughter info for colourless recoiling parton.
68345 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
68346 K(IR,4)=IRNEW
68347 K(IR,5)=IRNEW
68348 K(IRNEW,4)=0
68349 K(IRNEW,5)=0
68350
68351C...Colour of recoiling parton sails through unchanged.
68352 ELSE
68353 IF(K(IR,4).NE.0) THEN
68354 K(IR,4)=K(IR,4)+IRNEW
68355 K(IRNEW,4)=MSTU(5)*IR
68356 MCT(IRNEW,1)=MCT(IR,1)
68357 ENDIF
68358 IF(K(IR,5).NE.0) THEN
68359 K(IR,5)=K(IR,5)+IRNEW
68360 K(IRNEW,5)=MSTU(5)*IR
68361 MCT(IRNEW,2)=MCT(IR,2)
68362 ENDIF
68363 ENDIF
68364
68365C...Vertex information trivial.
68366 DO 450 J=1,5
68367 V(INEW,J)=V(I,J)
68368 V(IGNEW,J)=V(I,J)
68369 V(IRNEW,J)=V(IR,J)
68370 450 CONTINUE
68371
68372C...Update list of old radiators.
68373 DO 460 IEVOL=1,NEVOL
68374 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
68375 IPOS(IEVOL)=INEW
68376 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
68377 IREC(IEVOL)=IRNEW
68378 IFLG(IEVOL)=0
68379 ELSEIF(IPOS(IEVOL).EQ.I) THEN
68380 IPOS(IEVOL)=INEW
68381 IFLG(IEVOL)=0
68382 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
68383 IPOS(IEVOL)=IRNEW
68384 IREC(IEVOL)=INEW
68385 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
68386 IFLG(IEVOL)=0
68387 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
68388 IPOS(IEVOL)=IRNEW
68389 IFLG(IEVOL)=0
68390 ENDIF
68391C...Update links of old connected partons.
68392 IF(IREC(IEVOL).EQ.I) THEN
68393 IREC(IEVOL)=INEW
68394 IFLG(IEVOL)=0
68395 ELSEIF(IREC(IEVOL).EQ.IR) THEN
68396 IREC(IEVOL)=IRNEW
68397 IFLG(IEVOL)=0
68398 ENDIF
68399 460 CONTINUE
68400
68401C...q->qg or g->gg: create new gluon radiators.
68402 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
68403 NEVOL=NEVOL+1
68404 IPOS(NEVOL)=INEW
68405 IREC(NEVOL)=IGNEW
68406 IFLG(NEVOL)=0
68407 ISCOL(NEVOL)=KCOL
68408 ISCHG(NEVOL)=0
68409 PTSCA(NEVOL)=SQRT(PT2)
68410 NEVOL=NEVOL+1
68411 IPOS(NEVOL)=IGNEW
68412 IREC(NEVOL)=INEW
68413 IFLG(NEVOL)=0
68414 ISCOL(NEVOL)=-KCOL
68415 ISCHG(NEVOL)=0
68416 PTSCA(NEVOL)=PTSCA(NEVOL-1)
68417 ENDIF
68418
68419C...Update matrix elements parton list and add new for g/gamma->qqbar.
68420 DO 470 IME=1,NMESYS
68421 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
68422 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
68423 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
68424 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
68425 470 CONTINUE
68426 IF(KFQ.NE.0) THEN
68427 NMESYS=NMESYS+1
68428 MESYS(NMESYS,0)=66
68429 MESYS(NMESYS,1)=INEW
68430 MESYS(NMESYS,2)=IGNEW
68431 NMESYS=NMESYS+1
68432 MESYS(NMESYS,0)=102
68433 MESYS(NMESYS,1)=INEW
68434 MESYS(NMESYS,2)=IGNEW
68435 ENDIF
68436
68437C...Global statistics.
68438 MINT(353)=MINT(353)+1
68439 VINT(353)=VINT(353)+PTCOR
68440 IF (MINT(353).EQ.1) VINT(358)=PTCOR
68441
68442C...Loopback for more emissions if enough space.
68443 PT2CMX=PT2
68444 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
68445 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
68446 GOTO 280
68447 ELSE
68448 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
68449 ENDIF
68450
68451C...Done.
68452 480 CONTINUE
68453
68454 RETURN
68455 END
68456
68457C*********************************************************************
68458
68459C...PYMAEL
68460C...Auxiliary to PYSHOW and PYPTFS.
68461C...Matrix elements for gluon (or photon) emission from
68462C...a two-body state; to be used by the parton shower routine.
68463C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
68464C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
68465C... = (alpha-strong/2 pi) * CF * PYMAEL,
68466C...i.e. normalization is such that one recovers the familiar
68467C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
68468C...Coupling structure:
68469C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
68470C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
68471C... = 16-19 : q -> q V
68472C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
68473C... = 26-29 : q -> q S
68474C... = 31-34 : V -> ~q ~qbar (~q = squark)
68475C... = 36-39 : ~q -> ~q V
68476C... = 41-44 : S -> ~q ~qbar
68477C... = 46-49 : ~q -> ~q S
68478C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
68479C... = 56-59 : ~q -> q chi
68480C... = 61-64 : q -> ~q chi
68481C... = 66-69 : ~g -> q ~qbar
68482C... = 71-74 : ~q -> q ~g
68483C... = 76-79 : q -> ~q ~g
68484C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
68485C...Note that the order of the decay products is important.
68486C...In each set of four, the variants are ordered as:
68487C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
68488C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
68489C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
68490C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
68491
68492 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
68493
68494C...Double precision and integer declarations.
68495 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68496 IMPLICIT INTEGER(I-N)
68497
68498C...Check input values. Return zero outside allowed phase space.
68499 PYMAEL=0D0
68500 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
68501 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
68502 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
68503 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
68504 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
68505 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
68506
68507C...Initial values and flags.
68508 ICLASS=NI/5
68509 ICOMBI=NI-5*ICLASS
68510 ISSET1=0
68511 ISSET2=0
68512 ISSET4=0
68513
68514C... Phase space.
68515 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
68516
68517C...Eikonal expression; also acts as default.
68518 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
68519 RLO=PS
68520 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
68521 ANUM=0D0
68522 ELSEIF(ICOMBI.EQ.2) THEN
68523 ANUM=(2D0-X1-X2)**2
68524 ELSEIF(ICOMBI.EQ.3) THEN
68525 ANUM=ALPCOR*(2D0-X1-X2)**2
68526 ELSE
68527 ANUM=0.5D0*(2D0-X1-X2)**2
68528 ENDIF
68529 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
68530 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
68531 & R1**2/(1D0+R2**2-R1**2-X2)**2-
68532 & R2**2/(1D0+R1**2-R2**2-X1)**2)
68533 ICOMBI=0
68534
68535C...V -> q qbar (V = gamma*/Z0/W+-/...).
68536 ELSEIF(ICLASS.EQ.2) THEN
68537 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68538 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68539 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
68540 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
68541 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
68542 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
68543 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68544 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
68545 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
68546 & (-1+R1**2-R2**2+X2)**2
68547 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68548 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68549 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
68550 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68551 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
68552 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68553 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68554 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
68555 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
68556 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
68557 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
68558 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
68559 RFO1=RFO1/2.D0
68560 ISSET1=1
68561 ENDIF
68562 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68563 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68564 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
68565 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
68566 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
68567 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
68568 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
68569 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
68570 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
68571 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68572 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68573 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
68574 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68575 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
68576 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68577 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68578 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
68579 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
68580 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
68581 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68582 & +X2)/(-1-R1**2+R2**2+X1)**2
68583 RFO2=RFO2/2.D0
68584 ISSET2=1
68585 ENDIF
68586 IF(ICOMBI.EQ.4) THEN
68587 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
68588 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
68589 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
68590 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
68591 & (-1-R1**2+R2**2+X1)**2
68592 RFO4=RFO4
68593 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
68594 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
68595 & -R1**2*X2**2+X1*X2**2)/
68596 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68597 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
68598 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
68599 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
68600 & (-1+R1**2-R2**2+X2)**2
68601 RFO4=RFO4/2.D0
68602 ISSET4=1
68603 ENDIF
68604
68605C...q -> q V.
68606 ELSEIF(ICLASS.EQ.3) THEN
68607 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68608 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
68609 & +R1**2*R2**2-2D0*R2**4)
68610 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
68611 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
68612 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
68613 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
68614 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
68615 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
68616 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68617 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
68618 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68619 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
68620 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68621 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68622 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
68623 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
68624 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68625 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
68626 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68627 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
68628 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
68629 ISSET1=1
68630 ENDIF
68631 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68632 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
68633 & +R1**2*R2**2-2D0*R2**4)
68634 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
68635 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
68636 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
68637 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
68638 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
68639 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
68640 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68641 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
68642 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68643 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
68644 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68645 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68646 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68647 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
68648 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68649 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
68650 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68651 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68652 & +X1*X2**2)/(-2+X1+X2)**2
68653 ISSET2=1
68654 ENDIF
68655 IF(ICOMBI.EQ.4) THEN
68656 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
68657 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
68658 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
68659 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
68660 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
68661 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68662 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
68663 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
68664 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68665 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68666 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68667 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
68668 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
68669 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68670 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68671 & +X1*X2**2)/(2-X1-X2)**2
68672 ISSET4=1
68673 ENDIF
68674
68675C...S -> q qbar (S = h0/H0/A0/H+-/...).
68676 ELSEIF(ICLASS.EQ.4) THEN
68677 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68678 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
68679 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68680 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68681 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68682 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
68683 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
68684 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68685 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68686 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68687 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68688 ISSET1=1
68689 ENDIF
68690 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68691 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
68692 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68693 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68694 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68695 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68696 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68697 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68698 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
68699 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
68700 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
68701 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68702 ISSET2=1
68703 ENDIF
68704 IF(ICOMBI.EQ.4) THEN
68705 RLO4=PS*(1D0-R1**2-R2**2)
68706 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
68707 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68708 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
68709 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
68710 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68711 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
68712 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68713 ISSET4=1
68714 ENDIF
68715
68716C...q -> q S.
68717 ELSEIF(ICLASS.EQ.5) THEN
68718 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68719 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68720 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68721 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68722 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
68723 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68724 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68725 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68726 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68727 & (-1+R1**2-R2**2+X2)**2
68728 ISSET1=1
68729 ENDIF
68730 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68731 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68732 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68733 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68734 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
68735 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68736 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68737 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68738 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68739 & (-1+R1**2-R2**2+X2)**2
68740 ISSET2=1
68741 ENDIF
68742 IF(ICOMBI.EQ.4) THEN
68743 RLO4=PS*(1D0+R1**2-R2**2)
68744 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
68745 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68746 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
68747 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68748 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68749 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68750 ISSET4=1
68751 ENDIF
68752
68753C...V -> ~q ~qbar (~q = squark).
68754 ELSEIF(ICLASS.EQ.6) THEN
68755 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68756 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
68757 & (-1-R1**2+R2**2+X1)**2
68758 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
68759 & (-1-R1**2+R2**2+X1)
68760 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
68761 & /(-1+R1**2-R2**2+X2)**2
68762 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
68763 & (-1+R1**2-R2**2+X2)
68764 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
68765 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
68766 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
68767 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68768 ISSET1=1
68769
68770C...~q -> ~q V.
68771 ELSEIF(ICLASS.EQ.7) THEN
68772 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68773 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
68774 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
68775 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
68776 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68777 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
68778 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
68779 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
68780 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
68781 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
68782 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
68783 & (3*(-2+X1+X2))
68784 RFO1=3D0*RFO1/8D0
68785 ISSET1=1
68786
68787C...S -> ~q ~qbar.
68788 ELSEIF(ICLASS.EQ.8) THEN
68789 RLO1=PS
68790 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68791 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
68792 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
68793 & -R1**2*X2**2+X1*X2**2)/
68794 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
68795 RFO1=2D0*RFO1
68796 ISSET1=1
68797
68798C...~q -> ~q S.
68799 ELSEIF(ICLASS.EQ.9) THEN
68800 RLO1=PS
68801 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68802 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68803 & -(X1+X2)/(-2+X1+X2)**2
68804 ISSET1=1
68805
68806C...chi -> q ~qbar (chi = neutralino/chargino).
68807 ELSEIF(ICLASS.EQ.10) THEN
68808 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68809 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68810 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68811 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
68812 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68813 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68814 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68815 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68816 & (-1+R1**2-R2**2+X2)**2
68817 ISSET1=1
68818 ENDIF
68819 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68820 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
68821 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
68822 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
68823 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
68824 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68825 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68826 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68827 & (-1+R1**2-R2**2+X2)**2
68828 ISSET2=1
68829 ENDIF
68830 IF(ICOMBI.EQ.4) THEN
68831 RLO4=PS*(1+R1**2-R2**2)
68832 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68833 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
68834 & +X2+R1**2*X2-X1*X2/2)/
68835 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68836 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68837 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68838 ISSET4=1
68839 ENDIF
68840
68841C...~q -> q chi.
68842 ELSEIF(ICLASS.EQ.11) THEN
68843 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68844 RLO1=PS*(1D0-(R1+R2)**2)
68845 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68846 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68847 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68848 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68849 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68850 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68851 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68852 ISSET1=1
68853 ENDIF
68854 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68855 RLO2=PS*(1D0-(R1-R2)**2)
68856 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
68857 & (-2+X1+X2)**2
68858 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68859 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68860 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68861 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
68862 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68863 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68864 ISSET2=1
68865 ENDIF
68866 IF(ICOMBI.EQ.4) THEN
68867 RLO4=PS*(1D0-R1**2-R2**2)
68868 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68869 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
68870 & +3*R1**2*X2-R2**2*X2-X1*X2)/
68871 & (-1+R1**2-R2**2+X2)**2
68872 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
68873 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
68874 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68875 ISSET4=1
68876 ENDIF
68877
68878C...q -> ~q chi.
68879 ELSEIF(ICLASS.EQ.12) THEN
68880 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68881 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
68882 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68883 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
68884 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
68885 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
68886 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68887 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68888 ISSET1=1
68889 END IF
68890 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68891 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
68892 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
68893 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
68894 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
68895 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
68896 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68897 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68898 ISSET2=1
68899 END IF
68900 IF(ICOMBI.EQ.4) THEN
68901 RLO4=PS*(1D0-R1**2+R2**2)
68902 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68903 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
68904 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
68905 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
68906 & +R1**2*X2-X1*X2/2-X2**2/2)/
68907 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68908 ISSET4=1
68909 END IF
68910
68911C...~g -> q ~qbar.
68912 ELSEIF(ICLASS.EQ.13) THEN
68913 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68914 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68915 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
68916 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
68917 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
68918 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
68919 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68920 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
68921 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
68922 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
68923 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
68924 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
68925 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
68926 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68927 & (3*(-1+R1**2-R2**2+X2)**2)
68928 RFO1=3D0*RFO1/4D0
68929 ISSET1=1
68930 ENDIF
68931 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68932 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68933 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
68934 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
68935 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
68936 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
68937 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
68938 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
68939 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
68940 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
68941 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
68942 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68943 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
68944 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
68945 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68946 & (3*(-1+R1**2-R2**2+X2)**2)
68947 RFO2=3D0*RFO2/4D0
68948 ISSET2=1
68949 ENDIF
68950 IF(ICOMBI.EQ.4) THEN
68951 RLO4=PS*(1D0+R1**2-R2**2)
68952 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
68953 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
68954 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
68955 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
68956 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
68957 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68958 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
68959 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68960 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
68961 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68962 & (3*(-1+R1**2-R2**2+X2)**2)
68963 RFO4=3D0*RFO4/8D0
68964 ISSET4=1
68965 ENDIF
68966
68967C...~q -> q ~g.
68968 ELSEIF(ICLASS.EQ.14) THEN
68969 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68970 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
68971 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
68972 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68973 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68974 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
68975 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
68976 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
68977 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
68978 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68979 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68980 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
68981 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
68982 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
68983 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
68984 RFO1=RFO1
68985 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68986 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68987 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
68988 RFO1=9D0*RFO1/64D0
68989 ISSET1=1
68990 ENDIF
68991 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68992 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
68993 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
68994 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68995 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68996 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
68997 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
68998 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
68999 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
69000 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
69001 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
69002 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69003 RFO2=RFO2
69004 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
69005 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
69006 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69007 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
69008 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
69009 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69010 RFO2=9D0*RFO2/64D0
69011 ISSET2=1
69012 ENDIF
69013 IF(ICOMBI.EQ.4) THEN
69014 RLO4=PS*(1-R1**2-R2**2)
69015 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
69016 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
69017 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
69018 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
69019 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
69020 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
69021 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
69022 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69023 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
69024 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
69025 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
69026 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
69027 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
69028 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
69029 RFO4=9D0*RFO4/128D0
69030 ISSET4=1
69031 ENDIF
69032
69033C...q -> ~q ~g.
69034 ELSEIF(ICLASS.EQ.15) THEN
69035 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69036 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
69037 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69038 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
69039 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
69040 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
69041 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
69042 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69043 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
69044 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
69045 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69046 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
69047 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
69048 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
69049 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69050 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69051 RFO1=9D0*RFO1/32D0
69052 ISSET1=1
69053 END IF
69054 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69055 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
69056 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
69057 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
69058 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
69059 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
69060 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
69061 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69062 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
69063 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
69064 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69065 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
69066 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
69067 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
69068 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
69069 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69070 RFO2=9D0*RFO2/32D0
69071 ISSET2=1
69072 END IF
69073 IF(ICOMBI.EQ.4) THEN
69074 RLO4=PS*(1D0-R1**2+R2**2)
69075 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69076 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
69077 & -R2**2*X2/2-X1*X2/2)/
69078 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
69079 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
69080 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69081 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
69082 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69083 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
69084 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
69085 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69086 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69087 RFO4=9D0*RFO4/64D0
69088 ISSET4=1
69089 END IF
69090
69091C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
69092 ELSEIF(ICLASS.EQ.16) THEN
69093 RLO=PS
69094 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
69095 ANUM=0D0
69096 ELSEIF(ICOMBI.EQ.2) THEN
69097 ANUM=(2D0-X1-X2)**2
69098 ELSEIF(ICOMBI.EQ.3) THEN
69099 ANUM=ALPCOR*(2D0-X1-X2)**2
69100 ELSE
69101 ANUM=0.5D0*(2D0-X1-X2)**2
69102 ENDIF
69103 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
69104 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
69105 & R1**2/(1D0+R2**2-R1**2-X2)**2-
69106 & R2**2/(1D0+R1**2-R2**2-X1)**2)
69107 RFO=9D0*RFO/4D0
69108 ICOMBI=0
69109 ENDIF
69110
69111C...Find relevant LO and FO expression.
69112 IF(ICOMBI.EQ.0) THEN
69113 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
69114 RLO=RLO1
69115 RFO=RFO1
69116 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
69117 RLO=RLO2
69118 RFO=RFO2
69119 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69120 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
69121 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
69122 ELSEIF(ISSET4.EQ.1) THEN
69123 RLO=RLO4
69124 RFO=RFO4
69125 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69126 RLO=0.5D0*(RLO1+RLO2)
69127 RFO=0.5D0*(RFO1+RFO2)
69128 ELSEIF(ISSET1.EQ.1) THEN
69129 RLO=RLO1
69130 RFO=RFO1
69131 ELSE
69132 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
69133 RLO=1D0
69134 RFO=0D0
69135 ENDIF
69136
69137C...Output.
69138 PYMAEL=RFO/RLO
69139
69140 RETURN
69141 END
69142
69143C*********************************************************************
69144
69145C...PYBOEI
69146C...Modifies an event so as to approximately take into account
69147C...Bose-Einstein effects according to a simple phenomenological
69148C...parametrization.
69149
69150 SUBROUTINE PYBOEI(NSAV)
69151
69152C...Double precision and integer declarations.
69153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69154 IMPLICIT INTEGER(I-N)
69155 INTEGER PYK,PYCHGE,PYCOMP
69156C...Parameter statement to help give large particle numbers.
69157 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69158 &KEXCIT=4000000,KDIMEN=5000000)
69159C...Commonblocks.
69160 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69161 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69162 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69163 COMMON/PYINT1/MINT(400),VINT(400)
69164 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
69165C...Local arrays and data.
69166 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
69167 &BEIW(100),BEI3W(100)
69168 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
69169C...Statement function: squared invariant mass.
69170 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
69171 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
69172
69173C...Boost event to overall CM frame. Calculate CM energy.
69174 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
69175 DO 100 J=1,4
69176 DPS(J)=0D0
69177 100 CONTINUE
69178 DO 120 I=1,N
69179 KFA=IABS(K(I,2))
69180 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
69181 & .AND.K(I,3).GT.0) THEN
69182 KFMA=IABS(K(K(I,3),2))
69183 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
69184 ENDIF
69185 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
69186 DO 110 J=1,4
69187 DPS(J)=DPS(J)+P(I,J)
69188 110 CONTINUE
69189 120 CONTINUE
69190 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
69191 &-DPS(3)/DPS(4))
69192 PECM=0D0
69193 DO 130 I=1,N
69194 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
69195 130 CONTINUE
69196
69197C...Check if we have separated strings
69198
69199C...Reserve copy of particles by species at end of record.
69200 IWP=0
69201 IWN=0
69202 NBE(0)=N+MSTU(3)
69203 NMAX=NBE(0)
69204 SMMIN=PECM
69205 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
69206 NBE(IBE)=NBE(IBE-1)
69207 DO 180 I=NSAV+1,N
69208 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
69209 DO 140 IIBE=1,IBE-1
69210 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
69211 140 CONTINUE
69212 ELSE
69213 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
69214 ENDIF
69215 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
69216 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
69217 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
69218 RETURN
69219 ENDIF
69220 NBE(IBE)=NBE(IBE)+1
69221 NMAX=NBE(IBE)
69222 K(NBE(IBE),1)=I
69223 K(NBE(IBE),2)=0
69224 K(NBE(IBE),3)=0
69225 K(NBE(IBE),4)=0
69226 K(NBE(IBE),5)=0
69227 P(NBE(IBE),1)=0.0D0
69228 P(NBE(IBE),2)=0.0D0
69229 P(NBE(IBE),3)=0.0D0
69230 P(NBE(IBE),4)=0.0D0
69231 P(NBE(IBE),5)=0.0D0
69232 SMMIN=MIN(SMMIN,P(I,5))
69233C...Check if particles comes from different W's or Z's
69234 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
69235 IM=I
69236 150 IF(K(IM,3).GT.0) THEN
69237 IM=K(IM,3)
69238 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
69239 K(NBE(IBE),5)=IM
69240 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
69241 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
69242 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
69243 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
69244 ENDIF
69245 ENDIF
69246C...Check if particles comes from different strings.
69247 IF(PARJ(94).GT.0.0D0) THEN
69248 IM=I
69249 160 IF(K(IM,3).GT.0) THEN
69250 IM=K(IM,3)
69251 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
69252 K(NBE(IBE),5)=IM
69253 ENDIF
69254 ENDIF
69255 DO 170 J=1,3
69256 P(NBE(IBE),J)=0D0
69257 V(NBE(IBE),J)=0D0
69258 170 CONTINUE
69259 P(NBE(IBE),5)=-1.0D0
69260 180 CONTINUE
69261 190 CONTINUE
69262 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
69263
69264C...Calculate separation between W+ and W- or between two Z0's.
69265C...No separation if there has been re-connections.
69266 SIGW=PARJ(93)
69267 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
69268 IF(K(IWP,2).EQ.23) THEN
69269 DMW=PMAS(23,1)
69270 DGW=PMAS(23,2)
69271 ELSE
69272 DMW=PMAS(24,1)
69273 DGW=PMAS(24,2)
69274 ENDIF
69275 DMP=P(IWP,5)
69276 DMN=P(IWN,5)
69277 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
69278 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
69279 TAUP=-TAUPD*LOG(PYR(IDUM))
69280 TAUN=-TAUND*LOG(PYR(IDUM))
69281 DXP=TAUP*PYP(IWP,8)/DMP
69282 DXN=TAUN*PYP(IWN,8)/DMN
69283 DX=DXP+DXN
69284 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
69285 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
69286 ENDIF
69287
69288C...Add separation between strings.
69289 IF(PARJ(94).GT.0.0D0) THEN
69290 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
69291 IWP=-1
69292 IWN=-1
69293 ENDIF
69294
69295 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
69296 DO 220 IBE=1,MIN(9,MSTJ(52))
69297 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
69298 Q2MIN=PECM**2
69299 I1=K(I1M,1)
69300 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
69301 IF(I2M.EQ.I1M) GOTO 200
69302 I2=K(I2M,1)
69303 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
69304 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
69305 & (P(I1,5)+P(I2,5))**2
69306 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
69307 Q2MIN=Q2
69308 ENDIF
69309 200 CONTINUE
69310 P(I1M,5)=Q2MIN
69311 210 CONTINUE
69312 220 CONTINUE
69313 ENDIF
69314
69315C...Tabulate integral for subsequent momentum shift.
69316 DO 400 IBE=1,MIN(9,MSTJ(52))
69317 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
69318 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
69319 & .LE.1) GOTO 270
69320 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
69321 & NBE(7)-NBE(6)).LE.1) GOTO 270
69322 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
69323 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
69324 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
69325 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
69326 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
69327 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
69328 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
69329 QDELW=0.1D0*MIN(PMHQ,SIGW)
69330 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
69331 IF(MSTJ(51).EQ.1) THEN
69332 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
69333 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
69334 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
69335 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
69336 BEEX=EXP(0.5D0*QDEL/PARJ(93))
69337 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
69338 BEEXW=EXP(0.5D0*QDELW/SIGW)
69339 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
69340 BERT=EXP(-QDEL/PARJ(93))
69341 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
69342 BERTW=EXP(-QDELW/SIGW)
69343 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
69344 ELSE
69345 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
69346 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
69347 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
69348 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
69349 ENDIF
69350 DO 230 IBIN=1,NBIN
69351 QBIN=QDEL*(IBIN-0.5D0)
69352 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69353 IF(MSTJ(51).EQ.1) THEN
69354 BEEX=BEEX*BERT
69355 BEI(IBIN)=BEI(IBIN)*BEEX
69356 ELSE
69357 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
69358 ENDIF
69359 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
69360 230 CONTINUE
69361 DO 240 IBIN=1,NBIN3
69362 QBIN=QDEL3*(IBIN-0.5D0)
69363 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69364 IF(MSTJ(51).EQ.1) THEN
69365 BEEX3=BEEX3*BERT3
69366 BEI3(IBIN)=BEI3(IBIN)*BEEX3
69367 ELSE
69368 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
69369 ENDIF
69370 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
69371 240 CONTINUE
69372 DO 250 IBIN=1,NBINW
69373 QBIN=QDELW*(IBIN-0.5D0)
69374 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69375 IF(MSTJ(51).EQ.1) THEN
69376 BEEXW=BEEXW*BERTW
69377 BEIW(IBIN)=BEIW(IBIN)*BEEXW
69378 ELSE
69379 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
69380 ENDIF
69381 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
69382 250 CONTINUE
69383 DO 260 IBIN=1,NBIN3W
69384 QBIN=QDEL3W*(IBIN-0.5D0)
69385 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
69386 & SQRT(QBIN**2+PMHQ**2)
69387 IF(MSTJ(51).EQ.1) THEN
69388 BEEX3W=BEEX3W*BERT3W
69389 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
69390 ELSE
69391 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
69392 ENDIF
69393 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
69394 260 CONTINUE
69395
69396C...Loop through particle pairs and find old relative momentum.
69397 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
69398 I1=K(I1M,1)
69399 DO 380 I2M=I1M+1,NBE(IBE)
69400 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
69401 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
69402 I2=K(I2M,1)
69403 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
69404 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
69405 IF(Q2OLD.LE.0.0D0) GOTO 380
69406 QOLD=SQRT(Q2OLD)
69407
69408C...Calculate new relative momentum.
69409 QMOV=0.0D0
69410 QMOV3=0.0D0
69411 QMOVW=0.0D0
69412 QMOV3W=0.0D0
69413 IF(QOLD.LT.1D-3*QDEL) THEN
69414 GOTO 280
69415 ELSEIF(QOLD.LE.QDEL) THEN
69416 QMOV=QOLD/3D0
69417 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
69418 RBIN=QOLD/QDEL
69419 IBIN=RBIN
69420 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
69421 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
69422 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69423 ELSE
69424 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69425 ENDIF
69426 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
69427 IF(QOLD.LT.1D-3*QDEL3) THEN
69428 GOTO 290
69429 ELSEIF(QOLD.LE.QDEL3) THEN
69430 QMOV3=QOLD/3D0
69431 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
69432 RBIN3=QOLD/QDEL3
69433 IBIN3=RBIN3
69434 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
69435 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
69436 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69437 ELSE
69438 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69439 ENDIF
69440 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
69441 RSCALE=1.0D0
69442 IF(MSTJ(54).EQ.2)
69443 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
69444 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
69445 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
69446
69447 IF(QOLD.LT.1D-3*QDELW) THEN
69448 GOTO 300
69449 ELSEIF(QOLD.LE.QDELW) THEN
69450 QMOVW=QOLD/3D0
69451 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
69452 RBINW=QOLD/QDELW
69453 IBINW=RBINW
69454 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
69455 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
69456 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69457 ELSE
69458 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69459 ENDIF
69460 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
69461 IF(QOLD.LT.1D-3*QDEL3W) THEN
69462 GOTO 310
69463 ELSEIF(QOLD.LE.QDEL3W) THEN
69464 QMOV3W=QOLD/3D0
69465 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
69466 RBIN3W=QOLD/QDEL3W
69467 IBIN3W=RBIN3W
69468 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
69469 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
69470 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69471 ELSE
69472 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69473 ENDIF
69474 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
69475 IF(MSTJ(54).EQ.2)
69476 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
69477
69478 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
69479 DO 330 J=1,3
69480 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
69481 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
69482 330 CONTINUE
69483 IF(MSTJ(54).GE.1) THEN
69484 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
69485 DO 340 J=1,3
69486 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
69487 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
69488 340 CONTINUE
69489 ELSEIF(MSTJ(54).LE.-1) THEN
69490 EDEL=P(I1,4)+P(I2,4)-
69491 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
69492 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69493 & (P(I1,3)-P(I2,3))**2
69494 WMAX=-1.0D20
69495 MI3=0
69496 MI4=0
69497 S12=SDIP(I1,I2)
69498 SM1=(P(I1,5)+SMMIN)**2
69499 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69500 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
69501 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
69502 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69503 & K(I3M,5).NE.K(I1M,5)) GOTO 360
69504 I3=K(I3M,1)
69505 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
69506 S13=SDIP(I1,I3)
69507 S23=SDIP(I2,I3)
69508 SM3=(P(I3,5)+SMMIN)**2
69509 IF(MSTJ(54).EQ.-2) THEN
69510 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
69511 & S23*MIN(SM1,SM3))*SM1)
69512 ELSE
69513 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
69514 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
69515 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
69516 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
69517 ENDIF
69518 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
69519 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
69520 & GOTO 360
69521 ELSE
69522 IF(WMAX*WI.GE.1.0) GOTO 360
69523 ENDIF
69524 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
69525 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
69526 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
69527 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69528 & K(I4M,5).NE.K(I1M,5)) GOTO 350
69529 I4=K(I4M,1)
69530 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
69531 & GOTO 350
69532 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
69533 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69534 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
69535 & GOTO 350
69536 IF(MSTJ(54).EQ.-2) THEN
69537 S14=SDIP(I1,I4)
69538 S24=SDIP(I2,I4)
69539 S34=SDIP(I3,I4)
69540 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
69541 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
69542 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
69543 W=MIN(W,MIN(S23,S24)*S13*S14)
69544 W=1.0D0/W
69545 ELSE
69546C...weight=1-cos(theta)/mtot2
69547 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
69548 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
69549 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
69550 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
69551 W=1.0D0/S1234
69552 IF(W.LE.WMAX) GOTO 350
69553 ENDIF
69554 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
69555 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
69556 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
69557 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
69558 IF(W.LE.WMAX) GOTO 350
69559 MI3=I3M
69560 MI4=I4M
69561 WMAX=W
69562 350 CONTINUE
69563 360 CONTINUE
69564 IF(MI4.EQ.0) GOTO 380
69565 I3=K(MI3,1)
69566 I4=K(MI4,1)
69567 EOLD=P(I3,4)+P(I4,4)
69568 ENEW=EOLD+EDEL
69569 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69570 & (P(I3,3)+P(I4,3))**2
69571 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
69572 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
69573 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
69574 DO 370 J=1,3
69575 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
69576 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
69577 370 CONTINUE
69578 ENDIF
69579 380 CONTINUE
69580 390 CONTINUE
69581 400 CONTINUE
69582
69583C...Shift momenta and recalculate energies.
69584 ESUMP=0.0D0
69585 ESUM=0.0D0
69586 PROD=0.0D0
69587 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69588 I=K(IM,1)
69589 ESUMP=ESUMP+P(I,4)
69590 DO 410 J=1,3
69591 P(I,J)=P(I,J)+P(IM,J)
69592 410 CONTINUE
69593 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69594 ESUM=ESUM+P(I,4)
69595 DO 420 J=1,3
69596 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69597 420 CONTINUE
69598 430 CONTINUE
69599
69600 PARJ(96)=0.0D0
69601 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
69602 440 ALPHA=(ESUMP-ESUM)/PROD
69603 PARJ(96)=PARJ(96)+ALPHA
69604 PROD=0.0D0
69605 ESUM=0.0D0
69606 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69607 I=K(IM,1)
69608 DO 450 J=1,3
69609 P(I,J)=P(I,J)+ALPHA*V(IM,J)
69610 450 CONTINUE
69611 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69612 ESUM=ESUM+P(I,4)
69613 DO 460 J=1,3
69614 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69615 460 CONTINUE
69616 470 CONTINUE
69617 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
69618 & GOTO 440
69619 ENDIF
69620
69621C...Rescale all momenta for energy conservation.
69622 PES=0D0
69623 PQS=0D0
69624 DO 480 I=1,N
69625 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
69626 PES=PES+P(I,4)
69627 PQS=PQS+P(I,5)**2/P(I,4)
69628 480 CONTINUE
69629 PARJ(95)=PES-PECM
69630 FAC=(PECM-PQS)/(PES-PQS)
69631 DO 500 I=1,N
69632 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
69633 DO 490 J=1,3
69634 P(I,J)=FAC*P(I,J)
69635 490 CONTINUE
69636 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69637 500 CONTINUE
69638
69639C...Boost back to correct reference frame.
69640 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
69641 DO 520 I=1,N
69642 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
69643 520 CONTINUE
69644
69645 RETURN
69646 END
69647
69648C*********************************************************************
69649
69650C...PYBESQ
69651C...Calculates the momentum shift in a system of two particles assuming
69652C...the relative momentum squared should be shifted to Q2NEW. NI is the
69653C...last position occupied in /PYJETS/.
69654
69655 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
69656
69657C...Double precision and integer declarations.
69658 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69659 IMPLICIT INTEGER(I-N)
69660 INTEGER PYK,PYCHGE,PYCOMP
69661C...Parameter statement to help give large particle numbers.
69662 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69663 &KEXCIT=4000000,KDIMEN=5000000)
69664C...Commonblocks.
69665 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69666 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69667 SAVE /PYJETS/,/PYDAT1/
69668C...Local arrays and data.
69669 DIMENSION DP(5)
69670 SAVE HC1
69671
69672 IF(MSTJ(55).EQ.0) THEN
69673 DQ2=Q2NEW-Q2OLD
69674 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69675 & (P(I1,3)-P(I2,3))**2
69676 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
69677 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
69678 SE=P(I1,4)+P(I2,4)
69679 DE=P(I1,4)-P(I2,4)
69680 DQ2SE=DQ2+SE**2
69681 DA=SE*DE*DP12-DP2*DQ2SE
69682 DB=DP2*DQ2SE-DP12**2
69683 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
69684 DO 100 J=1,3
69685 PD=HA*(P(I1,J)-P(I2,J))
69686 P(NI+1,J)=PD
69687 P(NI+2,J)=-PD
69688 100 CONTINUE
69689 RETURN
69690 ENDIF
69691
69692 K(NI+1,1)=1
69693 K(NI+2,1)=1
69694 DO 110 J=1,5
69695 P(NI+1,J)=P(I1,J)
69696 P(NI+2,J)=P(I2,J)
69697 DP(J)=P(I1,J)+P(I2,J)
69698 110 CONTINUE
69699
69700C...Boost to cms and rotate first particle to z-axis
69701 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
69702 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
69703 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
69704 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
69705 S=Q2NEW+(P(I1,5)+P(I2,5))**2
69706 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
69707 P(NI+1,1)=0.0D0
69708 P(NI+1,2)=0.0D0
69709 P(NI+1,3)=PZ
69710 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
69711 P(NI+2,1)=0.0D0
69712 P(NI+2,2)=0.0D0
69713 P(NI+2,3)=-PZ
69714 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
69715 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
69716 CALL PYROBO(NI+1,NI+2,THE,PHI,
69717 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
69718
69719 DO 120 J=1,3
69720 P(NI+1,J)=P(NI+1,J)-P(I1,J)
69721 P(NI+2,J)=P(NI+2,J)-P(I2,J)
69722 120 CONTINUE
69723
69724 RETURN
69725 END
69726
69727C*********************************************************************
69728
69729C...PYMASS
69730C...Gives the mass of a particle/parton.
69731
69732 FUNCTION PYMASS(KF)
69733
69734C...Double precision and integer declarations.
69735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69736 IMPLICIT INTEGER(I-N)
69737 INTEGER PYK,PYCHGE,PYCOMP
69738C...Commonblocks.
69739 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69740 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69741 SAVE /PYDAT1/,/PYDAT2/
69742
69743C...Reset variables. Compressed code. Special case for popcorn diquarks.
69744 PYMASS=0D0
69745 KFA=IABS(KF)
69746 KC=PYCOMP(KF)
69747 IF(KC.EQ.0) THEN
69748 MSTJ(93)=0
69749 RETURN
69750 ENDIF
69751
69752C...Guarantee use of constituent masses for internal checks.
69753 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
69754 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
69755 IF(KFA.LE.5) THEN
69756 PYMASS=PARF(100+KFA)
69757 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
69758 ELSEIF(KFA.LE.10) THEN
69759 PYMASS=PMAS(KFA,1)
69760 ELSEIF(MSTJ(93).EQ.1) THEN
69761 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
69762 ELSE
69763 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
69764 ENDIF
69765
69766C...Other masses can be read directly off table.
69767 ELSE
69768 PYMASS=PMAS(KC,1)
69769 ENDIF
69770
69771C...Optional mass broadening according to truncated Breit-Wigner
69772C...(either in m or in m^2).
69773 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
69774 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
69775 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
69776 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
69777 ELSE
69778 PM0=PYMASS
69779 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
69780 & (PM0*PMAS(KC,2)))
69781 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
69782 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
69783 & (PMUPP-PMLOW)*PYR(0))))
69784 ENDIF
69785 ENDIF
69786 MSTJ(93)=0
69787
69788 RETURN
69789 END
69790
69791C*********************************************************************
69792
69793C...PYMRUN
69794C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
69795C...for Higgs couplings. Everything else sent on to PYMASS.
69796
69797 FUNCTION PYMRUN(KF,Q2)
69798
69799C...Double precision and integer declarations.
69800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69801 IMPLICIT INTEGER(I-N)
69802 INTEGER PYK,PYCHGE,PYCOMP
69803C...Commonblocks.
69804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69806 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69807 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
69808
69809C...Most masses not handled here.
69810 KFA=IABS(KF)
69811 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
69812 PYMRUN=PYMASS(KF)
69813
69814C...Current-algebra masses, but no Q2 dependence.
69815 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
69816 PYMRUN=PARF(90+KFA)
69817
69818C...Running current-algebra masses.
69819 ELSE
69820 AS=PYALPS(Q2)
69821 PYMRUN=PARF(90+KFA)*
69822 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
69823 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
69824 ENDIF
69825
69826 RETURN
69827 END
69828
69829C*********************************************************************
69830
69831C...PYNAME
69832C...Gives the particle/parton name as a character string.
69833
69834 SUBROUTINE PYNAME(KF,CHAU)
69835
69836C...Double precision and integer declarations.
69837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69838 IMPLICIT INTEGER(I-N)
69839 INTEGER PYK,PYCHGE,PYCOMP
69840C...Commonblocks.
69841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69843 COMMON/PYDAT4/CHAF(500,2)
69844 CHARACTER CHAF*16
69845 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
69846C...Local character variable.
69847 CHARACTER CHAU*16
69848
69849C...Read out code with distinction particle/antiparticle.
69850 CHAU=' '
69851 KC=PYCOMP(KF)
69852 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
69853
69854
69855 RETURN
69856 END
69857
69858C*********************************************************************
69859
69860C...PYCHGE
69861C...Gives three times the charge for a particle/parton.
69862
69863 FUNCTION PYCHGE(KF)
69864
69865C...Double precision and integer declarations.
69866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69867 IMPLICIT INTEGER(I-N)
69868 INTEGER PYK,PYCHGE,PYCOMP
69869C...Commonblocks.
69870 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69871 SAVE /PYDAT2/
69872
69873C...Read out charge and change sign for antiparticle.
69874 PYCHGE=0
69875 KC=PYCOMP(KF)
69876 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
69877
69878 RETURN
69879 END
69880
69881C*********************************************************************
69882
69883C...PYCOMP
69884C...Compress the standard KF codes for use in mass and decay arrays;
69885C...also checks whether a given code actually is defined.
69886
69887 FUNCTION PYCOMP(KF)
69888
69889C...Double precision and integer declarations.
69890 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69891 IMPLICIT INTEGER(I-N)
69892 INTEGER PYK,PYCHGE,PYCOMP
69893C...Commonblocks.
69894 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69895 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69896 SAVE /PYDAT1/,/PYDAT2/
69897C...Local arrays and saved data.
69898 DIMENSION KFORD(100:500),KCORD(101:500)
69899 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
69900
69901C...Whenever necessary reorder codes for faster search.
69902 IF(MSTU(20).EQ.0) THEN
69903 NFORD=100
69904 KFORD(100)=0
69905 DO 120 I=101,500
69906 KFA=KCHG(I,4)
69907 IF(KFA.LE.100) GOTO 120
69908 NFORD=NFORD+1
69909 DO 100 I1=NFORD-1,0,-1
69910 IF(KFA.GE.KFORD(I1)) GOTO 110
69911 KFORD(I1+1)=KFORD(I1)
69912 KCORD(I1+1)=KCORD(I1)
69913 100 CONTINUE
69914 110 KFORD(I1+1)=KFA
69915 KCORD(I1+1)=I
69916 120 CONTINUE
69917 MSTU(20)=1
69918 KFLAST=0
69919 KCLAST=0
69920 ENDIF
69921
69922C...Fast action if same code as in latest call.
69923 IF(KF.EQ.KFLAST) THEN
69924 PYCOMP=KCLAST
69925 RETURN
69926 ENDIF
69927
69928C...Starting values. Remove internal diquark flags.
69929 PYCOMP=0
69930 KFA=IABS(KF)
69931 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
69932 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
69933
69934C...Simple cases: direct translation.
69935 IF(KFA.GT.KFORD(NFORD)) THEN
69936 ELSEIF(KFA.LE.100) THEN
69937 PYCOMP=KFA
69938
69939C...Else binary search.
69940 ELSE
69941 IMIN=100
69942 IMAX=NFORD+1
69943 130 IAVG=(IMIN+IMAX)/2
69944 IF(KFORD(IAVG).GT.KFA) THEN
69945 IMAX=IAVG
69946 IF(IMAX.GT.IMIN+1) GOTO 130
69947 ELSEIF(KFORD(IAVG).LT.KFA) THEN
69948 IMIN=IAVG
69949 IF(IMAX.GT.IMIN+1) GOTO 130
69950 ELSE
69951 PYCOMP=KCORD(IAVG)
69952 ENDIF
69953 ENDIF
69954
69955C...Check if antiparticle allowed.
69956 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
69957 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
69958 ENDIF
69959
69960C...Save codes for possible future fast action.
69961 KFLAST=KF
69962 KCLAST=PYCOMP
69963
69964 RETURN
69965 END
69966
69967C*********************************************************************
69968
69969C...PYERRM
69970C...Informs user of errors in program execution.
69971
69972 SUBROUTINE PYERRM(MERR,CHMESS)
69973
69974C...Double precision and integer declarations.
69975 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69976 IMPLICIT INTEGER(I-N)
69977 INTEGER PYK,PYCHGE,PYCOMP
69978C...Commonblocks.
69979 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69980 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69981 SAVE /PYJETS/,/PYDAT1/
69982C...Local character variable.
69983 CHARACTER CHMESS*(*)
69984
69985C...Write first few warnings, then be silent.
69986 IF(MERR.LE.10) THEN
69987 MSTU(27)=MSTU(27)+1
69988 MSTU(28)=MERR
69989 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
69990 & MERR,MSTU(31),CHMESS
69991
69992C...Write first few errors, then be silent or stop program.
69993 ELSEIF(MERR.LE.20) THEN
69994 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
69995 MSTU(30)=MSTU(30)+1
69996 MSTU(24)=MERR-10
69997 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
69998 & MERR-10,MSTU(31),CHMESS
69999 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
70000 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
70001 WRITE(MSTU(11),5200)
70002 IF(MERR.NE.17) CALL PYLIST(2)
70003 CALL PYSTOP(3)
70004 ENDIF
70005
70006C...Stop program in case of irreparable error.
70007 ELSE
70008 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
70009 CALL PYSTOP(3)
70010 ENDIF
70011
70012C...Formats for output.
70013 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
70014 &' PYEXEC calls:'/5X,A)
70015 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
70016 &' PYEXEC calls:'/5X,A)
70017 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
70018 &'event!')
70019 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
70020 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
70021
70022 RETURN
70023 END
70024
70025C*********************************************************************
70026
70027C...PYALEM
70028C...Calculates the running alpha_electromagnetic.
70029
70030 FUNCTION PYALEM(Q2)
70031
70032C...Double precision and integer declarations.
70033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70034 IMPLICIT INTEGER(I-N)
70035 INTEGER PYK,PYCHGE,PYCOMP
70036C...Commonblocks.
70037 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70038 SAVE /PYDAT1/
70039
70040C...Calculate real part of photon vacuum polarization.
70041C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
70042C...For hadrons use parametrization of H. Burkhardt et al.
70043C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
70044 AEMPI=PARU(101)/(3D0*PARU(1))
70045 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
70046 RPIGG=0D0
70047 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
70048 RPIGG=0D0
70049 ELSEIF(MSTU(101).EQ.2) THEN
70050 RPIGG=1D0-PARU(101)/PARU(103)
70051 ELSEIF(Q2.LT.0.09D0) THEN
70052 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
70053 ELSEIF(Q2.LT.9D0) THEN
70054 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
70055 & 0.00238D0*LOG(1D0+3.927D0*Q2)
70056 ELSEIF(Q2.LT.1D4) THEN
70057 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
70058 & 0.00299D0*LOG(1D0+Q2)
70059 ELSE
70060 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
70061 & 0.00293D0*LOG(1D0+Q2)
70062 ENDIF
70063
70064C...Calculate running alpha_em.
70065 PYALEM=PARU(101)/(1D0-RPIGG)
70066 PARU(108)=PYALEM
70067
70068 RETURN
70069 END
70070
70071C*********************************************************************
70072
70073C...PYALPS
70074C...Gives the value of alpha_strong.
70075
70076 FUNCTION PYALPS(Q2)
70077
70078C...Double precision and integer declarations.
70079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70080 IMPLICIT INTEGER(I-N)
70081 INTEGER PYK,PYCHGE,PYCOMP
70082C...Commonblocks.
70083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70084 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70085 SAVE /PYDAT1/,/PYDAT2/
70086C...Coefficients for second-order threshold matching.
70087C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
70088 DIMENSION STEPDN(6),STEPUP(6)
70089c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
70090c &(2D0*321D0/3703D0),0D0/
70091c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
70092c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
70093 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
70094 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
70095
70096C...Constant alpha_strong trivial. Pick artificial Lambda.
70097 IF(MSTU(111).LE.0) THEN
70098 PYALPS=PARU(111)
70099 MSTU(118)=MSTU(112)
70100 PARU(117)=0.2D0
70101 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
70102 & ((33D0-2D0*MSTU(112))*PARU(111)))
70103 PARU(118)=PARU(111)
70104 RETURN
70105 ENDIF
70106
70107C...Find effective Q2, number of flavours and Lambda.
70108 Q2EFF=Q2
70109 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
70110 NF=MSTU(112)
70111 ALAM2=PARU(112)**2
70112 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
70113 Q2THR=PARU(113)*PMAS(NF,1)**2
70114 IF(Q2EFF.LT.Q2THR) THEN
70115 NF=NF-1
70116 Q2RAT=Q2THR/ALAM2
70117 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
70118 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
70119 GOTO 100
70120 ENDIF
70121 ENDIF
70122 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
70123 Q2THR=PARU(113)*PMAS(NF+1,1)**2
70124 IF(Q2EFF.GT.Q2THR) THEN
70125 NF=NF+1
70126 Q2RAT=Q2THR/ALAM2
70127 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
70128 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
70129 GOTO 110
70130 ENDIF
70131 ENDIF
70132 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
70133 PARU(117)=SQRT(ALAM2)
70134
70135C...Evaluate first or second order alpha_strong.
70136 B0=(33D0-2D0*NF)/6D0
70137 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
70138 IF(MSTU(111).EQ.1) THEN
70139 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
70140 ELSE
70141 B1=(153D0-19D0*NF)/6D0
70142 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
70143 & (B0**2*ALGQ)))
70144 ENDIF
70145 MSTU(118)=NF
70146 PARU(118)=PYALPS
70147
70148 RETURN
70149 END
70150
70151C*********************************************************************
70152
70153C...PYANGL
70154C...Reconstructs an angle from given x and y coordinates.
70155
70156 FUNCTION PYANGL(X,Y)
70157
70158C...Double precision and integer declarations.
70159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70160 IMPLICIT INTEGER(I-N)
70161 INTEGER PYK,PYCHGE,PYCOMP
70162C...Commonblocks.
70163 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70164 SAVE /PYDAT1/
70165
70166 PYANGL=0D0
70167 R=SQRT(X**2+Y**2)
70168 IF(R.LT.1D-20) RETURN
70169 IF(ABS(X)/R.LT.0.8D0) THEN
70170 PYANGL=SIGN(ACOS(X/R),Y)
70171 ELSE
70172 PYANGL=ASIN(Y/R)
70173 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
70174 PYANGL=PARU(1)-PYANGL
70175 ELSEIF(X.LT.0D0) THEN
70176 PYANGL=-PARU(1)-PYANGL
70177 ENDIF
70178 ENDIF
70179
70180 RETURN
70181 END
70182
70183C*********************************************************************
70184
70185C...PYROBO
70186C...Performs rotations and boosts.
70187
70188 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
70189
70190C...Double precision and integer declarations.
70191 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70192 IMPLICIT INTEGER(I-N)
70193 INTEGER PYK,PYCHGE,PYCOMP
70194C...Commonblocks.
70195 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70196 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70197 SAVE /PYJETS/,/PYDAT1/
70198C...Local arrays.
70199 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
70200
70201C...Find and check range of rotation/boost.
70202 IMIN=IMI
70203 IF(IMIN.LE.0) IMIN=1
70204 IF(MSTU(1).GT.0) IMIN=MSTU(1)
70205 IMAX=IMA
70206 IF(IMAX.LE.0) IMAX=N
70207 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70208 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
70209 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
70210 RETURN
70211 ENDIF
70212
70213C...Optional resetting of V (when not set before.)
70214 IF(MSTU(33).NE.0) THEN
70215 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
70216 DO 100 J=1,5
70217 V(I,J)=0D0
70218 100 CONTINUE
70219 110 CONTINUE
70220 MSTU(33)=0
70221 ENDIF
70222
70223C...Rotate, typically from z axis to direction (theta,phi).
70224 IF(THE**2+PHI**2.GT.1D-20) THEN
70225 ROT(1,1)=COS(THE)*COS(PHI)
70226 ROT(1,2)=-SIN(PHI)
70227 ROT(1,3)=SIN(THE)*COS(PHI)
70228 ROT(2,1)=COS(THE)*SIN(PHI)
70229 ROT(2,2)=COS(PHI)
70230 ROT(2,3)=SIN(THE)*SIN(PHI)
70231 ROT(3,1)=-SIN(THE)
70232 ROT(3,2)=0D0
70233 ROT(3,3)=COS(THE)
70234 DO 140 I=IMIN,IMAX
70235 IF(K(I,1).LE.0) GOTO 140
70236 DO 120 J=1,3
70237 PR(J)=P(I,J)
70238 VR(J)=V(I,J)
70239 120 CONTINUE
70240 DO 130 J=1,3
70241 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
70242 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
70243 130 CONTINUE
70244 140 CONTINUE
70245 ENDIF
70246
70247C...Boost, typically from rest to momentum/energy=beta.
70248 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
70249 DBX=BEX
70250 DBY=BEY
70251 DBZ=BEZ
70252 DB=SQRT(DBX**2+DBY**2+DBZ**2)
70253 EPS1=1D0-1D-12
70254 IF(DB.GT.EPS1) THEN
70255C...Rescale boost vector if too close to unity.
70256 CALL PYERRM(3,'(PYROBO:) boost vector too large')
70257 DBX=DBX*(EPS1/DB)
70258 DBY=DBY*(EPS1/DB)
70259 DBZ=DBZ*(EPS1/DB)
70260 DB=EPS1
70261 ENDIF
70262 DGA=1D0/SQRT(1D0-DB**2)
70263 DO 160 I=IMIN,IMAX
70264 IF(K(I,1).LE.0) GOTO 160
70265 DO 150 J=1,4
70266 DP(J)=P(I,J)
70267 DV(J)=V(I,J)
70268 150 CONTINUE
70269 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
70270 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
70271 P(I,1)=DP(1)+DGABP*DBX
70272 P(I,2)=DP(2)+DGABP*DBY
70273 P(I,3)=DP(3)+DGABP*DBZ
70274 P(I,4)=DGA*(DP(4)+DBP)
70275 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
70276 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
70277 V(I,1)=DV(1)+DGABV*DBX
70278 V(I,2)=DV(2)+DGABV*DBY
70279 V(I,3)=DV(3)+DGABV*DBZ
70280 V(I,4)=DGA*(DV(4)+DBV)
70281 160 CONTINUE
70282 ENDIF
70283
70284 RETURN
70285 END
70286
70287C*********************************************************************
70288
70289C...PYEDIT
70290C...Performs global manipulations on the event record, in particular
70291C...to exclude unstable or undetectable partons/particles.
70292
70293 SUBROUTINE PYEDIT(MEDIT)
70294
70295C...Double precision and integer declarations.
70296 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70297 IMPLICIT INTEGER(I-N)
70298 INTEGER PYK,PYCHGE,PYCOMP
70299C...Parameter statement to help give large particle numbers.
70300 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70301 &KEXCIT=4000000,KDIMEN=5000000)
70302C...Commonblocks.
70303 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70306 COMMON/PYCTAG/NCT,MCT(4000,2)
70307 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
70308C...Local arrays.
70309 DIMENSION NS(2),PTS(2),PLS(2)
70310
70311C...Remove unwanted partons/particles.
70312 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
70313 IMAX=N
70314 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70315 I1=MAX(1,MSTU(1))-1
70316 DO 110 I=MAX(1,MSTU(1)),IMAX
70317 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
70318 IF(MEDIT.EQ.1) THEN
70319 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70320 ELSEIF(MEDIT.EQ.2) THEN
70321 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70322 KC=PYCOMP(K(I,2))
70323 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70324 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70325 & K(I,2).EQ.KSUSY1+39) GOTO 110
70326 ELSEIF(MEDIT.EQ.3) THEN
70327 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70328 KC=PYCOMP(K(I,2))
70329 IF(KC.EQ.0) GOTO 110
70330 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
70331 ELSEIF(MEDIT.EQ.5) THEN
70332 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
70333 KC=PYCOMP(K(I,2))
70334 IF(KC.EQ.0) GOTO 110
70335 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
70336 & KCHG(KC,2).EQ.0) GOTO 110
70337 ENDIF
70338
70339C...Pack remaining partons/particles. Origin no longer known.
70340 I1=I1+1
70341 DO 100 J=1,5
70342 K(I1,J)=K(I,J)
70343 P(I1,J)=P(I,J)
70344 V(I1,J)=V(I,J)
70345 100 CONTINUE
70346 K(I1,3)=0
70347 110 CONTINUE
70348 IF(I1.LT.N) MSTU(3)=0
70349 IF(I1.LT.N) MSTU(70)=0
70350 N=I1
70351
70352C...Selective removal of class of entries. New position of retained.
70353 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
70354 I1=0
70355 DO 120 I=1,N
70356 K(I,3)=MOD(K(I,3),MSTU(5))
70357 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
70358 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
70359 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
70360 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
70361 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
70362 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
70363 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
70364 I1=I1+1
70365 K(I,3)=K(I,3)+MSTU(5)*I1
70366 120 CONTINUE
70367
70368C...Find new event history information and replace old.
70369 DO 140 I=1,N
70370 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
70371 & K(I,3)/MSTU(5).EQ.0) GOTO 140
70372 ID=I
70373 130 IM=MOD(K(ID,3),MSTU(5))
70374 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
70375 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
70376 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
70377 ID=IM
70378 GOTO 130
70379 ENDIF
70380 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
70381 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
70382 & K(IM,2).EQ.94) THEN
70383 ID=IM
70384 GOTO 130
70385 ENDIF
70386 ENDIF
70387 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
70388 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
70389 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
70390 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
70391 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
70392 & K(K(I,4),3)/MSTU(5)
70393 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
70394 & K(K(I,5),3)/MSTU(5)
70395 ELSE
70396 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
70397 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
70398 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
70399 KCD=MOD(K(I,4),MSTU(5))
70400 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70401 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70402 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
70403 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
70404 KCD=MOD(K(I,5),MSTU(5))
70405 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70406 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70407 ENDIF
70408 140 CONTINUE
70409
70410C...Pack remaining entries.
70411 I1=0
70412 MSTU90=MSTU(90)
70413 MSTU(90)=0
70414 DO 170 I=1,N
70415 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
70416 I1=I1+1
70417 DO 150 J=1,5
70418 K(I1,J)=K(I,J)
70419 P(I1,J)=P(I,J)
70420 V(I1,J)=V(I,J)
70421 150 CONTINUE
70422C...Also update LHA1 colour tags
70423 MCT(I1,1)=MCT(I,1)
70424 MCT(I1,2)=MCT(I,2)
70425 K(I1,3)=MOD(K(I1,3),MSTU(5))
70426 DO 160 IZ=1,MSTU90
70427 IF(I.EQ.MSTU(90+IZ)) THEN
70428 MSTU(90)=MSTU(90)+1
70429 MSTU(90+MSTU(90))=I1
70430 PARU(90+MSTU(90))=PARU(90+IZ)
70431 ENDIF
70432 160 CONTINUE
70433 170 CONTINUE
70434 IF(I1.LT.N) MSTU(3)=0
70435 IF(I1.LT.N) MSTU(70)=0
70436 N=I1
70437
70438C...Fill in some missing daughter pointers (lost in colour flow).
70439 ELSEIF(MEDIT.EQ.16) THEN
70440 DO 220 I=1,N
70441 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
70442 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
70443C...Find daughters who point to mother.
70444 DO 180 I1=I+1,N
70445 IF(K(I1,3).NE.I) THEN
70446 ELSEIF(K(I,4).EQ.0) THEN
70447 K(I,4)=I1
70448 ELSE
70449 K(I,5)=I1
70450 ENDIF
70451 180 CONTINUE
70452 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70453 IF(K(I,4).NE.0) GOTO 220
70454C...Find daughters who point to documentation version of mother.
70455 IM=K(I,3)
70456 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
70457 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
70458 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
70459 DO 190 I1=I+1,N
70460 IF(K(I1,3).NE.IM) THEN
70461 ELSEIF(K(I,4).EQ.0) THEN
70462 K(I,4)=I1
70463 ELSE
70464 K(I,5)=I1
70465 ENDIF
70466 190 CONTINUE
70467 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70468 IF(K(I,4).NE.0) GOTO 220
70469C...Find daughters who point to documentation daughters who,
70470C...in their turn, point to documentation mother.
70471 ID1=IM
70472 ID2=IM
70473 DO 200 I1=IM+1,I-1
70474 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
70475 ID2=I1
70476 IF(ID1.EQ.IM) ID1=I1
70477 ENDIF
70478 200 CONTINUE
70479 DO 210 I1=I+1,N
70480 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
70481 ELSEIF(K(I,4).EQ.0) THEN
70482 K(I,4)=I1
70483 ELSE
70484 K(I,5)=I1
70485 ENDIF
70486 210 CONTINUE
70487 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70488 220 CONTINUE
70489
70490C...Save top entries at bottom of PYJETS commonblock.
70491 ELSEIF(MEDIT.EQ.21) THEN
70492 IF(2*N.GE.MSTU(4)) THEN
70493 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
70494 RETURN
70495 ENDIF
70496 DO 240 I=1,N
70497 DO 230 J=1,5
70498 K(MSTU(4)-I,J)=K(I,J)
70499 P(MSTU(4)-I,J)=P(I,J)
70500 V(MSTU(4)-I,J)=V(I,J)
70501 230 CONTINUE
70502 240 CONTINUE
70503 MSTU(32)=N
70504
70505C...Restore bottom entries of commonblock PYJETS to top.
70506 ELSEIF(MEDIT.EQ.22) THEN
70507 DO 260 I=1,MSTU(32)
70508 DO 250 J=1,5
70509 K(I,J)=K(MSTU(4)-I,J)
70510 P(I,J)=P(MSTU(4)-I,J)
70511 V(I,J)=V(MSTU(4)-I,J)
70512 250 CONTINUE
70513 260 CONTINUE
70514 N=MSTU(32)
70515
70516C...Mark primary entries at top of commonblock PYJETS as untreated.
70517 ELSEIF(MEDIT.EQ.23) THEN
70518 I1=0
70519 DO 270 I=1,N
70520 KH=K(I,3)
70521 IF(KH.GE.1) THEN
70522 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
70523 ENDIF
70524 IF(KH.NE.0) GOTO 280
70525 I1=I1+1
70526 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
70527 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
70528 270 CONTINUE
70529 280 N=I1
70530
70531C...Place largest axis along z axis and second largest in xy plane.
70532 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
70533 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
70534 & P(MSTU(61),2)),0D0,0D0,0D0)
70535 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
70536 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
70537 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
70538 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
70539 IF(MEDIT.EQ.31) RETURN
70540
70541C...Rotate to put slim jet along +z axis.
70542 DO 290 IS=1,2
70543 NS(IS)=0
70544 PTS(IS)=0D0
70545 PLS(IS)=0D0
70546 290 CONTINUE
70547 DO 300 I=1,N
70548 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
70549 IF(MSTU(41).GE.2) THEN
70550 KC=PYCOMP(K(I,2))
70551 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70552 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70553 & K(I,2).EQ.KSUSY1+39) GOTO 300
70554 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70555 & .EQ.0) GOTO 300
70556 ENDIF
70557 IS=2D0-SIGN(0.5D0,P(I,3))
70558 NS(IS)=NS(IS)+1
70559 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
70560 300 CONTINUE
70561 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
70562 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
70563
70564C...Rotate to put second largest jet into -z,+x quadrant.
70565 DO 310 I=1,N
70566 IF(P(I,3).GE.0D0) GOTO 310
70567 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
70568 IF(MSTU(41).GE.2) THEN
70569 KC=PYCOMP(K(I,2))
70570 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70571 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70572 & K(I,2).EQ.KSUSY1+39) GOTO 310
70573 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70574 & .EQ.0) GOTO 310
70575 ENDIF
70576 IS=2D0-SIGN(0.5D0,P(I,1))
70577 PLS(IS)=PLS(IS)-P(I,3)
70578 310 CONTINUE
70579 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
70580 & 0D0,0D0,0D0)
70581 ENDIF
70582
70583 RETURN
70584 END
70585
70586C*********************************************************************
70587
70588C...PYLIST
70589C...Gives program heading, or lists an event, or particle
70590C...data, or current parameter values.
70591
70592 SUBROUTINE PYLIST(MLIST)
70593
70594C...Double precision and integer declarations.
70595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70596 IMPLICIT INTEGER(I-N)
70597 INTEGER PYK,PYCHGE,PYCOMP
70598C...Parameter statement to help give large particle numbers.
70599 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70600 &KEXCIT=4000000,KDIMEN=5000000)
70601
70602C...HEPEVT commonblock.
70603 PARAMETER (NMXHEP=4000)
70604 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
70605 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
70606 DOUBLE PRECISION PHEP,VHEP
70607 SAVE /HEPEVT/
70608
70609C...User process event common block.
70610 INTEGER MAXNUP
70611 PARAMETER (MAXNUP=500)
70612 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
70613 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
70614 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
70615 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
70616 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
70617 SAVE /HEPEUP/
70618
70619C...Commonblocks.
70620 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70621 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70622 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70623 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
70624 COMMON/PYCTAG/NCT,MCT(4000,2)
70625 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
70626C...Local arrays, character variables and data.
70627 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
70628 DIMENSION PS(6)
70629 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
70630
70631C...Initialization printout: version number and date of last change.
70632 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
70633 CALL PYLOGO
70634 MSTU(12)=12345
70635 IF(MLIST.EQ.0) RETURN
70636 ENDIF
70637
70638C...List event data, including additional lines after N.
70639 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
70640 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
70641 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
70642 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
70643 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
70644 LMX=12
70645 IF(MLIST.GE.2) LMX=16
70646 ISTR=0
70647 IMAX=N
70648 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70649 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
70650 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
70651 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
70652 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
70653
70654C...Get particle name, pad it and check it is not too long.
70655 CALL PYNAME(K(I,2),CHAP)
70656 LEN=0
70657 DO 100 LEM=1,16
70658 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
70659 100 CONTINUE
70660 MDL=(K(I,1)+19)/10
70661 LDL=0
70662 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
70663 CHAC=CHAP
70664 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
70665 ELSE
70666 LDL=1
70667 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
70668 IF(LEN.EQ.0) THEN
70669 CHAC=CHDL(MDL)(1:2*LDL)//' '
70670 ELSE
70671 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
70672 & CHDL(MDL)(LDL+1:2*LDL)//' '
70673 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
70674 ENDIF
70675 ENDIF
70676
70677C...Add information on string connection.
70678 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
70679 & THEN
70680 KC=PYCOMP(K(I,2))
70681 KCC=0
70682 IF(KC.NE.0) KCC=KCHG(KC,2)
70683 IF(IABS(K(I,2)).EQ.39) THEN
70684 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
70685 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
70686 ISTR=1
70687 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
70688 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
70689 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
70690 ELSEIF(KCC.NE.0) THEN
70691 ISTR=0
70692 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
70693 ENDIF
70694 ENDIF
70695 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
70696 & CHAC(LMX-1:LMX-1)='I'
70697
70698C...Write data for particle/jet.
70699 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
70700 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
70701 & (P(I,J2),J2=1,5)
70702 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
70703 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
70704 & (P(I,J2),J2=1,5)
70705 ELSEIF(MLIST.EQ.1) THEN
70706 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
70707 & (P(I,J2),J2=1,5)
70708 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
70709 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
70710 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
70711 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70712 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
70713 & (P(I,J2),J2=1,5)
70714 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
70715 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70716 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
70717 & ,10000),MCT(I,1),MCT(I,2)
70718 ELSE
70719 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
70720 & (P(I,J2),J2=1,5)
70721 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
70722 & ,MCT(I,1),MCT(I,2)
70723 ENDIF
70724 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
70725
70726C...Insert extra separator lines specified by user.
70727 IF(MSTU(70).GE.1) THEN
70728 ISEP=0
70729 DO 110 J=1,MIN(10,MSTU(70))
70730 IF(I.EQ.MSTU(70+J)) ISEP=1
70731 110 CONTINUE
70732 IF(ISEP.EQ.1) THEN
70733 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
70734 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
70735 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
70736 ENDIF
70737 ENDIF
70738 120 CONTINUE
70739
70740C...Sum of charges and momenta.
70741 DO 130 J=1,6
70742 PS(J)=PYP(0,J)
70743 130 CONTINUE
70744 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
70745 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
70746 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
70747 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
70748 ELSEIF(MLIST.EQ.1) THEN
70749 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
70750 ELSEIF(MLIST.LE.3) THEN
70751 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
70752 ELSE
70753 WRITE(MSTU(11),7000) PS(6)
70754 ENDIF
70755
70756C...Simple listing of HEPEVT entries (mainly for test purposes).
70757 ELSEIF(MLIST.EQ.5) THEN
70758 WRITE(MSTU(11),7100)
70759 DO 140 I=1,NHEP
70760 IF(ISTHEP(I).EQ.0) GOTO 140
70761 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
70762 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
70763 140 CONTINUE
70764
70765
70766C...Simple listing of user-process entries (mainly for test purposes).
70767 ELSEIF(MLIST.EQ.7) THEN
70768 WRITE(MSTU(11),7300)
70769 DO 150 I=1,NUP
70770 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
70771 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
70772 150 CONTINUE
70773
70774C...Give simple list of KF codes defined in program.
70775 ELSEIF(MLIST.EQ.11) THEN
70776 WRITE(MSTU(11),7500)
70777 DO 160 KF=1,80
70778 CALL PYNAME(KF,CHAP)
70779 CALL PYNAME(-KF,CHAN)
70780 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70781 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70782 160 CONTINUE
70783 DO 190 KFLS=1,3,2
70784 DO 180 KFLA=1,5
70785 DO 170 KFLB=1,KFLA-(3-KFLS)/2
70786 KF=1000*KFLA+100*KFLB+KFLS
70787 CALL PYNAME(KF,CHAP)
70788 CALL PYNAME(-KF,CHAN)
70789 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70790 170 CONTINUE
70791 180 CONTINUE
70792 190 CONTINUE
70793 DO 220 KMUL=0,5
70794 KFLS=3
70795 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
70796 IF(KMUL.EQ.5) KFLS=5
70797 KFLR=0
70798 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
70799 IF(KMUL.EQ.4) KFLR=2
70800 DO 210 KFLB=1,5
70801 DO 200 KFLC=1,KFLB-1
70802 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
70803 CALL PYNAME(KF,CHAP)
70804 CALL PYNAME(-KF,CHAN)
70805 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70806 IF(KF.EQ.311) THEN
70807 KFK=130
70808 CALL PYNAME(KFK,CHAP)
70809 WRITE(MSTU(11),7600) KFK,CHAP
70810 KFK=310
70811 CALL PYNAME(KFK,CHAP)
70812 WRITE(MSTU(11),7600) KFK,CHAP
70813 ENDIF
70814 200 CONTINUE
70815 KF=10000*KFLR+110*KFLB+KFLS
70816 CALL PYNAME(KF,CHAP)
70817 WRITE(MSTU(11),7600) KF,CHAP
70818 210 CONTINUE
70819 220 CONTINUE
70820 KF=100443
70821 CALL PYNAME(KF,CHAP)
70822 WRITE(MSTU(11),7600) KF,CHAP
70823 KF=100553
70824 CALL PYNAME(KF,CHAP)
70825 WRITE(MSTU(11),7600) KF,CHAP
70826 DO 260 KFLSP=1,3
70827 KFLS=2+2*(KFLSP/3)
70828 DO 250 KFLA=1,5
70829 DO 240 KFLB=1,KFLA
70830 DO 230 KFLC=1,KFLB
70831 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
70832 & GOTO 230
70833 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
70834 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
70835 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
70836 CALL PYNAME(KF,CHAP)
70837 CALL PYNAME(-KF,CHAN)
70838 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70839 230 CONTINUE
70840 240 CONTINUE
70841 250 CONTINUE
70842 260 CONTINUE
70843 DO 270 KC=1,500
70844 KF=KCHG(KC,4)
70845 IF(KF.LT.1000000) GOTO 270
70846 CALL PYNAME(KF,CHAP)
70847 CALL PYNAME(-KF,CHAN)
70848 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70849 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70850 270 CONTINUE
70851
70852C...List parton/particle data table. Check whether to be listed.
70853 ELSEIF(MLIST.EQ.12) THEN
70854 WRITE(MSTU(11),7700)
70855 DO 300 KC=1,MSTU(6)
70856 KF=KCHG(KC,4)
70857 IF(KF.EQ.0) GOTO 300
70858 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
70859 & GOTO 300
70860
70861C...Find particle name and mass. Print information.
70862 CALL PYNAME(KF,CHAP)
70863 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
70864 CALL PYNAME(-KF,CHAN)
70865 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
70866 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
70867
70868C...Particle decay: channel number, branching ratios, matrix element,
70869C...decay products.
70870 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
70871 DO 280 J=1,5
70872 CALL PYNAME(KFDP(IDC,J),CHAD(J))
70873 280 CONTINUE
70874 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
70875 & (CHAD(J),J=1,5)
70876 290 CONTINUE
70877 300 CONTINUE
70878
70879C...List parameter value table.
70880 ELSEIF(MLIST.EQ.13) THEN
70881 WRITE(MSTU(11),8000)
70882 DO 310 I=1,200
70883 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
70884 310 CONTINUE
70885 ENDIF
70886
70887C...Format statements for output on unit MSTU(11) (by default 6).
70888 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
70889 &5X,'KF orig p_x p_y p_z E m'/)
70890 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
70891 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70892 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
70893 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
70894 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70895 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
70896 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
70897 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
70898 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
70899 & ,' C tag AC tag'/)
70900 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
70901 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
70902 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
70903 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
70904 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
70905 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
70906 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
70907 6200 FORMAT(66X,5(1X,F12.3))
70908 6300 FORMAT(1X,78('='))
70909 6400 FORMAT(1X,130('='))
70910 6500 FORMAT(1X,65('='))
70911 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
70912 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
70913 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
70914 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
70915 &5F13.5)
70916 7000 FORMAT(19X,'sum charge:',F6.2)
70917 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
70918 &//' I IST ID Mothers Daughters p_x p_y p_z',
70919 &' E m')
70920 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
70921 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
70922 &//' I IST ID Mothers Colours p_x p_y p_z',
70923 &' E m')
70924 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
70925 7500 FORMAT(///20X,'List of KF codes in program'/)
70926 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
70927 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
70928 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
70929 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
70930 &1X,'ME',3X,'Br.rat.',4X,'decay products')
70931 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
70932 &1X,1P,E13.5,3X,I2)
70933 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
70934 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
70935 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
70936 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
70937
70938 RETURN
70939 END
70940
70941C*********************************************************************
70942
70943C...PYLOGO
70944C...Writes a logo for the program.
70945
70946 SUBROUTINE PYLOGO
70947
70948C...Double precision and integer declarations.
70949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70950 IMPLICIT INTEGER(I-N)
70951 INTEGER PYK,PYCHGE,PYCOMP
70952C...Parameter for length of information block.
70953 PARAMETER (IREFER=21)
70954C...Commonblocks.
70955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70956 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
70957 SAVE /PYDAT1/,/PYPARS/
70958C...Local arrays and character variables.
70959 INTEGER IDATI(6)
70960 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
70961 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
70962
70963C...Data on months, logo, titles, and references.
70964 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
70965 &'Oct','Nov','Dec'/
70966 DATA (LOGO(J),J=1,19)/
70967 &' *......* ',
70968 &' *:::!!:::::::::::* ',
70969 &' *::::::!!::::::::::::::* ',
70970 &' *::::::::!!::::::::::::::::* ',
70971 &' *:::::::::!!:::::::::::::::::* ',
70972 &' *:::::::::!!:::::::::::::::::* ',
70973 &' *::::::::!!::::::::::::::::*! ',
70974 &' *::::::!!::::::::::::::* !! ',
70975 &' !! *:::!!:::::::::::* !! ',
70976 &' !! !* -><- * !! ',
70977 &' !! !! !! ',
70978 &' !! !! !! ',
70979 &' !! !! ',
70980 &' !! lh !! ',
70981 &' !! !! ',
70982 &' !! hh !! ',
70983 &' !! ll !! ',
70984 &' !! !! ',
70985 &' !! '/
70986 DATA (LOGO(J),J=20,38)/
70987 &'Welcome to the Lund Monte Carlo!',
70988 &' ',
70989 &'PPP Y Y TTTTT H H III A ',
70990 &'P P Y Y T H H I A A ',
70991 &'PPP Y T HHHHH I AAAAA',
70992 &'P Y T H H I A A',
70993 &'P Y T H H III A A',
70994 &' ',
70995 &'This is PYTHIA version x.xxx ',
70996 &'Last date of change: xx xxx 200x',
70997 &' ',
70998 &'Now is xx xxx 200x at xx:xx:xx ',
70999 &' ',
71000 &'Disclaimer: this program comes ',
71001 &'without any guarantees. Beware ',
71002 &'of errors and use common sense ',
71003 &'when interpreting results. ',
71004 &' ',
71005 &'Copyright T. Sjostrand (2007) '/
71006 DATA (REFER(J),J=1,14)/
71007 &'An archive of program versions and d',
71008 &'ocumentation is found on the web: ',
71009 &'http://www.thep.lu.se/~torbjorn/Pyth',
71010 &'ia.html ',
71011 &' ',
71012 &' ',
71013 &'When you cite this program, the offi',
71014 &'cial reference is to the 6.4 manual:',
71015 &'T. Sjostrand, S. Mrenna and P. Skand',
71016 &'s, JHEP05 (2006) 026 ',
71017 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
71018 &'-T) [hep-ph/0603175]. ',
71019 &' ',
71020 &' '/
71021 DATA (REFER(J),J=15,32)/
71022 &'Also remember that the program, to a',
71023 &' large extent, represents original ',
71024 &'physics research. Other publications',
71025 &' of special relevance to your ',
71026 &'studies may therefore deserve separa',
71027 &'te mention. ',
71028 &' ',
71029 &' ',
71030 &'Main author: Torbjorn Sjostrand; CER',
71031 &'N/PH, CH-1211 Geneva, Switzerland, ',
71032 &' and Department of Theoretical Phys',
71033 &'ics, Lund University, Lund, Sweden; ',
71034 &' phone: + 41 - 22 - 767 82 27; e-ma',
71035 &'il: torbjorn@thep.lu.se ',
71036 &'Author: Stephen Mrenna; Computing Di',
71037 &'vision, GDS Group, ',
71038 &' Fermi National Accelerator Laborat',
71039 &'ory, MS 234, Batavia, IL 60510, USA;'/
71040 DATA (REFER(J),J=33,2*IREFER)/
71041 &' phone: + 1 - 630 - 840 - 2556; e-m',
71042 &'ail: mrenna@fnal.gov ',
71043 &'Author: Peter Skands; Theoretical Ph',
71044 &'ysics Department, ',
71045 &' Fermi National Accelerator Laborat',
71046 &'ory, MS 106, Batavia, IL 60510, USA;',
71047 &' and CERN/PH, CH-1211 Geneva, Switz',
71048 &'erland; ',
71049 &' phone: + 41 - 22 - 767 24 59; e-ma',
71050 &'il: skands@fnal.gov '/
71051
71052C...Check that PYDATA linked.
71053 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
71054 WRITE(*,'(1X,A)')
71055 & 'Error: PYDATA has not been linked.'
71056 WRITE(*,'(1X,A)') 'Execution stopped!'
71057 CALL PYSTOP(8)
71058
71059C...Write current version number and current date+time.
71060 ELSE
71061 WRITE(VERS,'(I1)') MSTP(181)
71062 LOGO(28)(24:24)=VERS
71063 WRITE(SUBV,'(I3)') MSTP(182)
71064 LOGO(28)(26:28)=SUBV
71065 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
71066 WRITE(DATE,'(I2)') MSTP(185)
71067 LOGO(29)(22:23)=DATE
71068 LOGO(29)(25:27)=MONTH(MSTP(184))
71069 WRITE(YEAR,'(I4)') MSTP(183)
71070 LOGO(29)(29:32)=YEAR
71071 CALL PYTIME(IDATI)
71072 IF(IDATI(1).LE.0) THEN
71073 LOGO(31)=' '
71074 ELSE
71075 WRITE(DATE,'(I2)') IDATI(3)
71076 LOGO(31)(8:9)=DATE
71077 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
71078 WRITE(YEAR,'(I4)') IDATI(1)
71079 LOGO(31)(15:18)=YEAR
71080 WRITE(HOUR,'(I2)') IDATI(4)
71081 LOGO(31)(23:24)=HOUR
71082 WRITE(MINU,'(I2)') IDATI(5)
71083 LOGO(31)(26:27)=MINU
71084 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
71085 WRITE(SECO,'(I2)') IDATI(6)
71086 LOGO(31)(29:30)=SECO
71087 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
71088 ENDIF
71089 ENDIF
71090
71091C...Loop over lines in header. Define page feed and side borders.
71092 DO 100 ILIN=1,29+IREFER
71093 LINE=' '
71094 IF(ILIN.EQ.1) THEN
71095 LINE(1:1)='1'
71096 ELSE
71097 LINE(2:3)='**'
71098 LINE(78:79)='**'
71099 ENDIF
71100
71101C...Separator lines and logos.
71102 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
71103 LINE(4:77)='***********************************************'//
71104 & '***************************'
71105 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
71106 LINE(6:37)=LOGO(ILIN-5)
71107 LINE(44:75)=LOGO(ILIN+14)
71108 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
71109 LINE(5:40)=REFER(2*ILIN-51)
71110 LINE(41:76)=REFER(2*ILIN-50)
71111 ENDIF
71112
71113C...Write lines to appropriate unit.
71114 WRITE(MSTU(11),'(A79)') LINE
71115 100 CONTINUE
71116
71117 RETURN
71118 END
71119
71120C*********************************************************************
71121
71122C...PYUPDA
71123C...Facilitates the updating of particle and decay data
71124C...by allowing it to be done in an external file.
71125
71126 SUBROUTINE PYUPDA(MUPDA,LFN)
71127
71128C...Double precision and integer declarations.
71129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71130 IMPLICIT INTEGER(I-N)
71131 INTEGER PYK,PYCHGE,PYCOMP
71132C...Commonblocks.
71133 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71134 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71135 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71136 COMMON/PYDAT4/CHAF(500,2)
71137 CHARACTER CHAF*16
71138 COMMON/PYINT4/MWID(500),WIDS(500,5)
71139 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
71140C...Local arrays, character variables and data.
71141 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
71142 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
71143 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
71144 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
71145 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
71146 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
71147 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
71148
71149C...Write header if not yet done.
71150 IF(MSTU(12).NE.12345) CALL PYLIST(0)
71151
71152C...Write information on file for editing.
71153 IF(MUPDA.EQ.1) THEN
71154 DO 110 KC=1,500
71155 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71156 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71157 & MWID(KC),MDCY(KC,1)
71158 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71159 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
71160 & (KFDP(IDC,J),J=1,5)
71161 100 CONTINUE
71162 110 CONTINUE
71163
71164C...Read complete set of information from edited file or
71165C...read partial set of new or updated information from edited file.
71166 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
71167
71168C...Reset counters.
71169 KCC=100
71170 NDC=0
71171 CHKF=' '
71172 IF(MUPDA.EQ.2) THEN
71173 DO 120 I=1,MSTU(6)
71174 KCHG(I,4)=0
71175 120 CONTINUE
71176 ELSE
71177 DO 130 KC=1,MSTU(6)
71178 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
71179 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
71180 130 CONTINUE
71181 ENDIF
71182
71183C...Begin of loop: read new line; unknown whether particle or
71184C...decay data.
71185 140 READ(LFN,5200,END=190) CHINL
71186
71187C...Identify particle code and whether already defined (for MUPDA=3).
71188 IF(CHINL(2:10).NE.' ') THEN
71189 CHKF=CHINL(2:10)
71190 READ(CHKF,5300) KF
71191 IF(MUPDA.EQ.2) THEN
71192 IF(KF.LE.100) THEN
71193 KC=KF
71194 ELSE
71195 KCC=KCC+1
71196 KC=KCC
71197 ENDIF
71198 ELSE
71199 KCREP=0
71200 IF(KF.LE.100) THEN
71201 KCREP=KF
71202 ELSE
71203 DO 150 KCR=101,KCC
71204 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
71205 150 CONTINUE
71206 ENDIF
71207C...Remove duplicate old decay data.
71208 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
71209 IDCREP=MDCY(KCREP,2)
71210 NDCREP=MDCY(KCREP,3)
71211 DO 160 I=1,KCC
71212 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
71213 160 CONTINUE
71214 DO 180 I=IDCREP,NDC-NDCREP
71215 MDME(I,1)=MDME(I+NDCREP,1)
71216 MDME(I,2)=MDME(I+NDCREP,2)
71217 BRAT(I)=BRAT(I+NDCREP)
71218 DO 170 J=1,5
71219 KFDP(I,J)=KFDP(I+NDCREP,J)
71220 170 CONTINUE
71221 180 CONTINUE
71222 NDC=NDC-NDCREP
71223 KC=KCREP
71224 ELSEIF(KCREP.NE.0) THEN
71225 KC=KCREP
71226 ELSE
71227 KCC=KCC+1
71228 KC=KCC
71229 ENDIF
71230 ENDIF
71231
71232C...Study line with particle data.
71233 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
71234 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
71235 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71236 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71237 & MWID(KC),MDCY(KC,1)
71238 MDCY(KC,2)=0
71239 MDCY(KC,3)=0
71240
71241C...Study line with decay data.
71242 ELSE
71243 NDC=NDC+1
71244 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
71245 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
71246 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
71247 MDCY(KC,3)=MDCY(KC,3)+1
71248 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
71249 & (KFDP(NDC,J),J=1,5)
71250 ENDIF
71251
71252C...End of loop; ensure that PYCOMP tables are updated.
71253 GOTO 140
71254 190 CONTINUE
71255 MSTU(20)=0
71256
71257C...Perform possible tests that new information is consistent.
71258 DO 220 KC=1,MSTU(6)
71259 KF=KCHG(KC,4)
71260 IF(KF.EQ.0) GOTO 220
71261 WRITE(CHKF,5300) KF
71262 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
71263 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
71264 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
71265 BRSUM=0D0
71266 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71267 IF(MDME(IDC,2).GT.80) GOTO 210
71268 KQ=KCHG(KC,1)
71269 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
71270 MERR=0
71271 DO 200 J=1,5
71272 KP=KFDP(IDC,J)
71273 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
71274 IF(KP.EQ.81) KQ=0
71275 ELSEIF(PYCOMP(KP).EQ.0) THEN
71276 MERR=3
71277 ELSE
71278 KQ=KQ-PYCHGE(KP)
71279 KPC=PYCOMP(KP)
71280 PMS=PMS-PMAS(KPC,1)
71281 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
71282 & PMAS(KPC,3))
71283 ENDIF
71284 200 CONTINUE
71285 IF(KQ.NE.0) MERR=MAX(2,MERR)
71286 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
71287 & MERR=MAX(1,MERR)
71288 IF(MERR.EQ.3) CALL PYERRM(17,
71289 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
71290 IF(MERR.EQ.2) CALL PYERRM(17,
71291 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
71292 IF(MERR.EQ.1) CALL PYERRM(7,
71293 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
71294 BRSUM=BRSUM+BRAT(IDC)
71295 210 CONTINUE
71296 WRITE(CHTMP,5500) BRSUM
71297 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
71298 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
71299 & CHTMP(9:16)//' for KF ='//CHKF)
71300 220 CONTINUE
71301
71302C...Write DATA statements for inclusion in program.
71303 ELSEIF(MUPDA.EQ.4) THEN
71304
71305C...Find out how many codes and decay channels are actually used.
71306 KCC=0
71307 NDC=0
71308 DO 230 I=1,MSTU(6)
71309 IF(KCHG(I,4).NE.0) THEN
71310 KCC=I
71311 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
71312 ENDIF
71313 230 CONTINUE
71314
71315C...Initialize writing of DATA statements for inclusion in program.
71316 DO 300 IVAR=1,22
71317 NDIM=MSTU(6)
71318 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
71319 NLIN=1
71320 CHLIN=' '
71321 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
71322 LLIN=35
71323 CHOLD='START'
71324
71325C...Loop through variables for conversion to characters.
71326 DO 280 IDIM=1,NDIM
71327 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
71328 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
71329 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
71330 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
71331 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
71332 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
71333 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
71334 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
71335 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
71336 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
71337 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
71338 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
71339 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
71340 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
71341 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
71342 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
71343 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
71344 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
71345 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
71346 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
71347 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
71348 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
71349
71350C...Replace variables beyond what is properly defined.
71351 IF(IVAR.LE.4) THEN
71352 IF(IDIM.GT.KCC) CHTMP=' 0'
71353 ELSEIF(IVAR.LE.8) THEN
71354 IF(IDIM.GT.KCC) CHTMP=' 0.0'
71355 ELSEIF(IVAR.LE.11) THEN
71356 IF(IDIM.GT.KCC) CHTMP=' 0'
71357 ELSEIF(IVAR.LE.13) THEN
71358 IF(IDIM.GT.NDC) CHTMP=' 0'
71359 ELSEIF(IVAR.LE.14) THEN
71360 IF(IDIM.GT.NDC) CHTMP=' 0.0'
71361 ELSEIF(IVAR.LE.19) THEN
71362 IF(IDIM.GT.NDC) CHTMP=' 0'
71363 ELSEIF(IVAR.LE.21) THEN
71364 IF(IDIM.GT.KCC) CHTMP=' '
71365 ELSE
71366 IF(IDIM.GT.KCC) CHTMP=' 0'
71367 ENDIF
71368
71369C...Length of variable, trailing decimal zeros, quotation marks.
71370 LLOW=1
71371 LHIG=1
71372 DO 240 LL=1,16
71373 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
71374 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
71375 240 CONTINUE
71376 CHNEW=CHTMP(LLOW:LHIG)//' '
71377 LNEW=1+LHIG-LLOW
71378 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
71379 LNEW=LNEW+1
71380 250 LNEW=LNEW-1
71381 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
71382 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
71383 IF(LNEW.EQ.0) THEN
71384 CHNEW(1:3)='0D0'
71385 LNEW=3
71386 ELSE
71387 CHNEW(LNEW+1:LNEW+2)='D0'
71388 LNEW=LNEW+2
71389 ENDIF
71390 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
71391 DO 260 LL=LNEW,1,-1
71392 IF(CHNEW(LL:LL).EQ.'''') THEN
71393 CHTMP=CHNEW
71394 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
71395 LNEW=LNEW+1
71396 ENDIF
71397 260 CONTINUE
71398 LNEW=MIN(14,LNEW)
71399 CHTMP=CHNEW
71400 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
71401 LNEW=LNEW+2
71402 ENDIF
71403
71404C...Form composite character string, often including repetition counter.
71405 IF(CHNEW.NE.CHOLD) THEN
71406 NRPT=1
71407 CHOLD=CHNEW
71408 CHCOM=CHNEW
71409 LCOM=LNEW
71410 ELSE
71411 LRPT=LNEW+1
71412 IF(NRPT.GE.2) LRPT=LNEW+3
71413 IF(NRPT.GE.10) LRPT=LNEW+4
71414 IF(NRPT.GE.100) LRPT=LNEW+5
71415 IF(NRPT.GE.1000) LRPT=LNEW+6
71416 LLIN=LLIN-LRPT
71417 NRPT=NRPT+1
71418 WRITE(CHTMP,5400) NRPT
71419 LRPT=1
71420 IF(NRPT.GE.10) LRPT=2
71421 IF(NRPT.GE.100) LRPT=3
71422 IF(NRPT.GE.1000) LRPT=4
71423 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
71424 LCOM=LRPT+1+LNEW
71425 ENDIF
71426
71427C...Add characters to end of line, to new line (after storing old line),
71428C...or to new block of lines (after writing old block).
71429 IF(LLIN+LCOM.LE.70) THEN
71430 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
71431 LLIN=LLIN+LCOM+1
71432 ELSEIF(NLIN.LE.19) THEN
71433 CHLIN(LLIN+1:72)=' '
71434 CHBLK(NLIN)=CHLIN
71435 NLIN=NLIN+1
71436 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
71437 LLIN=6+LCOM+1
71438 ELSE
71439 CHLIN(LLIN:72)='/'//' '
71440 CHBLK(NLIN)=CHLIN
71441 WRITE(CHTMP,5400) IDIM-NRPT
71442 CHBLK(1)(30:33)=CHTMP(13:16)
71443 DO 270 ILIN=1,NLIN
71444 WRITE(LFN,5700) CHBLK(ILIN)
71445 270 CONTINUE
71446 NLIN=1
71447 CHLIN=' '
71448 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
71449 & ',I= , )/'//CHCOM(1:LCOM)//','
71450 WRITE(CHTMP,5400) IDIM-NRPT+1
71451 CHLIN(25:28)=CHTMP(13:16)
71452 LLIN=35+LCOM+1
71453 ENDIF
71454 280 CONTINUE
71455
71456C...Write final block of lines.
71457 CHLIN(LLIN:72)='/'//' '
71458 CHBLK(NLIN)=CHLIN
71459 WRITE(CHTMP,5400) NDIM
71460 CHBLK(1)(30:33)=CHTMP(13:16)
71461 DO 290 ILIN=1,NLIN
71462 WRITE(LFN,5700) CHBLK(ILIN)
71463 290 CONTINUE
71464 300 CONTINUE
71465 ENDIF
71466
71467C...Formats for reading and writing particle data.
71468 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
71469 5100 FORMAT(10X,2I5,F12.6,5I10)
71470 5200 FORMAT(A120)
71471 5300 FORMAT(I9)
71472 5400 FORMAT(I16)
71473 5500 FORMAT(F16.5)
71474 5600 FORMAT(F16.6)
71475 5700 FORMAT(A72)
71476
71477 RETURN
71478 END
71479
71480C*********************************************************************
71481
71482C...PYK
71483C...Provides various integer-valued event related data.
71484
71485 FUNCTION PYK(I,J)
71486
71487C...Double precision and integer declarations.
71488 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71489 IMPLICIT INTEGER(I-N)
71490 INTEGER PYK,PYCHGE,PYCOMP
71491C...Commonblocks.
71492 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71495 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71496
71497C...Default value. For I=0 number of entries, number of stable entries
71498C...or 3 times total charge.
71499 PYK=0
71500 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71501 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
71502 PYK=N
71503 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
71504 DO 100 I1=1,N
71505 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
71506 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
71507 & PYCHGE(K(I1,2))
71508 100 CONTINUE
71509 ELSEIF(I.EQ.0) THEN
71510
71511C...For I > 0 direct readout of K matrix or charge.
71512 ELSEIF(J.LE.5) THEN
71513 PYK=K(I,J)
71514 ELSEIF(J.EQ.6) THEN
71515 PYK=PYCHGE(K(I,2))
71516
71517C...Status (existing/fragmented/decayed), parton/hadron separation.
71518 ELSEIF(J.LE.8) THEN
71519 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
71520 IF(J.EQ.8) PYK=PYK*K(I,2)
71521 ELSEIF(J.LE.12) THEN
71522 KFA=IABS(K(I,2))
71523 KC=PYCOMP(KFA)
71524 KQ=0
71525 IF(KC.NE.0) KQ=KCHG(KC,2)
71526 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
71527 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
71528 IF(J.EQ.11) PYK=KC
71529 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
71530
71531C...Heaviest flavour in hadron/diquark.
71532 ELSEIF(J.EQ.13) THEN
71533 KFA=IABS(K(I,2))
71534 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
71535 IF(KFA.LT.10) PYK=KFA
71536 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
71537 PYK=PYK*ISIGN(1,K(I,2))
71538
71539C...Particle history: generation, ancestor, rank.
71540 ELSEIF(J.LE.15) THEN
71541 I2=I
71542 I1=I
71543 110 PYK=PYK+1
71544 I2=I1
71545 I1=K(I1,3)
71546 IF(I1.GT.0) THEN
71547 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
71548 ENDIF
71549 IF(J.EQ.15) PYK=I2
71550 ELSEIF(J.EQ.16) THEN
71551 KFA=IABS(K(I,2))
71552 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
71553 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
71554 I1=I
71555 120 I2=I1
71556 I1=K(I1,3)
71557 IF(I1.GT.0) THEN
71558 KFAM=IABS(K(I1,2))
71559 ILP=1
71560 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
71561 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
71562 & ILP=0
71563 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
71564 IF(ILP.EQ.1) GOTO 120
71565 ENDIF
71566 IF(K(I1,1).EQ.12) THEN
71567 DO 130 I3=I1+1,I2
71568 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
71569 & .AND.K(I3,2).NE.93) PYK=PYK+1
71570 130 CONTINUE
71571 ELSE
71572 I3=I2
71573 140 PYK=PYK+1
71574 I3=I3+1
71575 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
71576 ENDIF
71577 ENDIF
71578
71579C...Particle coming from collapsing jet system or not.
71580 ELSEIF(J.EQ.17) THEN
71581 I1=I
71582 150 PYK=PYK+1
71583 I3=I1
71584 I1=K(I1,3)
71585 I0=MAX(1,I1)
71586 KC=PYCOMP(K(I0,2))
71587 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
71588 IF(PYK.EQ.1) PYK=-1
71589 IF(PYK.GT.1) PYK=0
71590 RETURN
71591 ENDIF
71592 IF(KCHG(KC,2).EQ.0) GOTO 150
71593 IF(K(I1,1).NE.12) PYK=0
71594 IF(K(I1,1).NE.12) RETURN
71595 I2=I1
71596 160 I2=I2+1
71597 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
71598 K3M=K(I3-1,3)
71599 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
71600 K3P=K(I3+1,3)
71601 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
71602
71603C...Number of decay products. Colour flow.
71604 ELSEIF(J.EQ.18) THEN
71605 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
71606 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
71607 ELSEIF(J.LE.22) THEN
71608 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
71609 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
71610 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
71611 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
71612 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
71613 ELSE
71614 ENDIF
71615
71616 RETURN
71617 END
71618
71619C*********************************************************************
71620
71621C...PYP
71622C...Provides various real-valued event related data.
71623
71624 FUNCTION PYP(I,J)
71625
71626C...Double precision and integer declarations.
71627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71628 IMPLICIT INTEGER(I-N)
71629 INTEGER PYK,PYCHGE,PYCOMP
71630C...Commonblocks.
71631 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71632 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71633 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71634 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71635C...Local array.
71636 DIMENSION PSUM(4)
71637
71638C...Set default value. For I = 0 sum of momenta or charges,
71639C...or invariant mass of system.
71640 PYP=0D0
71641 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71642 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
71643 DO 100 I1=1,N
71644 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
71645 100 CONTINUE
71646 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
71647 DO 120 J1=1,4
71648 PSUM(J1)=0D0
71649 DO 110 I1=1,N
71650 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
71651 & P(I1,J1)
71652 110 CONTINUE
71653 120 CONTINUE
71654 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71655 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
71656 DO 130 I1=1,N
71657 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
71658 130 CONTINUE
71659 ELSEIF(I.EQ.0) THEN
71660
71661C...Direct readout of P matrix.
71662 ELSEIF(J.LE.5) THEN
71663 PYP=P(I,J)
71664
71665C...Charge, total momentum, transverse momentum, transverse mass.
71666 ELSEIF(J.LE.12) THEN
71667 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
71668 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
71669 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
71670 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
71671 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
71672
71673C...Theta and phi angle in radians or degrees.
71674 ELSEIF(J.LE.16) THEN
71675 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
71676 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
71677 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
71678
71679C...True rapidity, rapidity with pion mass, pseudorapidity.
71680 ELSEIF(J.LE.19) THEN
71681 PMR=0D0
71682 IF(J.EQ.17) PMR=P(I,5)
71683 IF(J.EQ.18) PMR=PYMASS(211)
71684 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71685 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71686 & 1D20)),P(I,3))
71687
71688C...Energy and momentum fractions (only to be used in CM frame).
71689 ELSEIF(J.LE.25) THEN
71690 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
71691 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
71692 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
71693 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
71694 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
71695 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
71696 ENDIF
71697
71698 RETURN
71699 END
71700
71701C*********************************************************************
71702
71703C...PYSPHE
71704C...Performs sphericity tensor analysis to give sphericity,
71705C...aplanarity and the related event axes.
71706
71707 SUBROUTINE PYSPHE(SPH,APL)
71708
71709C...Double precision and integer declarations.
71710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71711 IMPLICIT INTEGER(I-N)
71712 INTEGER PYK,PYCHGE,PYCOMP
71713C...Parameter statement to help give large particle numbers.
71714 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71715 &KEXCIT=4000000,KDIMEN=5000000)
71716C...Commonblocks.
71717 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71718 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71719 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71720 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71721C...Local arrays.
71722 DIMENSION SM(3,3),SV(3,3)
71723
71724C...Calculate matrix to be diagonalized.
71725 NP=0
71726 DO 110 J1=1,3
71727 DO 100 J2=J1,3
71728 SM(J1,J2)=0D0
71729 100 CONTINUE
71730 110 CONTINUE
71731 PS=0D0
71732 DO 140 I=1,N
71733 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
71734 IF(MSTU(41).GE.2) THEN
71735 KC=PYCOMP(K(I,2))
71736 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71737 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71738 & K(I,2).EQ.KSUSY1+39) GOTO 140
71739 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71740 & GOTO 140
71741 ENDIF
71742 NP=NP+1
71743 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71744 PWT=1D0
71745 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
71746 & MAX(1D-10,PA)**(PARU(41)-2D0)
71747 DO 130 J1=1,3
71748 DO 120 J2=J1,3
71749 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
71750 120 CONTINUE
71751 130 CONTINUE
71752 PS=PS+PWT*PA**2
71753 140 CONTINUE
71754
71755C...Very low multiplicities (0 or 1) not considered.
71756 IF(NP.LE.1) THEN
71757 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
71758 SPH=-1D0
71759 APL=-1D0
71760 RETURN
71761 ENDIF
71762 DO 160 J1=1,3
71763 DO 150 J2=J1,3
71764 SM(J1,J2)=SM(J1,J2)/PS
71765 150 CONTINUE
71766 160 CONTINUE
71767
71768C...Find eigenvalues to matrix (third degree equation).
71769 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71770 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71771 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71772 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71773 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71774 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71775 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71776 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
71777 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
71778 IF(P(N+2,4).LT.1D-5) THEN
71779 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
71780 SPH=-1D0
71781 APL=-1D0
71782 RETURN
71783 ENDIF
71784
71785C...Find first and last eigenvector by solving equation system.
71786 DO 240 I=1,3,2
71787 DO 180 J1=1,3
71788 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
71789 DO 170 J2=J1+1,3
71790 SV(J1,J2)=SM(J1,J2)
71791 SV(J2,J1)=SM(J1,J2)
71792 170 CONTINUE
71793 180 CONTINUE
71794 SMAX=0D0
71795 DO 200 J1=1,3
71796 DO 190 J2=1,3
71797 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
71798 JA=J1
71799 JB=J2
71800 SMAX=ABS(SV(J1,J2))
71801 190 CONTINUE
71802 200 CONTINUE
71803 SMAX=0D0
71804 DO 220 J3=JA+1,JA+2
71805 J1=J3-3*((J3-1)/3)
71806 RL=SV(J1,JB)/SV(JA,JB)
71807 DO 210 J2=1,3
71808 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
71809 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
71810 JC=J1
71811 SMAX=ABS(SV(J1,J2))
71812 210 CONTINUE
71813 220 CONTINUE
71814 JB1=JB+1-3*(JB/3)
71815 JB2=JB+2-3*((JB+1)/3)
71816 P(N+I,JB1)=-SV(JC,JB2)
71817 P(N+I,JB2)=SV(JC,JB1)
71818 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
71819 & SV(JA,JB)
71820 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
71821 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71822 DO 230 J=1,3
71823 P(N+I,J)=SGN*P(N+I,J)/PA
71824 230 CONTINUE
71825 240 CONTINUE
71826
71827C...Middle axis orthogonal to other two. Fill other codes.
71828 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71829 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
71830 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
71831 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
71832 DO 260 I=1,3
71833 K(N+I,1)=31
71834 K(N+I,2)=95
71835 K(N+I,3)=I
71836 K(N+I,4)=0
71837 K(N+I,5)=0
71838 P(N+I,5)=0D0
71839 DO 250 J=1,5
71840 V(I,J)=0D0
71841 250 CONTINUE
71842 260 CONTINUE
71843
71844C...Calculate sphericity and aplanarity. Select storing option.
71845 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
71846 APL=1.5D0*P(N+3,4)
71847 MSTU(61)=N+1
71848 MSTU(62)=NP
71849 IF(MSTU(43).LE.1) MSTU(3)=3
71850 IF(MSTU(43).GE.2) N=N+3
71851
71852 RETURN
71853 END
71854
71855C*********************************************************************
71856
71857C...PYTHRU
71858C...Performs thrust analysis to give thrust, oblateness
71859C...and the related event axes.
71860
71861 SUBROUTINE PYTHRU(THR,OBL)
71862
71863C...Double precision and integer declarations.
71864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71865 IMPLICIT INTEGER(I-N)
71866 INTEGER PYK,PYCHGE,PYCOMP
71867C...Parameter statement to help give large particle numbers.
71868 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71869 &KEXCIT=4000000,KDIMEN=5000000)
71870C...Commonblocks.
71871 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71873 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71874 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71875C...Local arrays.
71876 DIMENSION TDI(3),TPR(3)
71877
71878C...Take copy of particles that are to be considered in thrust analysis.
71879 NP=0
71880 PS=0D0
71881 DO 100 I=1,N
71882 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
71883 IF(MSTU(41).GE.2) THEN
71884 KC=PYCOMP(K(I,2))
71885 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71886 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71887 & K(I,2).EQ.KSUSY1+39) GOTO 100
71888 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71889 & GOTO 100
71890 ENDIF
71891 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
71892 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
71893 THR=-2D0
71894 OBL=-2D0
71895 RETURN
71896 ENDIF
71897 NP=NP+1
71898 K(N+NP,1)=23
71899 P(N+NP,1)=P(I,1)
71900 P(N+NP,2)=P(I,2)
71901 P(N+NP,3)=P(I,3)
71902 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71903 P(N+NP,5)=1D0
71904 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
71905 & P(N+NP,4)**(PARU(42)-1D0)
71906 PS=PS+P(N+NP,4)*P(N+NP,5)
71907 100 CONTINUE
71908
71909C...Very low multiplicities (0 or 1) not considered.
71910 IF(NP.LE.1) THEN
71911 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
71912 THR=-1D0
71913 OBL=-1D0
71914 RETURN
71915 ENDIF
71916
71917C...Loop over thrust and major. T axis along z direction in latter case.
71918 DO 320 ILD=1,2
71919 IF(ILD.EQ.2) THEN
71920 K(N+NP+1,1)=31
71921 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
71922 MSTU(33)=1
71923 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
71924 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
71925 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
71926 ENDIF
71927
71928C...Find and order particles with highest p (pT for major).
71929 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
71930 P(ILF,4)=0D0
71931 110 CONTINUE
71932 DO 160 I=N+1,N+NP
71933 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
71934 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
71935 IF(P(I,4).LE.P(ILF,4)) GOTO 140
71936 DO 120 J=1,5
71937 P(ILF+1,J)=P(ILF,J)
71938 120 CONTINUE
71939 130 CONTINUE
71940 ILF=N+NP+3
71941 140 DO 150 J=1,5
71942 P(ILF+1,J)=P(I,J)
71943 150 CONTINUE
71944 160 CONTINUE
71945
71946C...Find and order initial axes with highest thrust (major).
71947 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
71948 P(ILG,4)=0D0
71949 170 CONTINUE
71950 NC=2**(MIN(MSTU(44),NP)-1)
71951 DO 250 ILC=1,NC
71952 DO 180 J=1,3
71953 TDI(J)=0D0
71954 180 CONTINUE
71955 DO 200 ILF=1,MIN(MSTU(44),NP)
71956 SGN=P(N+NP+ILF+3,5)
71957 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
71958 DO 190 J=1,4-ILD
71959 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
71960 190 CONTINUE
71961 200 CONTINUE
71962 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
71963 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
71964 IF(TDS.LE.P(ILG,4)) GOTO 230
71965 DO 210 J=1,4
71966 P(ILG+1,J)=P(ILG,J)
71967 210 CONTINUE
71968 220 CONTINUE
71969 ILG=N+NP+MSTU(44)+4
71970 230 DO 240 J=1,3
71971 P(ILG+1,J)=TDI(J)
71972 240 CONTINUE
71973 P(ILG+1,4)=TDS
71974 250 CONTINUE
71975
71976C...Iterate direction of axis until stable maximum.
71977 P(N+NP+ILD,4)=0D0
71978 ILG=0
71979 260 ILG=ILG+1
71980 THP=0D0
71981 270 THPS=THP
71982 DO 280 J=1,3
71983 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
71984 IF(THP.GT.1D-10) TDI(J)=TPR(J)
71985 TPR(J)=0D0
71986 280 CONTINUE
71987 DO 300 I=N+1,N+NP
71988 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
71989 DO 290 J=1,4-ILD
71990 TPR(J)=TPR(J)+SGN*P(I,J)
71991 290 CONTINUE
71992 300 CONTINUE
71993 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
71994 IF(THP.GE.THPS+PARU(48)) GOTO 270
71995
71996C...Save good axis. Try new initial axis until a number of tries agree.
71997 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
71998 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
71999 IAGR=0
72000 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72001 DO 310 J=1,3
72002 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
72003 310 CONTINUE
72004 P(N+NP+ILD,4)=THP
72005 P(N+NP+ILD,5)=0D0
72006 ENDIF
72007 IAGR=IAGR+1
72008 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
72009 320 CONTINUE
72010
72011C...Find minor axis and value by orthogonality.
72012 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72013 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
72014 P(N+NP+3,2)=SGN*P(N+NP+2,1)
72015 P(N+NP+3,3)=0D0
72016 THP=0D0
72017 DO 330 I=N+1,N+NP
72018 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
72019 330 CONTINUE
72020 P(N+NP+3,4)=THP/PS
72021 P(N+NP+3,5)=0D0
72022
72023C...Fill axis information. Rotate back to original coordinate system.
72024 DO 350 ILD=1,3
72025 K(N+ILD,1)=31
72026 K(N+ILD,2)=96
72027 K(N+ILD,3)=ILD
72028 K(N+ILD,4)=0
72029 K(N+ILD,5)=0
72030 DO 340 J=1,5
72031 P(N+ILD,J)=P(N+NP+ILD,J)
72032 V(N+ILD,J)=0D0
72033 340 CONTINUE
72034 350 CONTINUE
72035 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
72036
72037C...Calculate thrust and oblateness. Select storing option.
72038 THR=P(N+1,4)
72039 OBL=P(N+2,4)-P(N+3,4)
72040 MSTU(61)=N+1
72041 MSTU(62)=NP
72042 IF(MSTU(43).LE.1) MSTU(3)=3
72043 IF(MSTU(43).GE.2) N=N+3
72044
72045 RETURN
72046 END
72047
72048C*********************************************************************
72049
72050C...PYCLUS
72051C...Subdivides the particle content of an event into jets/clusters.
72052
72053 SUBROUTINE PYCLUS(NJET)
72054
72055C...Double precision and integer declarations.
72056 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72057 IMPLICIT INTEGER(I-N)
72058 INTEGER PYK,PYCHGE,PYCOMP
72059C...Parameter statement to help give large particle numbers.
72060 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72061 &KEXCIT=4000000,KDIMEN=5000000)
72062C...Commonblocks.
72063 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72064 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72065 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72066 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72067C...Local arrays and saved variables.
72068 DIMENSION PS(5)
72069 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
72070
72071C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
72072 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
72073 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
72074 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
72075 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72076 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
72077 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72078
72079C...If first time, reset. If reentering, skip preliminaries.
72080 IF(MSTU(48).LE.0) THEN
72081 NP=0
72082 DO 100 J=1,5
72083 PS(J)=0D0
72084 100 CONTINUE
72085 PSS=0D0
72086 PIMASS=PMAS(PYCOMP(211),1)
72087 ELSE
72088 NJET=NSAV
72089 IF(MSTU(43).GE.2) N=N-NJET
72090 DO 110 I=N+1,N+NJET
72091 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72092 110 CONTINUE
72093 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72094 R2ACC=PARU(44)**2
72095 ELSE
72096 R2ACC=PARU(45)*PS(5)**2
72097 ENDIF
72098 NLOOP=0
72099 GOTO 300
72100 ENDIF
72101
72102C...Find which particles are to be considered in cluster search.
72103 DO 140 I=1,N
72104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
72105 IF(MSTU(41).GE.2) THEN
72106 KC=PYCOMP(K(I,2))
72107 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72108 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72109 & K(I,2).EQ.KSUSY1+39) GOTO 140
72110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72111 & GOTO 140
72112 ENDIF
72113 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
72114 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
72115 NJET=-1
72116 RETURN
72117 ENDIF
72118
72119C...Take copy of these particles, with space left for jets later on.
72120 NP=NP+1
72121 K(N+NP,3)=I
72122 DO 120 J=1,5
72123 P(N+NP,J)=P(I,J)
72124 120 CONTINUE
72125 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72126 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72127 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72128 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72129 DO 130 J=1,4
72130 PS(J)=PS(J)+P(N+NP,J)
72131 130 CONTINUE
72132 PSS=PSS+P(N+NP,5)
72133 140 CONTINUE
72134 DO 160 I=N+1,N+NP
72135 K(I+NP,3)=K(I,3)
72136 DO 150 J=1,5
72137 P(I+NP,J)=P(I,J)
72138 150 CONTINUE
72139 160 CONTINUE
72140 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
72141
72142C...Very low multiplicities not considered.
72143 IF(NP.LT.MSTU(47)) THEN
72144 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
72145 NJET=-1
72146 RETURN
72147 ENDIF
72148
72149C...Find precluster configuration. If too few jets, make harder cuts.
72150 NLOOP=0
72151 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72152 R2ACC=PARU(44)**2
72153 ELSE
72154 R2ACC=PARU(45)*PS(5)**2
72155 ENDIF
72156 RINIT=1.25D0*PARU(43)
72157 IF(NP.LE.MSTU(47)+2) RINIT=0D0
72158 170 RINIT=0.8D0*RINIT
72159 NPRE=0
72160 NREM=NP
72161 DO 180 I=N+NP+1,N+2*NP
72162 K(I,4)=0
72163 180 CONTINUE
72164
72165C...Sum up small momentum region. Jet if enough absolute momentum.
72166 IF(MSTU(46).LE.2) THEN
72167 DO 190 J=1,4
72168 P(N+1,J)=0D0
72169 190 CONTINUE
72170 DO 210 I=N+NP+1,N+2*NP
72171 IF(P(I,5).GT.2D0*RINIT) GOTO 210
72172 NREM=NREM-1
72173 K(I,4)=1
72174 DO 200 J=1,4
72175 P(N+1,J)=P(N+1,J)+P(I,J)
72176 200 CONTINUE
72177 210 CONTINUE
72178 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
72179 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
72180 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72181 IF(NREM.EQ.0) GOTO 170
72182 ENDIF
72183
72184C...Find fastest remaining particle.
72185 220 NPRE=NPRE+1
72186 PMAX=0D0
72187 DO 230 I=N+NP+1,N+2*NP
72188 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
72189 IMAX=I
72190 PMAX=P(I,5)
72191 230 CONTINUE
72192 DO 240 J=1,5
72193 P(N+NPRE,J)=P(IMAX,J)
72194 240 CONTINUE
72195 NREM=NREM-1
72196 K(IMAX,4)=NPRE
72197
72198C...Sum up precluster around it according to pT separation.
72199 IF(MSTU(46).LE.2) THEN
72200 DO 260 I=N+NP+1,N+2*NP
72201 IF(K(I,4).NE.0) GOTO 260
72202 R2=R2T(I,IMAX)
72203 IF(R2.GT.RINIT**2) GOTO 260
72204 NREM=NREM-1
72205 K(I,4)=NPRE
72206 DO 250 J=1,4
72207 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
72208 250 CONTINUE
72209 260 CONTINUE
72210 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72211
72212C...Sum up precluster around it according to mass or
72213C...Durham pT separation.
72214 ELSE
72215 270 IMIN=0
72216 R2MIN=RINIT**2
72217 DO 280 I=N+NP+1,N+2*NP
72218 IF(K(I,4).NE.0) GOTO 280
72219 IF(MSTU(46).LE.4) THEN
72220 R2=R2M(I,N+NPRE)
72221 ELSE
72222 R2=R2D(I,N+NPRE)
72223 ENDIF
72224 IF(R2.GE.R2MIN) GOTO 280
72225 IMIN=I
72226 R2MIN=R2
72227 280 CONTINUE
72228 IF(IMIN.NE.0) THEN
72229 DO 290 J=1,4
72230 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
72231 290 CONTINUE
72232 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72233 NREM=NREM-1
72234 K(IMIN,4)=NPRE
72235 GOTO 270
72236 ENDIF
72237 ENDIF
72238
72239C...Check if more preclusters to be found. Start over if too few.
72240 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72241 IF(NREM.GT.0) GOTO 220
72242 NJET=NPRE
72243
72244C...Reassign all particles to nearest jet. Sum up new jet momenta.
72245 300 TSAV=0D0
72246 PSJT=0D0
72247 310 IF(MSTU(46).LE.1) THEN
72248 DO 330 I=N+1,N+NJET
72249 DO 320 J=1,4
72250 V(I,J)=0D0
72251 320 CONTINUE
72252 330 CONTINUE
72253 DO 360 I=N+NP+1,N+2*NP
72254 R2MIN=PSS**2
72255 DO 340 IJET=N+1,N+NJET
72256 IF(P(IJET,5).LT.RINIT) GOTO 340
72257 R2=R2T(I,IJET)
72258 IF(R2.GE.R2MIN) GOTO 340
72259 IMIN=IJET
72260 R2MIN=R2
72261 340 CONTINUE
72262 K(I,4)=IMIN-N
72263 DO 350 J=1,4
72264 V(IMIN,J)=V(IMIN,J)+P(I,J)
72265 350 CONTINUE
72266 360 CONTINUE
72267 PSJT=0D0
72268 DO 380 I=N+1,N+NJET
72269 DO 370 J=1,4
72270 P(I,J)=V(I,J)
72271 370 CONTINUE
72272 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72273 PSJT=PSJT+P(I,5)
72274 380 CONTINUE
72275 ENDIF
72276
72277C...Find two closest jets.
72278 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
72279 DO 400 ITRY1=N+1,N+NJET-1
72280 DO 390 ITRY2=ITRY1+1,N+NJET
72281 IF(MSTU(46).LE.2) THEN
72282 R2=R2T(ITRY1,ITRY2)
72283 ELSEIF(MSTU(46).LE.4) THEN
72284 R2=R2M(ITRY1,ITRY2)
72285 ELSE
72286 R2=R2D(ITRY1,ITRY2)
72287 ENDIF
72288 IF(R2.GE.R2MIN) GOTO 390
72289 IMIN1=ITRY1
72290 IMIN2=ITRY2
72291 R2MIN=R2
72292 390 CONTINUE
72293 400 CONTINUE
72294
72295C...If allowed, join two closest jets and start over.
72296 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
72297 IREC=MIN(IMIN1,IMIN2)
72298 IDEL=MAX(IMIN1,IMIN2)
72299 DO 410 J=1,4
72300 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
72301 410 CONTINUE
72302 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
72303 DO 430 I=IDEL+1,N+NJET
72304 DO 420 J=1,5
72305 P(I-1,J)=P(I,J)
72306 420 CONTINUE
72307 430 CONTINUE
72308 IF(MSTU(46).GE.2) THEN
72309 DO 440 I=N+NP+1,N+2*NP
72310 IORI=N+K(I,4)
72311 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
72312 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
72313 440 CONTINUE
72314 ENDIF
72315 NJET=NJET-1
72316 GOTO 300
72317
72318C...Divide up broad jet if empty cluster in list of final ones.
72319 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
72320 DO 450 I=N+1,N+NJET
72321 K(I,5)=0
72322 450 CONTINUE
72323 DO 460 I=N+NP+1,N+2*NP
72324 K(N+K(I,4),5)=K(N+K(I,4),5)+1
72325 460 CONTINUE
72326 IEMP=0
72327 DO 470 I=N+1,N+NJET
72328 IF(K(I,5).EQ.0) IEMP=I
72329 470 CONTINUE
72330 IF(IEMP.NE.0) THEN
72331 NLOOP=NLOOP+1
72332 ISPL=0
72333 R2MAX=0D0
72334 DO 480 I=N+NP+1,N+2*NP
72335 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
72336 IJET=N+K(I,4)
72337 R2=R2T(I,IJET)
72338 IF(R2.LE.R2MAX) GOTO 480
72339 ISPL=I
72340 R2MAX=R2
72341 480 CONTINUE
72342 IF(ISPL.NE.0) THEN
72343 IJET=N+K(ISPL,4)
72344 DO 490 J=1,4
72345 P(IEMP,J)=P(ISPL,J)
72346 P(IJET,J)=P(IJET,J)-P(ISPL,J)
72347 490 CONTINUE
72348 P(IEMP,5)=P(ISPL,5)
72349 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
72350 IF(NLOOP.LE.2) GOTO 300
72351 ENDIF
72352 ENDIF
72353 ENDIF
72354
72355C...If generalized thrust has not yet converged, continue iteration.
72356 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
72357 &THEN
72358 TSAV=PSJT/PSS
72359 GOTO 310
72360 ENDIF
72361
72362C...Reorder jets according to energy.
72363 DO 510 I=N+1,N+NJET
72364 DO 500 J=1,5
72365 V(I,J)=P(I,J)
72366 500 CONTINUE
72367 510 CONTINUE
72368 DO 540 INEW=N+1,N+NJET
72369 PEMAX=0D0
72370 DO 520 ITRY=N+1,N+NJET
72371 IF(V(ITRY,4).LE.PEMAX) GOTO 520
72372 IMAX=ITRY
72373 PEMAX=V(ITRY,4)
72374 520 CONTINUE
72375 K(INEW,1)=31
72376 K(INEW,2)=97
72377 K(INEW,3)=INEW-N
72378 K(INEW,4)=0
72379 DO 530 J=1,5
72380 P(INEW,J)=V(IMAX,J)
72381 530 CONTINUE
72382 V(IMAX,4)=-1D0
72383 K(IMAX,5)=INEW
72384 540 CONTINUE
72385
72386C...Clean up particle-jet assignments and jet information.
72387 DO 550 I=N+NP+1,N+2*NP
72388 IORI=K(N+K(I,4),5)
72389 K(I,4)=IORI-N
72390 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
72391 K(IORI,4)=K(IORI,4)+1
72392 550 CONTINUE
72393 IEMP=0
72394 PSJT=0D0
72395 DO 570 I=N+1,N+NJET
72396 K(I,5)=0
72397 PSJT=PSJT+P(I,5)
72398 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
72399 DO 560 J=1,5
72400 V(I,J)=0D0
72401 560 CONTINUE
72402 IF(K(I,4).EQ.0) IEMP=I
72403 570 CONTINUE
72404
72405C...Select storing option. Output variables. Check for failure.
72406 MSTU(61)=N+1
72407 MSTU(62)=NP
72408 MSTU(63)=NPRE
72409 PARU(61)=PS(5)
72410 PARU(62)=PSJT/PSS
72411 PARU(63)=SQRT(R2MIN)
72412 IF(NJET.LE.1) PARU(63)=0D0
72413 IF(IEMP.NE.0) THEN
72414 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
72415 NJET=-1
72416 RETURN
72417 ENDIF
72418 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72419 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72420 NSAV=NJET
72421
72422 RETURN
72423 END
72424
72425C*********************************************************************
72426
72427C...PYCELL
72428C...Provides a simple way of jet finding in eta-phi-ET coordinates,
72429C...as used for calorimeters at hadron colliders.
72430
72431 SUBROUTINE PYCELL(NJET)
72432
72433C...Double precision and integer declarations.
72434 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72435 IMPLICIT INTEGER(I-N)
72436 INTEGER PYK,PYCHGE,PYCOMP
72437C...Parameter statement to help give large particle numbers.
72438 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72439 &KEXCIT=4000000,KDIMEN=5000000)
72440C...Commonblocks.
72441 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72442 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72443 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72444 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72445
72446C...Loop over all particles. Find cell that was hit by given particle.
72447 PTLRAT=1D0/SINH(PARU(51))**2
72448 NP=0
72449 NC=N
72450 DO 110 I=1,N
72451 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72452 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
72453 IF(MSTU(41).GE.2) THEN
72454 KC=PYCOMP(K(I,2))
72455 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72456 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72457 & K(I,2).EQ.KSUSY1+39) GOTO 110
72458 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72459 & GOTO 110
72460 ENDIF
72461 NP=NP+1
72462 PT=SQRT(P(I,1)**2+P(I,2)**2)
72463 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
72464 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
72465 & (ETA/PARU(51)+1D0))))
72466 PHI=PYANGL(P(I,1),P(I,2))
72467 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
72468 & (PHI/PARU(1)+1D0))))
72469 IETPH=MSTU(52)*IETA+IPHI
72470
72471C...Add to cell already hit, or book new cell.
72472 DO 100 IC=N+1,NC
72473 IF(IETPH.EQ.K(IC,3)) THEN
72474 K(IC,4)=K(IC,4)+1
72475 P(IC,5)=P(IC,5)+PT
72476 GOTO 110
72477 ENDIF
72478 100 CONTINUE
72479 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
72480 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72481 NJET=-2
72482 RETURN
72483 ENDIF
72484 NC=NC+1
72485 K(NC,3)=IETPH
72486 K(NC,4)=1
72487 K(NC,5)=2
72488 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
72489 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
72490 P(NC,5)=PT
72491 110 CONTINUE
72492
72493C...Smear true bin content by calorimeter resolution.
72494 IF(MSTU(53).GE.1) THEN
72495 DO 130 IC=N+1,NC
72496 PEI=P(IC,5)
72497 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
72498 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
72499 & COS(PARU(2)*PYR(0))
72500 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
72501 P(IC,5)=PEF
72502 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
72503 130 CONTINUE
72504 ENDIF
72505
72506C...Remove cells below threshold.
72507 IF(PARU(58).GT.0D0) THEN
72508 NCC=NC
72509 NC=N
72510 DO 140 IC=N+1,NCC
72511 IF(P(IC,5).GT.PARU(58)) THEN
72512 NC=NC+1
72513 K(NC,3)=K(IC,3)
72514 K(NC,4)=K(IC,4)
72515 K(NC,5)=K(IC,5)
72516 P(NC,1)=P(IC,1)
72517 P(NC,2)=P(IC,2)
72518 P(NC,5)=P(IC,5)
72519 ENDIF
72520 140 CONTINUE
72521 ENDIF
72522
72523C...Find initiator cell: the one with highest pT of not yet used ones.
72524 NJ=NC
72525 150 ETMAX=0D0
72526 DO 160 IC=N+1,NC
72527 IF(K(IC,5).NE.2) GOTO 160
72528 IF(P(IC,5).LE.ETMAX) GOTO 160
72529 ICMAX=IC
72530 ETA=P(IC,1)
72531 PHI=P(IC,2)
72532 ETMAX=P(IC,5)
72533 160 CONTINUE
72534 IF(ETMAX.LT.PARU(52)) GOTO 220
72535 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
72536 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72537 NJET=-2
72538 RETURN
72539 ENDIF
72540 K(ICMAX,5)=1
72541 NJ=NJ+1
72542 K(NJ,4)=0
72543 K(NJ,5)=1
72544 P(NJ,1)=ETA
72545 P(NJ,2)=PHI
72546 P(NJ,3)=0D0
72547 P(NJ,4)=0D0
72548 P(NJ,5)=0D0
72549
72550C...Sum up unused cells within required distance of initiator.
72551 DO 170 IC=N+1,NC
72552 IF(K(IC,5).EQ.0) GOTO 170
72553 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
72554 DPHIA=ABS(P(IC,2)-PHI)
72555 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
72556 PHIC=P(IC,2)
72557 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
72558 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
72559 K(IC,5)=-K(IC,5)
72560 K(NJ,4)=K(NJ,4)+K(IC,4)
72561 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
72562 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
72563 P(NJ,5)=P(NJ,5)+P(IC,5)
72564 170 CONTINUE
72565
72566C...Reject cluster below minimum ET, else accept.
72567 IF(P(NJ,5).LT.PARU(53)) THEN
72568 NJ=NJ-1
72569 DO 180 IC=N+1,NC
72570 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
72571 180 CONTINUE
72572 ELSEIF(MSTU(54).LE.2) THEN
72573 P(NJ,3)=P(NJ,3)/P(NJ,5)
72574 P(NJ,4)=P(NJ,4)/P(NJ,5)
72575 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
72576 & P(NJ,4))
72577 DO 190 IC=N+1,NC
72578 IF(K(IC,5).LT.0) K(IC,5)=0
72579 190 CONTINUE
72580 ELSE
72581 DO 200 J=1,4
72582 P(NJ,J)=0D0
72583 200 CONTINUE
72584 DO 210 IC=N+1,NC
72585 IF(K(IC,5).GE.0) GOTO 210
72586 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
72587 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
72588 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
72589 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
72590 K(IC,5)=0
72591 210 CONTINUE
72592 ENDIF
72593 GOTO 150
72594
72595C...Arrange clusters in falling ET sequence.
72596 220 DO 250 I=1,NJ-NC
72597 ETMAX=0D0
72598 DO 230 IJ=NC+1,NJ
72599 IF(K(IJ,5).EQ.0) GOTO 230
72600 IF(P(IJ,5).LT.ETMAX) GOTO 230
72601 IJMAX=IJ
72602 ETMAX=P(IJ,5)
72603 230 CONTINUE
72604 K(IJMAX,5)=0
72605 K(N+I,1)=31
72606 K(N+I,2)=98
72607 K(N+I,3)=I
72608 K(N+I,4)=K(IJMAX,4)
72609 K(N+I,5)=0
72610 DO 240 J=1,5
72611 P(N+I,J)=P(IJMAX,J)
72612 V(N+I,J)=0D0
72613 240 CONTINUE
72614 250 CONTINUE
72615 NJET=NJ-NC
72616
72617C...Convert to massless or massive four-vectors.
72618 IF(MSTU(54).EQ.2) THEN
72619 DO 260 I=N+1,N+NJET
72620 ETA=P(I,3)
72621 P(I,1)=P(I,5)*COS(P(I,4))
72622 P(I,2)=P(I,5)*SIN(P(I,4))
72623 P(I,3)=P(I,5)*SINH(ETA)
72624 P(I,4)=P(I,5)*COSH(ETA)
72625 P(I,5)=0D0
72626 260 CONTINUE
72627 ELSEIF(MSTU(54).GE.3) THEN
72628 DO 270 I=N+1,N+NJET
72629 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
72630 270 CONTINUE
72631 ENDIF
72632
72633C...Information about storage.
72634 MSTU(61)=N+1
72635 MSTU(62)=NP
72636 MSTU(63)=NC-N
72637 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72638 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72639
72640 RETURN
72641 END
72642
72643C*********************************************************************
72644
72645C...PYJMAS
72646C...Determines, approximately, the two jet masses that minimize
72647C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
72648
72649 SUBROUTINE PYJMAS(PMH,PML)
72650
72651C...Double precision and integer declarations.
72652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72653 IMPLICIT INTEGER(I-N)
72654 INTEGER PYK,PYCHGE,PYCOMP
72655C...Parameter statement to help give large particle numbers.
72656 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72657 &KEXCIT=4000000,KDIMEN=5000000)
72658C...Commonblocks.
72659 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72660 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72661 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72662 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72663C...Local arrays.
72664 DIMENSION SM(3,3),SAX(3),PS(3,5)
72665
72666C...Reset.
72667 NP=0
72668 DO 120 J1=1,3
72669 DO 100 J2=J1,3
72670 SM(J1,J2)=0D0
72671 100 CONTINUE
72672 DO 110 J2=1,4
72673 PS(J1,J2)=0D0
72674 110 CONTINUE
72675 120 CONTINUE
72676 PSS=0D0
72677 PIMASS=PMAS(PYCOMP(211),1)
72678
72679C...Take copy of particles that are to be considered in mass analysis.
72680 DO 170 I=1,N
72681 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
72682 IF(MSTU(41).GE.2) THEN
72683 KC=PYCOMP(K(I,2))
72684 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72685 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72686 & K(I,2).EQ.KSUSY1+39) GOTO 170
72687 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72688 & GOTO 170
72689 ENDIF
72690 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
72691 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
72692 PMH=-2D0
72693 PML=-2D0
72694 RETURN
72695 ENDIF
72696 NP=NP+1
72697 DO 130 J=1,5
72698 P(N+NP,J)=P(I,J)
72699 130 CONTINUE
72700 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72701 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72702 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72703
72704C...Fill information in sphericity tensor and total momentum vector.
72705 DO 150 J1=1,3
72706 DO 140 J2=J1,3
72707 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
72708 140 CONTINUE
72709 150 CONTINUE
72710 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72711 DO 160 J=1,4
72712 PS(3,J)=PS(3,J)+P(N+NP,J)
72713 160 CONTINUE
72714 170 CONTINUE
72715
72716C...Very low multiplicities (0 or 1) not considered.
72717 IF(NP.LE.1) THEN
72718 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
72719 PMH=-1D0
72720 PML=-1D0
72721 RETURN
72722 ENDIF
72723 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
72724 &PS(3,3)**2))
72725
72726C...Find largest eigenvalue to matrix (third degree equation).
72727 DO 190 J1=1,3
72728 DO 180 J2=J1,3
72729 SM(J1,J2)=SM(J1,J2)/PSS
72730 180 CONTINUE
72731 190 CONTINUE
72732 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
72733 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
72734 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
72735 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
72736 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
72737 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
72738 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
72739
72740C...Find largest eigenvector by solving equation system.
72741 DO 210 J1=1,3
72742 SM(J1,J1)=SM(J1,J1)-SMA
72743 DO 200 J2=J1+1,3
72744 SM(J2,J1)=SM(J1,J2)
72745 200 CONTINUE
72746 210 CONTINUE
72747 SMAX=0D0
72748 DO 230 J1=1,3
72749 DO 220 J2=1,3
72750 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
72751 JA=J1
72752 JB=J2
72753 SMAX=ABS(SM(J1,J2))
72754 220 CONTINUE
72755 230 CONTINUE
72756 SMAX=0D0
72757 DO 250 J3=JA+1,JA+2
72758 J1=J3-3*((J3-1)/3)
72759 RL=SM(J1,JB)/SM(JA,JB)
72760 DO 240 J2=1,3
72761 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
72762 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
72763 JC=J1
72764 SMAX=ABS(SM(J1,J2))
72765 240 CONTINUE
72766 250 CONTINUE
72767 JB1=JB+1-3*(JB/3)
72768 JB2=JB+2-3*((JB+1)/3)
72769 SAX(JB1)=-SM(JC,JB2)
72770 SAX(JB2)=SM(JC,JB1)
72771 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
72772
72773C...Divide particles into two initial clusters by hemisphere.
72774 DO 270 I=N+1,N+NP
72775 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
72776 IS=1
72777 IF(PSAX.LT.0D0) IS=2
72778 K(I,3)=IS
72779 DO 260 J=1,4
72780 PS(IS,J)=PS(IS,J)+P(I,J)
72781 260 CONTINUE
72782 270 CONTINUE
72783 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
72784 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
72785
72786C...Reassign one particle at a time; find maximum decrease of m^2 sum.
72787 280 PMD=0D0
72788 IM=0
72789 DO 290 J=1,4
72790 PS(3,J)=PS(1,J)-PS(2,J)
72791 290 CONTINUE
72792 DO 300 I=N+1,N+NP
72793 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)
72794 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
72795 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
72796 IF(PMDI.LT.PMD) THEN
72797 PMD=PMDI
72798 IM=I
72799 ENDIF
72800 300 CONTINUE
72801
72802C...Loop back if significant reduction in sum of m^2.
72803 IF(PMD.LT.-PARU(48)*PMS) THEN
72804 PMS=PMS+PMD
72805 IS=K(IM,3)
72806 DO 310 J=1,4
72807 PS(IS,J)=PS(IS,J)-P(IM,J)
72808 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
72809 310 CONTINUE
72810 K(IM,3)=3-IS
72811 GOTO 280
72812 ENDIF
72813
72814C...Final masses and output.
72815 MSTU(61)=N+1
72816 MSTU(62)=NP
72817 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
72818 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
72819 PMH=MAX(PS(1,5),PS(2,5))
72820 PML=MIN(PS(1,5),PS(2,5))
72821
72822 RETURN
72823 END
72824
72825C*********************************************************************
72826
72827C...PYFOWO
72828C...Calculates the first few Fox-Wolfram moments.
72829
72830 SUBROUTINE PYFOWO(H10,H20,H30,H40)
72831
72832C...Double precision and integer declarations.
72833 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72834 IMPLICIT INTEGER(I-N)
72835 INTEGER PYK,PYCHGE,PYCOMP
72836C...Parameter statement to help give large particle numbers.
72837 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72838 &KEXCIT=4000000,KDIMEN=5000000)
72839C...Commonblocks.
72840 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72843 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72844
72845C...Copy momenta for particles and calculate H0.
72846 NP=0
72847 H0=0D0
72848 HD=0D0
72849 DO 110 I=1,N
72850 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72851 IF(MSTU(41).GE.2) THEN
72852 KC=PYCOMP(K(I,2))
72853 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72854 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72855 & K(I,2).EQ.KSUSY1+39) GOTO 110
72856 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72857 & GOTO 110
72858 ENDIF
72859 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
72860 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
72861 H10=-1D0
72862 H20=-1D0
72863 H30=-1D0
72864 H40=-1D0
72865 RETURN
72866 ENDIF
72867 NP=NP+1
72868 DO 100 J=1,3
72869 P(N+NP,J)=P(I,J)
72870 100 CONTINUE
72871 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72872 H0=H0+P(N+NP,4)
72873 HD=HD+P(N+NP,4)**2
72874 110 CONTINUE
72875 H0=H0**2
72876
72877C...Very low multiplicities (0 or 1) not considered.
72878 IF(NP.LE.1) THEN
72879 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
72880 H10=-1D0
72881 H20=-1D0
72882 H30=-1D0
72883 H40=-1D0
72884 RETURN
72885 ENDIF
72886
72887C...Calculate H1 - H4.
72888 H10=0D0
72889 H20=0D0
72890 H30=0D0
72891 H40=0D0
72892 DO 130 I1=N+1,N+NP
72893 DO 120 I2=I1+1,N+NP
72894 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72895 & (P(I1,4)*P(I2,4))
72896 H10=H10+P(I1,4)*P(I2,4)*CTHE
72897 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
72898 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
72899 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
72900 & 0.375D0)
72901 120 CONTINUE
72902 130 CONTINUE
72903
72904C...Calculate H1/H0 - H4/H0. Output.
72905 MSTU(61)=N+1
72906 MSTU(62)=NP
72907 H10=(HD+2D0*H10)/H0
72908 H20=(HD+2D0*H20)/H0
72909 H30=(HD+2D0*H30)/H0
72910 H40=(HD+2D0*H40)/H0
72911
72912 RETURN
72913 END
72914
72915C*********************************************************************
72916
72917C...PYTABU
72918C...Evaluates various properties of an event, with statistics
72919C...accumulated during the course of the run and
72920C...printed at the end.
72921
72922 SUBROUTINE PYTABU(MTABU)
72923
72924C...Double precision and integer declarations.
72925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72926 IMPLICIT INTEGER(I-N)
72927 INTEGER PYK,PYCHGE,PYCOMP
72928C...Parameter statement to help give large particle numbers.
72929 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72930 &KEXCIT=4000000,KDIMEN=5000000)
72931C...Commonblocks.
72932 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72933 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72934 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72935 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
72936 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
72937C...Local arrays, character variables, saved variables and data.
72938 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
72939 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
72940 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
72941 &KFDM(8),KFDC(200,0:8),NPDC(200)
72942 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
72943 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
72944 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
72945 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
72946 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
72947 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
72948 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
72949 &NEVDC/0/,NKFDC/0/,NREDC/0/
72950
72951C...Reset statistics on initial parton state.
72952 IF(MTABU.EQ.10) THEN
72953 NEVIS=0
72954 NKFIS=0
72955
72956C...Identify and order flavour content of initial state.
72957 ELSEIF(MTABU.EQ.11) THEN
72958 NEVIS=NEVIS+1
72959 KFM1=2*IABS(MSTU(161))
72960 IF(MSTU(161).GT.0) KFM1=KFM1-1
72961 KFM2=2*IABS(MSTU(162))
72962 IF(MSTU(162).GT.0) KFM2=KFM2-1
72963 KFMN=MIN(KFM1,KFM2)
72964 KFMX=MAX(KFM1,KFM2)
72965 DO 100 I=1,NKFIS
72966 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
72967 IKFIS=-I
72968 GOTO 110
72969 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
72970 & KFMX.LT.KFIS(I,2))) THEN
72971 IKFIS=I
72972 GOTO 110
72973 ENDIF
72974 100 CONTINUE
72975 IKFIS=NKFIS+1
72976 110 IF(IKFIS.LT.0) THEN
72977 IKFIS=-IKFIS
72978 ELSE
72979 IF(NKFIS.GE.100) RETURN
72980 DO 130 I=NKFIS,IKFIS,-1
72981 KFIS(I+1,1)=KFIS(I,1)
72982 KFIS(I+1,2)=KFIS(I,2)
72983 DO 120 J=0,10
72984 NPIS(I+1,J)=NPIS(I,J)
72985 120 CONTINUE
72986 130 CONTINUE
72987 NKFIS=NKFIS+1
72988 KFIS(IKFIS,1)=KFMN
72989 KFIS(IKFIS,2)=KFMX
72990 DO 140 J=0,10
72991 NPIS(IKFIS,J)=0
72992 140 CONTINUE
72993 ENDIF
72994 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
72995
72996C...Count number of partons in initial state.
72997 NP=0
72998 DO 160 I=1,N
72999 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
73000 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
73001 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
73002 & THEN
73003 ELSE
73004 IM=I
73005 150 IM=K(IM,3)
73006 IF(IM.LE.0.OR.IM.GT.N) THEN
73007 NP=NP+1
73008 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73009 NP=NP+1
73010 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
73011 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
73012 & .NE.0) THEN
73013 ELSE
73014 GOTO 150
73015 ENDIF
73016 ENDIF
73017 160 CONTINUE
73018 NPCO=MAX(NP,1)
73019 IF(NP.GE.6) NPCO=6
73020 IF(NP.GE.8) NPCO=7
73021 IF(NP.GE.11) NPCO=8
73022 IF(NP.GE.16) NPCO=9
73023 IF(NP.GE.26) NPCO=10
73024 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
73025 MSTU(62)=NP
73026
73027C...Write statistics on initial parton state.
73028 ELSEIF(MTABU.EQ.12) THEN
73029 FAC=1D0/MAX(1,NEVIS)
73030 WRITE(MSTU(11),5000) NEVIS
73031 DO 170 I=1,NKFIS
73032 KFMN=KFIS(I,1)
73033 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73034 KFM1=(KFMN+1)/2
73035 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73036 CALL PYNAME(KFM1,CHAU)
73037 CHIS(1)=CHAU(1:12)
73038 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
73039 KFMX=KFIS(I,2)
73040 IF(KFIS(I,1).EQ.0) KFMX=0
73041 KFM2=(KFMX+1)/2
73042 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73043 CALL PYNAME(KFM2,CHAU)
73044 CHIS(2)=CHAU(1:12)
73045 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
73046 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
73047 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
73048 170 CONTINUE
73049
73050C...Copy statistics on initial parton state into /PYJETS/.
73051 ELSEIF(MTABU.EQ.13) THEN
73052 FAC=1D0/MAX(1,NEVIS)
73053 DO 190 I=1,NKFIS
73054 KFMN=KFIS(I,1)
73055 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73056 KFM1=(KFMN+1)/2
73057 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73058 KFMX=KFIS(I,2)
73059 IF(KFIS(I,1).EQ.0) KFMX=0
73060 KFM2=(KFMX+1)/2
73061 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73062 K(I,1)=32
73063 K(I,2)=99
73064 K(I,3)=KFM1
73065 K(I,4)=KFM2
73066 K(I,5)=NPIS(I,0)
73067 DO 180 J=1,5
73068 P(I,J)=FAC*NPIS(I,J)
73069 V(I,J)=FAC*NPIS(I,J+5)
73070 180 CONTINUE
73071 190 CONTINUE
73072 N=NKFIS
73073 DO 200 J=1,5
73074 K(N+1,J)=0
73075 P(N+1,J)=0D0
73076 V(N+1,J)=0D0
73077 200 CONTINUE
73078 K(N+1,1)=32
73079 K(N+1,2)=99
73080 K(N+1,5)=NEVIS
73081 MSTU(3)=1
73082
73083C...Reset statistics on number of particles/partons.
73084 ELSEIF(MTABU.EQ.20) THEN
73085 NEVFS=0
73086 NPRFS=0
73087 NFIFS=0
73088 NCHFS=0
73089 NKFFS=0
73090
73091C...Identify whether particle/parton is primary or not.
73092 ELSEIF(MTABU.EQ.21) THEN
73093 NEVFS=NEVFS+1
73094 MSTU(62)=0
73095 DO 260 I=1,N
73096 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
73097 MSTU(62)=MSTU(62)+1
73098 KC=PYCOMP(K(I,2))
73099 MPRI=0
73100 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
73101 MPRI=1
73102 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
73103 MPRI=1
73104 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
73105 MPRI=1
73106 ELSEIF(KC.EQ.0) THEN
73107 ELSEIF(K(K(I,3),1).EQ.13) THEN
73108 IM=K(K(I,3),3)
73109 IF(IM.LE.0.OR.IM.GT.N) THEN
73110 MPRI=1
73111 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73112 MPRI=1
73113 ENDIF
73114 ELSEIF(KCHG(KC,2).EQ.0) THEN
73115 KCM=PYCOMP(K(K(I,3),2))
73116 IF(KCM.NE.0) THEN
73117 IF(KCHG(KCM,2).NE.0) MPRI=1
73118 ENDIF
73119 ENDIF
73120 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
73121 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
73122 ENDIF
73123 IF(K(I,1).LE.10) THEN
73124 NFIFS=NFIFS+1
73125 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
73126 ENDIF
73127
73128C...Fill statistics on number of particles/partons in event.
73129 KFA=IABS(K(I,2))
73130 KFS=3-ISIGN(1,K(I,2))-MPRI
73131 DO 210 IP=1,NKFFS
73132 IF(KFA.EQ.KFFS(IP)) THEN
73133 IKFFS=-IP
73134 GOTO 220
73135 ELSEIF(KFA.LT.KFFS(IP)) THEN
73136 IKFFS=IP
73137 GOTO 220
73138 ENDIF
73139 210 CONTINUE
73140 IKFFS=NKFFS+1
73141 220 IF(IKFFS.LT.0) THEN
73142 IKFFS=-IKFFS
73143 ELSE
73144 IF(NKFFS.GE.400) RETURN
73145 DO 240 IP=NKFFS,IKFFS,-1
73146 KFFS(IP+1)=KFFS(IP)
73147 DO 230 J=1,4
73148 NPFS(IP+1,J)=NPFS(IP,J)
73149 230 CONTINUE
73150 240 CONTINUE
73151 NKFFS=NKFFS+1
73152 KFFS(IKFFS)=KFA
73153 DO 250 J=1,4
73154 NPFS(IKFFS,J)=0
73155 250 CONTINUE
73156 ENDIF
73157 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
73158 260 CONTINUE
73159
73160C...Write statistics on particle/parton composition of events.
73161 ELSEIF(MTABU.EQ.22) THEN
73162 FAC=1D0/MAX(1,NEVFS)
73163 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
73164 DO 270 I=1,NKFFS
73165 CALL PYNAME(KFFS(I),CHAU)
73166 KC=PYCOMP(KFFS(I))
73167 MDCYF=0
73168 IF(KC.NE.0) MDCYF=MDCY(KC,1)
73169 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
73170 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
73171 270 CONTINUE
73172
73173C...Copy particle/parton composition information into /PYJETS/.
73174 ELSEIF(MTABU.EQ.23) THEN
73175 FAC=1D0/MAX(1,NEVFS)
73176 DO 290 I=1,NKFFS
73177 K(I,1)=32
73178 K(I,2)=99
73179 K(I,3)=KFFS(I)
73180 K(I,4)=0
73181 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
73182 DO 280 J=1,4
73183 P(I,J)=FAC*NPFS(I,J)
73184 V(I,J)=0D0
73185 280 CONTINUE
73186 P(I,5)=FAC*K(I,5)
73187 V(I,5)=0D0
73188 290 CONTINUE
73189 N=NKFFS
73190 DO 300 J=1,5
73191 K(N+1,J)=0
73192 P(N+1,J)=0D0
73193 V(N+1,J)=0D0
73194 300 CONTINUE
73195 K(N+1,1)=32
73196 K(N+1,2)=99
73197 K(N+1,5)=NEVFS
73198 P(N+1,1)=FAC*NPRFS
73199 P(N+1,2)=FAC*NFIFS
73200 P(N+1,3)=FAC*NCHFS
73201 MSTU(3)=1
73202
73203C...Reset factorial moments statistics.
73204 ELSEIF(MTABU.EQ.30) THEN
73205 NEVFM=0
73206 NMUFM=0
73207 DO 330 IM=1,3
73208 DO 320 IB=1,10
73209 DO 310 IP=1,4
73210 FM1FM(IM,IB,IP)=0D0
73211 FM2FM(IM,IB,IP)=0D0
73212 310 CONTINUE
73213 320 CONTINUE
73214 330 CONTINUE
73215
73216C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
73217 ELSEIF(MTABU.EQ.31) THEN
73218 NEVFM=NEVFM+1
73219 NLOW=N+MSTU(3)
73220 NUPP=NLOW
73221 DO 410 I=1,N
73222 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
73223 IF(MSTU(41).GE.2) THEN
73224 KC=PYCOMP(K(I,2))
73225 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73226 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73227 & K(I,2).EQ.KSUSY1+39) GOTO 410
73228 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73229 & PYCHGE(K(I,2)).EQ.0) GOTO 410
73230 ENDIF
73231 PMR=0D0
73232 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73233 IF(MSTU(42).GE.2) PMR=P(I,5)
73234 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
73235 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
73236 & 1D20)),P(I,3))
73237 IF(ABS(YETA).GT.PARU(57)) GOTO 410
73238 PHI=PYANGL(P(I,1),P(I,2))
73239 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
73240 IYETA=MAX(0,MIN(511,IYETA))
73241 IPHI=512D0*(PHI+PARU(1))/PARU(2)
73242 IPHI=MAX(0,MIN(511,IPHI))
73243 IYEP=0
73244 DO 340 IB=0,9
73245 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
73246 340 CONTINUE
73247
73248C...Order particles in (pseudo)rapidity and/or azimuth.
73249 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73250 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73251 RETURN
73252 ENDIF
73253 NUPP=NUPP+1
73254 IF(NUPP.EQ.NLOW+1) THEN
73255 K(NUPP,1)=IYETA
73256 K(NUPP,2)=IPHI
73257 K(NUPP,3)=IYEP
73258 ELSE
73259 DO 350 I1=NUPP-1,NLOW+1,-1
73260 IF(IYETA.GE.K(I1,1)) GOTO 360
73261 K(I1+1,1)=K(I1,1)
73262 350 CONTINUE
73263 360 K(I1+1,1)=IYETA
73264 DO 370 I1=NUPP-1,NLOW+1,-1
73265 IF(IPHI.GE.K(I1,2)) GOTO 380
73266 K(I1+1,2)=K(I1,2)
73267 370 CONTINUE
73268 380 K(I1+1,2)=IPHI
73269 DO 390 I1=NUPP-1,NLOW+1,-1
73270 IF(IYEP.GE.K(I1,3)) GOTO 400
73271 K(I1+1,3)=K(I1,3)
73272 390 CONTINUE
73273 400 K(I1+1,3)=IYEP
73274 ENDIF
73275 410 CONTINUE
73276 K(NUPP+1,1)=2**10
73277 K(NUPP+1,2)=2**10
73278 K(NUPP+1,3)=4**10
73279
73280C...Calculate sum of factorial moments in event.
73281 DO 480 IM=1,3
73282 DO 430 IB=1,10
73283 DO 420 IP=1,4
73284 FEVFM(IB,IP)=0D0
73285 420 CONTINUE
73286 430 CONTINUE
73287 DO 450 IB=1,10
73288 IF(IM.LE.2) IBIN=2**(10-IB)
73289 IF(IM.EQ.3) IBIN=4**(10-IB)
73290 IAGR=K(NLOW+1,IM)/IBIN
73291 NAGR=1
73292 DO 440 I=NLOW+2,NUPP+1
73293 ICUT=K(I,IM)/IBIN
73294 IF(ICUT.EQ.IAGR) THEN
73295 NAGR=NAGR+1
73296 ELSE
73297 IF(NAGR.EQ.1) THEN
73298 ELSEIF(NAGR.EQ.2) THEN
73299 FEVFM(IB,1)=FEVFM(IB,1)+2D0
73300 ELSEIF(NAGR.EQ.3) THEN
73301 FEVFM(IB,1)=FEVFM(IB,1)+6D0
73302 FEVFM(IB,2)=FEVFM(IB,2)+6D0
73303 ELSEIF(NAGR.EQ.4) THEN
73304 FEVFM(IB,1)=FEVFM(IB,1)+12D0
73305 FEVFM(IB,2)=FEVFM(IB,2)+24D0
73306 FEVFM(IB,3)=FEVFM(IB,3)+24D0
73307 ELSE
73308 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
73309 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
73310 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73311 & (NAGR-3D0)
73312 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73313 & (NAGR-3D0)*(NAGR-4D0)
73314 ENDIF
73315 IAGR=ICUT
73316 NAGR=1
73317 ENDIF
73318 440 CONTINUE
73319 450 CONTINUE
73320
73321C...Add results to total statistics.
73322 DO 470 IB=10,1,-1
73323 DO 460 IP=1,4
73324 IF(FEVFM(1,IP).LT.0.5D0) THEN
73325 FEVFM(IB,IP)=0D0
73326 ELSEIF(IM.LE.2) THEN
73327 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73328 ELSE
73329 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73330 ENDIF
73331 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
73332 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
73333 460 CONTINUE
73334 470 CONTINUE
73335 480 CONTINUE
73336 NMUFM=NMUFM+(NUPP-NLOW)
73337 MSTU(62)=NUPP-NLOW
73338
73339C...Write accumulated statistics on factorial moments.
73340 ELSEIF(MTABU.EQ.32) THEN
73341 FAC=1D0/MAX(1,NEVFM)
73342 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
73343 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
73344 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
73345 DO 510 IM=1,3
73346 WRITE(MSTU(11),5500)
73347 DO 500 IB=1,10
73348 BYETA=2D0*PARU(57)
73349 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
73350 BPHI=PARU(2)
73351 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
73352 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
73353 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
73354 DO 490 IP=1,4
73355 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
73356 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73357 & FMOMA(IP)**2)))
73358 490 CONTINUE
73359 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
73360 & IP=1,4)
73361 500 CONTINUE
73362 510 CONTINUE
73363
73364C...Copy statistics on factorial moments into /PYJETS/.
73365 ELSEIF(MTABU.EQ.33) THEN
73366 FAC=1D0/MAX(1,NEVFM)
73367 DO 540 IM=1,3
73368 DO 530 IB=1,10
73369 I=10*(IM-1)+IB
73370 K(I,1)=32
73371 K(I,2)=99
73372 K(I,3)=1
73373 IF(IM.NE.2) K(I,3)=2**(IB-1)
73374 K(I,4)=1
73375 IF(IM.NE.1) K(I,4)=2**(IB-1)
73376 K(I,5)=0
73377 P(I,1)=2D0*PARU(57)/K(I,3)
73378 V(I,1)=PARU(2)/K(I,4)
73379 DO 520 IP=1,4
73380 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
73381 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73382 & P(I,IP+1)**2)))
73383 520 CONTINUE
73384 530 CONTINUE
73385 540 CONTINUE
73386 N=30
73387 DO 550 J=1,5
73388 K(N+1,J)=0
73389 P(N+1,J)=0D0
73390 V(N+1,J)=0D0
73391 550 CONTINUE
73392 K(N+1,1)=32
73393 K(N+1,2)=99
73394 K(N+1,5)=NEVFM
73395 MSTU(3)=1
73396
73397C...Reset statistics on Energy-Energy Correlation.
73398 ELSEIF(MTABU.EQ.40) THEN
73399 NEVEE=0
73400 DO 560 J=1,25
73401 FE1EC(J)=0D0
73402 FE2EC(J)=0D0
73403 FE1EC(51-J)=0D0
73404 FE2EC(51-J)=0D0
73405 FE1EA(J)=0D0
73406 FE2EA(J)=0D0
73407 560 CONTINUE
73408
73409C...Find particles to include, with proper assumed mass.
73410 ELSEIF(MTABU.EQ.41) THEN
73411 NEVEE=NEVEE+1
73412 NLOW=N+MSTU(3)
73413 NUPP=NLOW
73414 ECM=0D0
73415 DO 570 I=1,N
73416 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
73417 IF(MSTU(41).GE.2) THEN
73418 KC=PYCOMP(K(I,2))
73419 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73420 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73421 & K(I,2).EQ.KSUSY1+39) GOTO 570
73422 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73423 & PYCHGE(K(I,2)).EQ.0) GOTO 570
73424 ENDIF
73425 PMR=0D0
73426 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73427 IF(MSTU(42).GE.2) PMR=P(I,5)
73428 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73429 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73430 RETURN
73431 ENDIF
73432 NUPP=NUPP+1
73433 P(NUPP,1)=P(I,1)
73434 P(NUPP,2)=P(I,2)
73435 P(NUPP,3)=P(I,3)
73436 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73437 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
73438 ECM=ECM+P(NUPP,4)
73439 570 CONTINUE
73440 IF(NUPP.EQ.NLOW) RETURN
73441
73442C...Analyze Energy-Energy Correlation in event.
73443 FAC=(2D0/ECM**2)*50D0/PARU(1)
73444 DO 580 J=1,50
73445 FEVEE(J)=0D0
73446 580 CONTINUE
73447 DO 600 I1=NLOW+2,NUPP
73448 DO 590 I2=NLOW+1,I1-1
73449 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
73450 & (P(I1,5)*P(I2,5))
73451 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
73452 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
73453 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
73454 590 CONTINUE
73455 600 CONTINUE
73456 DO 610 J=1,25
73457 FE1EC(J)=FE1EC(J)+FEVEE(J)
73458 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
73459 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
73460 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
73461 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
73462 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
73463 610 CONTINUE
73464 MSTU(62)=NUPP-NLOW
73465
73466C...Write statistics on Energy-Energy Correlation.
73467 ELSEIF(MTABU.EQ.42) THEN
73468 FAC=1D0/MAX(1,NEVEE)
73469 WRITE(MSTU(11),5700) NEVEE
73470 DO 620 J=1,25
73471 FEEC1=FAC*FE1EC(J)
73472 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
73473 FEEC2=FAC*FE1EC(51-J)
73474 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
73475 FEECA=FAC*FE1EA(J)
73476 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
73477 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
73478 & FEEC2,FEES2,FEECA,FEESA
73479 620 CONTINUE
73480
73481C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
73482 ELSEIF(MTABU.EQ.43) THEN
73483 FAC=1D0/MAX(1,NEVEE)
73484 DO 630 I=1,25
73485 K(I,1)=32
73486 K(I,2)=99
73487 K(I,3)=0
73488 K(I,4)=0
73489 K(I,5)=0
73490 P(I,1)=FAC*FE1EC(I)
73491 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
73492 P(I,2)=FAC*FE1EC(51-I)
73493 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
73494 P(I,3)=FAC*FE1EA(I)
73495 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
73496 P(I,4)=PARU(1)*(I-1)/50D0
73497 P(I,5)=PARU(1)*I/50D0
73498 V(I,4)=3.6D0*(I-1)
73499 V(I,5)=3.6D0*I
73500 630 CONTINUE
73501 N=25
73502 DO 640 J=1,5
73503 K(N+1,J)=0
73504 P(N+1,J)=0D0
73505 V(N+1,J)=0D0
73506 640 CONTINUE
73507 K(N+1,1)=32
73508 K(N+1,2)=99
73509 K(N+1,5)=NEVEE
73510 MSTU(3)=1
73511
73512C...Reset statistics on decay channels.
73513 ELSEIF(MTABU.EQ.50) THEN
73514 NEVDC=0
73515 NKFDC=0
73516 NREDC=0
73517
73518C...Identify and order flavour content of final state.
73519 ELSEIF(MTABU.EQ.51) THEN
73520 NEVDC=NEVDC+1
73521 NDS=0
73522 DO 670 I=1,N
73523 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
73524 NDS=NDS+1
73525 IF(NDS.GT.8) THEN
73526 NREDC=NREDC+1
73527 RETURN
73528 ENDIF
73529 KFM=2*IABS(K(I,2))
73530 IF(K(I,2).LT.0) KFM=KFM-1
73531 DO 650 IDS=NDS-1,1,-1
73532 IIN=IDS+1
73533 IF(KFM.LT.KFDM(IDS)) GOTO 660
73534 KFDM(IDS+1)=KFDM(IDS)
73535 650 CONTINUE
73536 IIN=1
73537 660 KFDM(IIN)=KFM
73538 670 CONTINUE
73539
73540C...Find whether old or new final state.
73541 DO 690 IDC=1,NKFDC
73542 IF(NDS.LT.KFDC(IDC,0)) THEN
73543 IKFDC=IDC
73544 GOTO 700
73545 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
73546 DO 680 I=1,NDS
73547 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
73548 IKFDC=IDC
73549 GOTO 700
73550 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
73551 GOTO 690
73552 ENDIF
73553 680 CONTINUE
73554 IKFDC=-IDC
73555 GOTO 700
73556 ENDIF
73557 690 CONTINUE
73558 IKFDC=NKFDC+1
73559 700 IF(IKFDC.LT.0) THEN
73560 IKFDC=-IKFDC
73561 ELSEIF(NKFDC.GE.200) THEN
73562 NREDC=NREDC+1
73563 RETURN
73564 ELSE
73565 DO 720 IDC=NKFDC,IKFDC,-1
73566 NPDC(IDC+1)=NPDC(IDC)
73567 DO 710 I=0,8
73568 KFDC(IDC+1,I)=KFDC(IDC,I)
73569 710 CONTINUE
73570 720 CONTINUE
73571 NKFDC=NKFDC+1
73572 KFDC(IKFDC,0)=NDS
73573 DO 730 I=1,NDS
73574 KFDC(IKFDC,I)=KFDM(I)
73575 730 CONTINUE
73576 NPDC(IKFDC)=0
73577 ENDIF
73578 NPDC(IKFDC)=NPDC(IKFDC)+1
73579
73580C...Write statistics on decay channels.
73581 ELSEIF(MTABU.EQ.52) THEN
73582 FAC=1D0/MAX(1,NEVDC)
73583 WRITE(MSTU(11),5900) NEVDC
73584 DO 750 IDC=1,NKFDC
73585 DO 740 I=1,KFDC(IDC,0)
73586 KFM=KFDC(IDC,I)
73587 KF=(KFM+1)/2
73588 IF(2*KF.NE.KFM) KF=-KF
73589 CALL PYNAME(KF,CHAU)
73590 CHDC(I)=CHAU(1:12)
73591 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
73592 740 CONTINUE
73593 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
73594 750 CONTINUE
73595 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
73596
73597C...Copy statistics on decay channels into /PYJETS/.
73598 ELSEIF(MTABU.EQ.53) THEN
73599 FAC=1D0/MAX(1,NEVDC)
73600 DO 780 IDC=1,NKFDC
73601 K(IDC,1)=32
73602 K(IDC,2)=99
73603 K(IDC,3)=0
73604 K(IDC,4)=0
73605 K(IDC,5)=KFDC(IDC,0)
73606 DO 760 J=1,5
73607 P(IDC,J)=0D0
73608 V(IDC,J)=0D0
73609 760 CONTINUE
73610 DO 770 I=1,KFDC(IDC,0)
73611 KFM=KFDC(IDC,I)
73612 KF=(KFM+1)/2
73613 IF(2*KF.NE.KFM) KF=-KF
73614 IF(I.LE.5) P(IDC,I)=KF
73615 IF(I.GE.6) V(IDC,I-5)=KF
73616 770 CONTINUE
73617 V(IDC,5)=FAC*NPDC(IDC)
73618 780 CONTINUE
73619 N=NKFDC
73620 DO 790 J=1,5
73621 K(N+1,J)=0
73622 P(N+1,J)=0D0
73623 V(N+1,J)=0D0
73624 790 CONTINUE
73625 K(N+1,1)=32
73626 K(N+1,2)=99
73627 K(N+1,5)=NEVDC
73628 V(N+1,5)=FAC*NREDC
73629 MSTU(3)=1
73630 ENDIF
73631
73632C...Format statements for output on unit MSTU(11) (default 6).
73633 5000 FORMAT(///20X,'Event statistics - initial state'/
73634 &20X,'based on an analysis of ',I6,' events'//
73635 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
73636 &'according to fragmenting system multiplicity'/
73637 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
73638 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
73639 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
73640 5200 FORMAT(///20X,'Event statistics - final state'/
73641 &20X,'based on an analysis of ',I7,' events'//
73642 &5X,'Mean primary multiplicity =',F10.4/
73643 &5X,'Mean final multiplicity =',F10.4/
73644 &5X,'Mean charged multiplicity =',F10.4//
73645 &5X,'Number of particles produced per event (directly and via ',
73646 &'decays/branchings)'/
73647 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
73648 &8X,'Total'/35X,'prim seco prim seco'/)
73649 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
73650 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
73651 &20X,'based on an analysis of ',I6,' events'//
73652 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
73653 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
73654 5500 FORMAT(10X)
73655 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
73656 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
73657 &20X,'based on an analysis of ',I6,' events'//
73658 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
73659 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
73660 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
73661 5900 FORMAT(///20X,'Decay channel analysis - final state'/
73662 &20X,'based on an analysis of ',I6,' events'//
73663 &2X,'Probability',10X,'Complete final state'/)
73664 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
73665 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
73666 &'or table overflow)')
73667
73668 RETURN
73669 END
73670
73671C*********************************************************************
73672
73673C...PYEEVT
73674C...Handles the generation of an e+e- annihilation jet event.
73675
73676 SUBROUTINE PYEEVT(KFL,ECM)
73677
73678C...Double precision and integer declarations.
73679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73680 IMPLICIT INTEGER(I-N)
73681 INTEGER PYK,PYCHGE,PYCOMP
73682C...Commonblocks.
73683 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73685 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73686 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73687
73688C...Check input parameters.
73689 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73690 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73691 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
73692 IF(MSTU(21).GE.1) RETURN
73693 ENDIF
73694 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
73695 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
73696 IF(ECM.LT.ECMMIN) THEN
73697 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
73698 IF(MSTU(21).GE.1) RETURN
73699 ENDIF
73700
73701C...Check consistency of MSTJ options set.
73702 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
73703 CALL PYERRM(6,
73704 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
73705 MSTJ(110)=1
73706 ENDIF
73707 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
73708 CALL PYERRM(6,
73709 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
73710 MSTJ(111)=0
73711 ENDIF
73712
73713C...Initialize alpha_strong and total cross-section.
73714 MSTU(111)=MSTJ(108)
73715 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73716 &MSTU(111)=1
73717 PARU(112)=PARJ(121)
73718 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73719 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
73720 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
73721 &XTOT)
73722 IF(MSTJ(116).GE.3) MSTJ(116)=1
73723 PARJ(171)=0D0
73724
73725C...Add initial e+e- to event record (documentation only).
73726 NTRY=0
73727 100 NTRY=NTRY+1
73728 IF(NTRY.GT.100) THEN
73729 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
73730 RETURN
73731 ENDIF
73732 MSTU(24)=0
73733 NC=0
73734 IF(MSTJ(115).GE.2) THEN
73735 NC=NC+2
73736 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73737 K(NC-1,1)=21
73738 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73739 K(NC,1)=21
73740 ENDIF
73741
73742C...Radiative photon (in initial state).
73743 MK=0
73744 ECMC=ECM
73745 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
73746 &THEK,PHIK,ALPK)
73747 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
73748 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
73749 NC=NC+1
73750 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
73751 K(NC,3)=MIN(MSTJ(115)/2,1)
73752 ENDIF
73753
73754C...Virtual exchange boson (gamma or Z0).
73755 IF(MSTJ(115).GE.3) THEN
73756 NC=NC+1
73757 KF=22
73758 IF(MSTJ(102).EQ.2) KF=23
73759 MSTU10=MSTU(10)
73760 MSTU(10)=1
73761 P(NC,5)=ECMC
73762 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
73763 K(NC,1)=21
73764 K(NC,3)=1
73765 MSTU(10)=MSTU10
73766 ENDIF
73767
73768C...Choice of flavour and jet configuration.
73769 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
73770 IF(KFLC.EQ.0) GOTO 100
73771 CALL PYXJET(ECMC,NJET,CUT)
73772 KFLN=21
73773 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
73774 &X12,X14)
73775 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
73776 IF(NJET.EQ.2) MSTJ(120)=1
73777
73778C...Fill jet configuration and origin.
73779 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
73780 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
73781 &ECMC)
73782 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
73783 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
73784 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73785 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
73786 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73787 IF(MSTU(24).NE.0) GOTO 100
73788 DO 110 IP=NC+1,N
73789 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
73790 110 CONTINUE
73791
73792C...Angular orientation according to matrix element.
73793 IF(MSTJ(106).EQ.1) THEN
73794 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
73795 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73796 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73797 ENDIF
73798
73799C...Rotation and boost from radiative photon.
73800 IF(MK.EQ.1) THEN
73801 DBEK=-PAK/(ECM-PAK)
73802 NMIN=NC+1-MSTJ(115)/3
73803 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
73804 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
73805 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
73806 ENDIF
73807
73808C...Generate parton shower. Rearrange along strings and check.
73809 IF(MSTJ(101).EQ.5) THEN
73810 CALL PYSHOW(N-1,N,ECMC)
73811 MSTJ14=MSTJ(14)
73812 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73813 IF(MSTJ(105).GE.0) MSTU(28)=0
73814 CALL PYPREP(0)
73815 MSTJ(14)=MSTJ14
73816 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73817 ENDIF
73818
73819C...Fragmentation/decay generation. Information for PYTABU.
73820 IF(MSTJ(105).EQ.1) CALL PYEXEC
73821 MSTU(161)=KFLC
73822 MSTU(162)=-KFLC
73823
73824 RETURN
73825 END
73826
73827C*********************************************************************
73828
73829C...PYXTEE
73830C...Calculates total cross-section, including initial state
73831C...radiation effects.
73832
73833 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
73834
73835C...Double precision and integer declarations.
73836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73837 IMPLICIT INTEGER(I-N)
73838 INTEGER PYK,PYCHGE,PYCOMP
73839C...Commonblocks.
73840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73842 SAVE /PYDAT1/,/PYDAT2/
73843
73844C...Status, (optimized) Q^2 scale, alpha_strong.
73845 PARJ(151)=ECM
73846 MSTJ(119)=10*MSTJ(102)+KFL
73847 IF(MSTJ(111).EQ.0) THEN
73848 Q2R=ECM**2
73849 ELSEIF(MSTU(111).EQ.0) THEN
73850 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
73851 & ((33D0-2D0*MSTU(112))*PARU(111)))))
73852 Q2R=PARJ(168)*ECM**2
73853 ELSE
73854 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
73855 & (2D0*PARU(112)/ECM)**2))
73856 Q2R=PARJ(168)*ECM**2
73857 ENDIF
73858 ALSPI=PYALPS(Q2R)/PARU(1)
73859
73860C...QCD corrections factor in R.
73861 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
73862 RQCD=1D0
73863 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
73864 RQCD=1D0+ALSPI
73865 ELSEIF(MSTJ(109).EQ.0) THEN
73866 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
73867 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
73868 & LOG(PARJ(168))*ALSPI**2)
73869 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
73870 RQCD=1D0+(3D0/4D0)*ALSPI
73871 ELSE
73872 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
73873 ENDIF
73874
73875C...Calculate Z0 width if default value not acceptable.
73876 IF(MSTJ(102).GE.3) THEN
73877 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
73878 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
73879 DO 100 KFLC=5,6
73880 VQ=1D0
73881 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
73882 & (2D0*PYMASS(KFLC)/ ECM)**2))
73883 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
73884 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
73885 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
73886 100 CONTINUE
73887 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
73888 & (1D0-PARU(102)))
73889 ENDIF
73890
73891C...Calculate propagator and related constants for QFD case.
73892 POLL=1D0-PARJ(131)*PARJ(132)
73893 IF(MSTJ(102).GE.2) THEN
73894 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73895 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73896 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73897 VE=4D0*PARU(102)-1D0
73898 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
73899 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
73900 HF1I=SFI*SF1I
73901 HF1W=SFW*SF1W
73902 ENDIF
73903
73904C...Loop over different flavours: charge, velocity.
73905 RTOT=0D0
73906 RQQ=0D0
73907 RQV=0D0
73908 RVA=0D0
73909 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
73910 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
73911 MSTJ(93)=1
73912 PMQ=PYMASS(KFLC)
73913 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
73914 QF=KCHG(KFLC,1)/3D0
73915 VQ=1D0
73916 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
73917
73918C...Calculate R and sum of charges for QED or QFD case.
73919 RQQ=RQQ+3D0*QF**2*POLL
73920 IF(MSTJ(102).LE.1) THEN
73921 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
73922 ELSE
73923 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
73924 RQV=RQV-6D0*QF*VF*SF1I
73925 RVA=RVA+3D0*(VF**2+1D0)*SF1W
73926 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
73927 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
73928 ENDIF
73929 110 CONTINUE
73930 RSUM=RQQ
73931 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
73932
73933C...Calculate cross-section, including QCD corrections.
73934 PARJ(141)=RQQ
73935 PARJ(142)=RTOT
73936 PARJ(143)=RTOT*RQCD
73937 PARJ(144)=PARJ(143)
73938 PARJ(145)=PARJ(141)*86.8D0/ECM**2
73939 PARJ(146)=PARJ(142)*86.8D0/ECM**2
73940 PARJ(147)=PARJ(143)*86.8D0/ECM**2
73941 PARJ(148)=PARJ(147)
73942 PARJ(157)=RSUM*RQCD
73943 PARJ(158)=0D0
73944 PARJ(159)=0D0
73945 XTOT=PARJ(147)
73946 IF(MSTJ(107).LE.0) RETURN
73947
73948C...Virtual cross-section.
73949 XKL=PARJ(135)
73950 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
73951 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
73952 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
73953 &1.526D0*LOG(ECM**2/0.932D0)
73954
73955C...Soft and hard radiative cross-section in QED case.
73956 IF(MSTJ(102).LE.1) THEN
73957 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
73958 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
73959 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
73960
73961C...Soft and hard radiative cross-section in QFD case.
73962 ELSE
73963 SZM=1D0-(PARJ(123)/ECM)**2
73964 SZW=PARJ(123)*PARJ(124)/ECM**2
73965 PARJ(161)=-RQQ/RSUM
73966 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
73967 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
73968 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
73969 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
73970 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
73971 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
73972 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
73973 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
73974 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
73975 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
73976 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
73977 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
73978 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
73979 ENDIF
73980
73981C...Total cross-section and fraction of hard photon events.
73982 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
73983 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
73984 PARJ(144)=PARJ(157)
73985 PARJ(148)=PARJ(144)*86.8D0/ECM**2
73986 XTOT=PARJ(148)
73987
73988 RETURN
73989 END
73990
73991C*********************************************************************
73992
73993C...PYRADK
73994C...Generates initial state photon radiation.
73995
73996 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
73997
73998C...Double precision and integer declarations.
73999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74000 IMPLICIT INTEGER(I-N)
74001 INTEGER PYK,PYCHGE,PYCOMP
74002C...Commonblocks.
74003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74004 SAVE /PYDAT1/
74005
74006C...Function: cumulative hard photon spectrum in QFD case.
74007 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
74008 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
74009
74010C...Determine whether radiative photon or not.
74011 MK=0
74012 PAK=0D0
74013 IF(PARJ(160).LT.PYR(0)) RETURN
74014 MK=1
74015
74016C...Photon energy range. Find photon momentum in QED case.
74017 XKL=PARJ(135)
74018 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
74019 IF(MSTJ(102).LE.1) THEN
74020 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
74021 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
74022
74023C...Ditto in QFD case, by numerical inversion of integrated spectrum.
74024 ELSE
74025 SZM=1D0-(PARJ(123)/ECM)**2
74026 SZW=PARJ(123)*PARJ(124)/ECM**2
74027 FXKL=FXK(XKL)
74028 FXKU=FXK(XKU)
74029 FXKD=1D-4*(FXKU-FXKL)
74030 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
74031 NXK=0
74032 110 NXK=NXK+1
74033 XK=0.5D0*(XKL+XKU)
74034 FXKV=FXK(XK)
74035 IF(FXKV.GT.FXKR) THEN
74036 XKU=XK
74037 FXKU=FXKV
74038 ELSE
74039 XKL=XK
74040 FXKL=FXKV
74041 ENDIF
74042 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
74043 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
74044 ENDIF
74045 PAK=0.5D0*ECM*XK
74046
74047C...Photon polar and azimuthal angle.
74048 PME=2D0*(PYMASS(11)/ECM)**2
74049 120 CTHM=PME*(2D0/PME)**PYR(0)
74050 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
74051 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
74052 CTHE=1D0-CTHM
74053 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
74054 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
74055 THEK=PYANGL(CTHE,STHE)
74056 PHIK=PARU(2)*PYR(0)
74057
74058C...Rotation angle for hadronic system.
74059 SGN=1D0
74060 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
74061 &PYR(0)) SGN=-1D0
74062 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
74063 &(2D0-XK*(1D0-SGN*CTHE)))
74064
74065 RETURN
74066 END
74067
74068C*********************************************************************
74069
74070C...PYXKFL
74071C...Selects flavour for produced qqbar pair.
74072
74073 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
74074
74075C...Double precision and integer declarations.
74076 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74077 IMPLICIT INTEGER(I-N)
74078 INTEGER PYK,PYCHGE,PYCOMP
74079C...Commonblocks.
74080 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74081 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74082 SAVE /PYDAT1/,/PYDAT2/
74083
74084C...Calculate maximum weight in QED or QFD case.
74085 IF(MSTJ(102).LE.1) THEN
74086 RFMAX=4D0/9D0
74087 ELSE
74088 POLL=1D0-PARJ(131)*PARJ(132)
74089 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74090 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74091 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
74092 VE=4D0*PARU(102)-1D0
74093 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
74094 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
74095 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
74096 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
74097 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
74098 & 1D0)*HF1W)
74099 ENDIF
74100
74101C...Choose flavour. Gives charge and velocity.
74102 NTRY=0
74103 100 NTRY=NTRY+1
74104 IF(NTRY.GT.100) THEN
74105 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
74106 KFLC=0
74107 RETURN
74108 ENDIF
74109 KFLC=KFL
74110 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
74111 MSTJ(93)=1
74112 PMQ=PYMASS(KFLC)
74113 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
74114 QF=KCHG(KFLC,1)/3D0
74115 VQ=1D0
74116 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
74117
74118C...Calculate weight in QED or QFD case.
74119 IF(MSTJ(102).LE.1) THEN
74120 RF=QF**2
74121 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
74122 ELSE
74123 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
74124 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
74125 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
74126 & VQ**3*HF1W
74127 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
74128 ENDIF
74129
74130C...Weighting or new event (radiative photon). Cross-section update.
74131 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
74132 PARJ(158)=PARJ(158)+1D0
74133 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
74134 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
74135 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
74136 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
74137 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74138
74139 RETURN
74140 END
74141
74142C*********************************************************************
74143
74144C...PYXJET
74145C...Selects number of jets in matrix element approach.
74146
74147 SUBROUTINE PYXJET(ECM,NJET,CUT)
74148
74149C...Double precision and integer declarations.
74150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74151 IMPLICIT INTEGER(I-N)
74152 INTEGER PYK,PYCHGE,PYCOMP
74153C...Commonblocks.
74154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74155 SAVE /PYDAT1/
74156C...Local array and data.
74157 DIMENSION ZHUT(5)
74158 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
74159
74160C...Trivial result for two-jets only, including parton shower.
74161 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74162 CUT=0D0
74163
74164C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
74165 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
74166 CF=4D0/3D0
74167 IF(MSTJ(109).EQ.2) CF=1D0
74168 IF(MSTJ(111).EQ.0) THEN
74169 Q2=ECM**2
74170 Q2R=ECM**2
74171 ELSEIF(MSTU(111).EQ.0) THEN
74172 PARJ(169)=MIN(1D0,PARJ(129))
74173 Q2=PARJ(169)*ECM**2
74174 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
74175 & ((33D0-2D0*MSTU(112))*PARU(111)))))
74176 Q2R=PARJ(168)*ECM**2
74177 ELSE
74178 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
74179 Q2=PARJ(169)*ECM**2
74180 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
74181 & (2D0*PARU(112)/ECM)**2))
74182 Q2R=PARJ(168)*ECM**2
74183 ENDIF
74184
74185C...alpha_strong for R and R itself.
74186 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
74187 IF(IABS(MSTJ(101)).EQ.1) THEN
74188 RQCD=1D0+ALSPI
74189 ELSEIF(MSTJ(109).EQ.0) THEN
74190 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
74191 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
74192 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
74193 ELSE
74194 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
74195 ENDIF
74196
74197C...alpha_strong for jet rate. Initial value for y cut.
74198 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74199 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
74200 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
74201 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
74202 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74203
74204C...Parametrization of first order three-jet cross-section.
74205 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
74206 PARJ(152)=0D0
74207 ELSE
74208 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
74209 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
74210 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
74211 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
74212 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
74213 & PARJ(152)=0D0
74214 ENDIF
74215
74216C...Parametrization of second order three-jet cross-section.
74217 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
74218 & CUT.GE.0.25D0) THEN
74219 PARJ(153)=0D0
74220 ELSEIF(MSTJ(110).LE.1) THEN
74221 CT=LOG(1D0/CUT-2D0)
74222 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
74223 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
74224
74225C...Interpolation in second/first order ratio for Zhu parametrization.
74226 ELSEIF(MSTJ(110).EQ.2) THEN
74227 IZA=0
74228 DO 110 IY=1,5
74229 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74230 110 CONTINUE
74231 IF(IZA.NE.0) THEN
74232 ZHURAT=ZHUT(IZA)
74233 ELSE
74234 IZ=100D0*CUT
74235 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
74236 ENDIF
74237 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
74238 ENDIF
74239
74240C...Shift in second order three-jet cross-section with optimized Q^2.
74241 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
74242 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
74243 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
74244
74245C...Parametrization of second order four-jet cross-section.
74246 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
74247 PARJ(154)=0D0
74248 ELSE
74249 CT=LOG(1D0/CUT-5D0)
74250 IF(CUT.LE.0.018D0) THEN
74251 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
74252 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
74253 & 0.4059D0*CT**2)
74254 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
74255 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74256 ELSE
74257 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
74258 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
74259 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
74260 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
74261 & 0.002093D0*CT**3)
74262 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74263 ENDIF
74264 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
74265 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
74266 ENDIF
74267
74268C...If negative three-jet rate, change y' optimization parameter.
74269 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
74270 & PARJ(169).LT.0.99D0) THEN
74271 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74272 Q2=PARJ(169)*ECM**2
74273 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74274 GOTO 100
74275 ENDIF
74276
74277C...If too high cross-section, use harder cuts, or fail.
74278 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
74279 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
74280 & PARJ(169).LT.0.99D0) THEN
74281 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74282 Q2=PARJ(169)*ECM**2
74283 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74284 GOTO 100
74285 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
74286 CALL PYERRM(26,
74287 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
74288 ENDIF
74289 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
74290 & PARJ(154))**(-1D0/3D0)
74291 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74292 GOTO 100
74293 ENDIF
74294
74295C...Scalar gluon (first order only).
74296 ELSE
74297 ALSPI=PYALPS(ECM**2)/PARU(1)
74298 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
74299 PARJ(152)=0D0
74300 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
74301 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
74302 PARJ(153)=0D0
74303 PARJ(154)=0D0
74304 ENDIF
74305
74306C...Select number of jets.
74307 PARJ(150)=CUT
74308 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74309 NJET=2
74310 ELSEIF(MSTJ(101).LE.0) THEN
74311 NJET=MIN(4,2-MSTJ(101))
74312 ELSE
74313 RNJ=PYR(0)
74314 NJET=2
74315 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
74316 IF(PARJ(154).GT.RNJ) NJET=4
74317 ENDIF
74318
74319 RETURN
74320 END
74321
74322C*********************************************************************
74323
74324C...PYX3JT
74325C...Selects the kinematical variables of three-jet events.
74326
74327 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
74328
74329C...Double precision and integer declarations.
74330 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74331 IMPLICIT INTEGER(I-N)
74332 INTEGER PYK,PYCHGE,PYCOMP
74333C...Commonblocks.
74334 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74335 SAVE /PYDAT1/
74336C...Local array.
74337 DIMENSION ZHUP(5,12)
74338
74339C...Coefficients of Zhu second order parametrization.
74340 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
74341 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
74342 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
74343 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
74344 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
74345 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
74346 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
74347 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
74348 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
74349 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
74350 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
74351
74352C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
74353 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
74354 &X**7/49D0
74355
74356C...Event type. Mass effect factors and other common constants.
74357 MSTJ(120)=2
74358 MSTJ(121)=0
74359 PMQ=PYMASS(KFL)
74360 QME=(2D0*PMQ/ECM)**2
74361 IF(MSTJ(109).NE.1) THEN
74362 CUTL=LOG(CUT)
74363 CUTD=LOG(1D0/CUT-2D0)
74364 IF(MSTJ(109).EQ.0) THEN
74365 CF=4D0/3D0
74366 CN=3D0
74367 TR=2D0
74368 WTMX=MIN(20D0,37D0-6D0*CUTD)
74369 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
74370 ELSE
74371 CF=1D0
74372 CN=0D0
74373 TR=12D0
74374 WTMX=0D0
74375 ENDIF
74376
74377C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
74378 ALS2PI=PARU(118)/PARU(2)
74379 WTOPT=0D0
74380 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
74381 & LOG(PARJ(169))*ALS2PI
74382 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
74383
74384C...Choose three-jet events in allowed region.
74385 100 NJET=3
74386 110 Y13L=CUTL+CUTD*PYR(0)
74387 Y23L=CUTL+CUTD*PYR(0)
74388 Y13=EXP(Y13L)
74389 Y23=EXP(Y23L)
74390 Y12=1D0-Y13-Y23
74391 IF(Y12.LE.CUT) GOTO 110
74392 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
74393
74394C...Second order corrections.
74395 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
74396 Y12L=LOG(Y12)
74397 Y13M=LOG(1D0-Y13)
74398 Y23M=LOG(1D0-Y23)
74399 Y12M=LOG(1D0-Y12)
74400 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
74401 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
74402 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
74403 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
74404 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
74405 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
74406 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
74407 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
74408 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
74409 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
74410 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
74411 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
74412 & TR*(2D0*CUTL/3D0-10D0/9D0)+
74413 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
74414 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
74415 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
74416 & Y13*Y23)/(Y12+Y13)**2)/WT1+
74417 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
74418 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
74419 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
74420 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
74421 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
74422 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
74423 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
74424 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74425 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74426 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
74427
74428 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
74429C...Second order corrections; Zhu parametrization of ERT.
74430 ZX=(Y23-Y13)**2
74431 ZY=1D0-Y12
74432 IZA=0
74433 DO 120 IY=1,5
74434 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74435 120 CONTINUE
74436 IF(IZA.NE.0) THEN
74437 IZ=IZA
74438 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74439 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74440 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74441 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74442 ELSE
74443 IZ=100D0*CUT
74444 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74445 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74446 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74447 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74448 IZ=IZ+1
74449 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74450 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74451 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74452 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74453 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
74454 ENDIF
74455 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74456 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74457 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
74458 ENDIF
74459
74460C...Impose mass cuts (gives two jets). For fixed jet number new try.
74461 X1=1D0-Y23
74462 X2=1D0-Y13
74463 X3=1D0-Y12
74464 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
74465 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
74466 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
74467 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
74468 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
74469
74470C...Scalar gluon model (first order only, no mass effects).
74471 ELSE
74472 130 NJET=3
74473 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
74474 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
74475 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
74476 X1=1D0-0.5D0*(X3+YD)
74477 X2=1D0-0.5D0*(X3-YD)
74478 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
74479 IF(MSTJ(102).GE.2) THEN
74480 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
74481 & X3**2*PYR(0)) NJET=2
74482 ENDIF
74483 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
74484 ENDIF
74485
74486 RETURN
74487 END
74488
74489C*********************************************************************
74490
74491C...PYX4JT
74492C...Selects the kinematical variables of four-jet events.
74493
74494 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
74495
74496C...Double precision and integer declarations.
74497 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74498 IMPLICIT INTEGER(I-N)
74499 INTEGER PYK,PYCHGE,PYCOMP
74500C...Commonblocks.
74501 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74502 SAVE /PYDAT1/
74503C...Local arrays.
74504 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
74505
74506C...Common constants. Colour factors for QCD and Abelian gluon theory.
74507 PMQ=PYMASS(KFL)
74508 QME=(2D0*PMQ/ECM)**2
74509 CT=LOG(1D0/CUT-5D0)
74510 IF(MSTJ(109).EQ.0) THEN
74511 CF=4D0/3D0
74512 CN=3D0
74513 TR=2.5D0
74514 ELSE
74515 CF=1D0
74516 CN=0D0
74517 TR=15D0
74518 ENDIF
74519
74520C...Choice of process (qqbargg or qqbarqqbar).
74521 100 NJET=4
74522 IT=1
74523 IF(PARJ(155).GT.PYR(0)) IT=2
74524 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
74525 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
74526 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
74527 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
74528 ID=1
74529
74530C...Sample the five kinematical variables (for qqgg preweighted in y34).
74531 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74532 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74533 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
74534 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
74535 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
74536 VT=PYR(0)
74537 CP=COS(PARU(1)*PYR(0))
74538 Y14=(Y134-Y34)*VT
74539 Y13=Y134-Y14-Y34
74540 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
74541 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
74542 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
74543 Y23=Y234-Y34-Y24
74544 Y12=1D0-Y134-Y23-Y24
74545 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
74546 Y123=Y12+Y13+Y23
74547 Y124=Y12+Y14+Y24
74548
74549C...Calculate matrix elements for qqgg or qqqq process.
74550 IC=0
74551 WTTOT=0D0
74552 120 IC=IC+1
74553 IF(IT.EQ.1) THEN
74554 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
74555 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
74556 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
74557 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
74558 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
74559 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
74560 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
74561 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
74562 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
74563 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
74564 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
74565 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
74566 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
74567 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
74568 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
74569 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
74570 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
74571 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
74572 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
74573 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
74574 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
74575 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
74576 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
74577 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
74578 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
74579 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
74580 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
74581 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
74582 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
74583 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
74584 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
74585 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
74586 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
74587 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
74588 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
74589 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
74590 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
74591 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
74592 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
74593 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
74594 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
74595 & CN*WTC(IC))/8D0
74596 ELSE
74597 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
74598 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
74599 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
74600 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
74601 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
74602 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
74603 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
74604 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
74605 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
74606 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
74607 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
74608 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
74609 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
74610 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
74611 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
74612 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
74613 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
74614 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
74615 ENDIF
74616
74617C...Permutations of momenta in matrix element. Weighting.
74618 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
74619 YSAV=Y13
74620 Y13=Y14
74621 Y14=YSAV
74622 YSAV=Y23
74623 Y23=Y24
74624 Y24=YSAV
74625 YSAV=Y123
74626 Y123=Y124
74627 Y124=YSAV
74628 ENDIF
74629 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
74630 YSAV=Y13
74631 Y13=Y23
74632 Y23=YSAV
74633 YSAV=Y14
74634 Y14=Y24
74635 Y24=YSAV
74636 YSAV=Y134
74637 Y134=Y234
74638 Y234=YSAV
74639 ENDIF
74640 IF(IC.LE.3) GOTO 120
74641 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
74642 IC=5
74643
74644C...qqgg events: string configuration and event type.
74645 IF(IT.EQ.1) THEN
74646 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
74647 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
74648 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
74649 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
74650 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
74651 IF(ID.EQ.2) GOTO 130
74652 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
74653 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
74654 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
74655 IF(ID.EQ.2) GOTO 130
74656 ENDIF
74657 MSTJ(120)=3
74658 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
74659 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
74660 KFLN=21
74661
74662C...Mass cuts. Kinematical variables out.
74663 IF(Y12.LE.CUT+QME) NJET=2
74664 IF(NJET.EQ.2) GOTO 150
74665 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
74666 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
74667 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
74668 X2=1D0-Y124
74669 X12=(1D0-Q12)*Y13+Q12*Y23
74670 X14=Y12-0.5D0*QME
74671 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74672
74673C...qqbarqqbar events: string configuration, choose new flavour.
74674 ELSE
74675 IF(ID.EQ.1) THEN
74676 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
74677 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
74678 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
74679 IF(WTR.LT.WTD(4)) ID=4
74680 IF(ID.GE.2) GOTO 130
74681 ENDIF
74682 MSTJ(120)=5
74683 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
74684 140 KFLN=1+INT(5D0*PYR(0))
74685 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
74686 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
74687 IF(KFLN.GT.MSTJ(104)) NJET=2
74688 PMQN=PYMASS(KFLN)
74689 QMEN=(2D0*PMQN/ECM)**2
74690
74691C...Mass cuts. Kinematical variables out.
74692 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
74693 IF(NJET.EQ.2) GOTO 150
74694 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
74695 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
74696 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
74697 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
74698 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
74699 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
74700 & Q13*Y23)
74701 X14=Y24-0.5D0*QME
74702 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
74703 & Q13*Y14)
74704 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
74705 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
74706 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74707 ENDIF
74708 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
74709
74710 RETURN
74711 END
74712
74713C*********************************************************************
74714
74715C...PYXDIF
74716C...Gives the angular orientation of events.
74717
74718 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
74719
74720C...Double precision and integer declarations.
74721 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74722 IMPLICIT INTEGER(I-N)
74723 INTEGER PYK,PYCHGE,PYCOMP
74724C...Commonblocks.
74725 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74728 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74729
74730C...Charge. Factors depending on polarization for QED case.
74731 QF=KCHG(KFL,1)/3D0
74732 POLL=1D0-PARJ(131)*PARJ(132)
74733 POLD=PARJ(132)-PARJ(131)
74734 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
74735 HF1=POLL
74736 HF2=0D0
74737 HF3=PARJ(133)**2
74738 HF4=0D0
74739
74740C...Factors depending on flavour, energy and polarization for QFD case.
74741 ELSE
74742 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74743 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74744 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
74745 AE=-1D0
74746 VE=4D0*PARU(102)-1D0
74747 AF=SIGN(1D0,QF)
74748 VF=AF-4D0*QF*PARU(102)
74749 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
74750 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
74751 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
74752 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
74753 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
74754 & SFW*SFF**2*(VE**2-AE**2))
74755 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
74756 & SFF*AE
74757 ENDIF
74758
74759C...Mass factor. Differential cross-sections for two-jet events.
74760 SQ2=SQRT(2D0)
74761 QME=0D0
74762 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
74763 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
74764 IF(NJET.EQ.2) THEN
74765 SIGU=4D0*SQRT(1D0-QME)
74766 SIGL=2D0*QME*SQRT(1D0-QME)
74767 SIGT=0D0
74768 SIGI=0D0
74769 SIGA=0D0
74770 SIGP=4D0
74771
74772C...Kinematical variables. Reduce four-jet event to three-jet one.
74773 ELSE
74774 IF(NJET.EQ.3) THEN
74775 X1=2D0*P(NC+1,4)/ECM
74776 X2=2D0*P(NC+3,4)/ECM
74777 ELSE
74778 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
74779 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
74780 X1=2D0*P(NC+1,4)/ECMR
74781 X2=2D0*P(NC+4,4)/ECMR
74782 ENDIF
74783
74784C...Differential cross-sections for three-jet (or reduced four-jet).
74785 XQ=(1D0-X1)/(1D0-X2)
74786 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
74787 ST12=SQRT(1D0-CT12**2)
74788 IF(MSTJ(109).NE.1) THEN
74789 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
74790 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
74791 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
74792 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
74793 & X2)*XQ
74794 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
74795 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
74796 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
74797 SIGA=X2**2*ST12/SQ2
74798 SIGP=2D0*(X1**2-X2**2*CT12)
74799
74800C...Differential cross-sect for scalar gluons (no mass effects).
74801 ELSE
74802 X3=2D0-X1-X2
74803 XT=X2*ST12
74804 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
74805 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
74806 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
74807 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
74808 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
74809 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
74810 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
74811 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
74812 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
74813 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
74814 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
74815 ENDIF
74816 ENDIF
74817
74818C...Upper bounds for differential cross-section.
74819 HF1A=ABS(HF1)
74820 HF2A=ABS(HF2)
74821 HF3A=ABS(HF3)
74822 HF4A=ABS(HF4)
74823 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
74824 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
74825 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
74826 &2D0*HF2A*ABS(SIGP)
74827
74828C...Generate angular orientation according to differential cross-sect.
74829 100 CHI=PARU(2)*PYR(0)
74830 CTHE=2D0*PYR(0)-1D0
74831 PHI=PARU(2)*PYR(0)
74832 CCHI=COS(CHI)
74833 SCHI=SIN(CHI)
74834 C2CHI=COS(2D0*CHI)
74835 S2CHI=SIN(2D0*CHI)
74836 THE=ACOS(CTHE)
74837 STHE=SIN(THE)
74838 C2PHI=COS(2D0*(PHI-PARJ(134)))
74839 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74840 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
74841 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
74842 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
74843 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
74844 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
74845 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
74846 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
74847 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
74848
74849 RETURN
74850 END
74851
74852C*********************************************************************
74853
74854C...PYONIA
74855C...Generates Upsilon and toponium decays into three gluons
74856C...or two gluons and a photon.
74857
74858 SUBROUTINE PYONIA(KFL,ECM)
74859
74860C...Double precision and integer declarations.
74861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74862 IMPLICIT INTEGER(I-N)
74863 INTEGER PYK,PYCHGE,PYCOMP
74864C...Commonblocks.
74865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74867 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74868 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74869
74870C...Printout. Check input parameters.
74871 IF(MSTU(12).NE.12345) CALL PYLIST(0)
74872 IF(KFL.LT.0.OR.KFL.GT.8) THEN
74873 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
74874 IF(MSTU(21).GE.1) RETURN
74875 ENDIF
74876 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
74877 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
74878 IF(MSTU(21).GE.1) RETURN
74879 ENDIF
74880
74881C...Initial e+e- and onium state (optional).
74882 NC=0
74883 IF(MSTJ(115).GE.2) THEN
74884 NC=NC+2
74885 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
74886 K(NC-1,1)=21
74887 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
74888 K(NC,1)=21
74889 ENDIF
74890 KFLC=IABS(KFL)
74891 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
74892 NC=NC+1
74893 KF=110*KFLC+3
74894 MSTU10=MSTU(10)
74895 MSTU(10)=1
74896 P(NC,5)=ECM
74897 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
74898 K(NC,1)=21
74899 K(NC,3)=1
74900 MSTU(10)=MSTU10
74901 ENDIF
74902
74903C...Choose x1 and x2 according to matrix element.
74904 NTRY=0
74905 100 X1=PYR(0)
74906 X2=PYR(0)
74907 X3=2D0-X1-X2
74908 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
74909 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
74910 NTRY=NTRY+1
74911 NJET=3
74912 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
74913 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
74914
74915C...Photon-gluon-gluon events. Small system modifications. Jet origin.
74916 MSTU(111)=MSTJ(108)
74917 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
74918 &MSTU(111)=1
74919 PARU(112)=PARJ(121)
74920 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
74921 QF=0D0
74922 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
74923 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
74924 MK=0
74925 ECMC=ECM
74926 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
74927 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
74928 & NJET=2
74929 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
74930 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
74931 ELSE
74932 MK=1
74933 ECMC=SQRT(1D0-X1)*ECM
74934 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
74935 K(NC+1,1)=1
74936 K(NC+1,2)=22
74937 K(NC+1,4)=0
74938 K(NC+1,5)=0
74939 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
74940 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
74941 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
74942 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
74943 NJET=2
74944 IF(ECMC.LT.4D0*PARJ(127)) THEN
74945 MSTU10=MSTU(10)
74946 MSTU(10)=1
74947 P(NC+2,5)=ECMC
74948 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
74949 MSTU(10)=MSTU10
74950 NJET=0
74951 ENDIF
74952 ENDIF
74953 DO 110 IP=NC+1,N
74954 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
74955 110 CONTINUE
74956
74957C...Differential cross-sections. Upper limit for cross-section.
74958 IF(MSTJ(106).EQ.1) THEN
74959 SQ2=SQRT(2D0)
74960 HF1=1D0-PARJ(131)*PARJ(132)
74961 HF3=PARJ(133)**2
74962 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
74963 ST13=SQRT(1D0-CT13**2)
74964 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
74965 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
74966 SIGT=0.5D0*SIGL
74967 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
74968 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
74969 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
74970
74971C...Angular orientation of event.
74972 120 CHI=PARU(2)*PYR(0)
74973 CTHE=2D0*PYR(0)-1D0
74974 PHI=PARU(2)*PYR(0)
74975 CCHI=COS(CHI)
74976 SCHI=SIN(CHI)
74977 C2CHI=COS(2D0*CHI)
74978 S2CHI=SIN(2D0*CHI)
74979 THE=ACOS(CTHE)
74980 STHE=SIN(THE)
74981 C2PHI=COS(2D0*(PHI-PARJ(134)))
74982 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74983 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
74984 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
74985 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
74986 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
74987 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
74988 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
74989 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
74990 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
74991 ENDIF
74992
74993C...Generate parton shower. Rearrange along strings and check.
74994 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
74995 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
74996 MSTJ14=MSTJ(14)
74997 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
74998 IF(MSTJ(105).GE.0) MSTU(28)=0
74999 CALL PYPREP(0)
75000 MSTJ(14)=MSTJ14
75001 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
75002 ENDIF
75003
75004C...Generate fragmentation. Information for PYTABU:
75005 IF(MSTJ(105).EQ.1) CALL PYEXEC
75006 MSTU(161)=110*KFLC+3
75007 MSTU(162)=0
75008
75009 RETURN
75010 END
75011
75012C*********************************************************************
75013
75014C...PYBOOK
75015C...Books a histogram.
75016
75017 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
75018
75019C...Double precision declaration.
75020 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75021 IMPLICIT INTEGER(I-N)
75022C...Commonblock.
75023 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75024 SAVE /PYBINS/
75025C...Local character variables.
75026 CHARACTER TITLE*(*), TITFX*60
75027
75028C...Check that input is sensible. Find initial address in memory.
75029 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75030 &'(PYBOOK:) not allowed histogram number')
75031 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
75032 &'(PYBOOK:) not allowed number of bins')
75033 IF(XL.GE.XU) CALL PYERRM(28,
75034 &'(PYBOOK:) x limits in wrong order')
75035 INDX(ID)=IHIST(4)
75036 IHIST(4)=IHIST(4)+28+NX
75037 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
75038 &'(PYBOOK:) out of histogram space')
75039 IS=INDX(ID)
75040
75041C...Store histogram size and reset contents.
75042 BIN(IS+1)=NX
75043 BIN(IS+2)=XL
75044 BIN(IS+3)=XU
75045 BIN(IS+4)=(XU-XL)/NX
75046 CALL PYNULL(ID)
75047
75048C...Store title by conversion to integer to double precision.
75049 TITFX=TITLE//' '
75050 DO 100 IT=1,20
75051 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
75052 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
75053 100 CONTINUE
75054
75055 RETURN
75056 END
75057
75058C*********************************************************************
75059
75060C...PYFILL
75061C...Fills entry in histogram.
75062
75063 SUBROUTINE PYFILL(ID,X,W)
75064
75065C...Double precision declaration.
75066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75067 IMPLICIT INTEGER(I-N)
75068C...Commonblock.
75069 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75070 SAVE /PYBINS/
75071
75072C...Find initial address in memory. Increase number of entries.
75073 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75074 &'(PYFILL:) not allowed histogram number')
75075 IS=INDX(ID)
75076 IF(IS.EQ.0) CALL PYERRM(28,
75077 &'(PYFILL:) filling unbooked histogram')
75078 BIN(IS+5)=BIN(IS+5)+1D0
75079
75080C...Find bin in x, including under/overflow, and fill.
75081 IF(X.LT.BIN(IS+2)) THEN
75082 BIN(IS+6)=BIN(IS+6)+W
75083 ELSEIF(X.GE.BIN(IS+3)) THEN
75084 BIN(IS+8)=BIN(IS+8)+W
75085 ELSE
75086 BIN(IS+7)=BIN(IS+7)+W
75087 IX=(X-BIN(IS+2))/BIN(IS+4)
75088 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
75089 BIN(IS+9+IX)=BIN(IS+9+IX)+W
75090 ENDIF
75091
75092 RETURN
75093 END
75094
75095C*********************************************************************
75096
75097C...PYFACT
75098C...Multiplies histogram contents by factor.
75099
75100 SUBROUTINE PYFACT(ID,F)
75101
75102C...Double precision declaration.
75103 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75104 IMPLICIT INTEGER(I-N)
75105C...Commonblock.
75106 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75107 SAVE /PYBINS/
75108
75109C...Find initial address in memory. Multiply all contents bins.
75110 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75111 &'(PYFACT:) not allowed histogram number')
75112 IS=INDX(ID)
75113 IF(IS.EQ.0) CALL PYERRM(28,
75114 &'(PYFACT:) scaling unbooked histogram')
75115 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
75116 BIN(IX)=F*BIN(IX)
75117 100 CONTINUE
75118
75119 RETURN
75120 END
75121
75122C*********************************************************************
75123
75124C...PYOPER
75125C...Performs operations between histograms.
75126
75127 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
75128
75129C...Double precision declaration.
75130 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75131 IMPLICIT INTEGER(I-N)
75132C...Commonblock.
75133 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75134 SAVE /PYBINS/
75135C...Character variable.
75136 CHARACTER OPER*(*)
75137
75138C...Find initial addresses in memory, and histogram size.
75139 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
75140 &'(PYFACT:) not allowed histogram number')
75141 IS1=INDX(ID1)
75142 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
75143 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
75144 NX=NINT(BIN(IS3+1))
75145 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
75146
75147C...Update info on number of histogram entries.
75148 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
75149 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
75150 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
75151 BIN(IS3+5)=BIN(IS1+5)
75152 ENDIF
75153
75154C...Operations on pair of histograms: addition, subtraction,
75155C...multiplication, division.
75156 IF(OPER.EQ.'+') THEN
75157 DO 100 IX=6,8+NX
75158 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
75159 100 CONTINUE
75160 ELSEIF(OPER.EQ.'-') THEN
75161 DO 110 IX=6,8+NX
75162 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
75163 110 CONTINUE
75164 ELSEIF(OPER.EQ.'*') THEN
75165 DO 120 IX=6,8+NX
75166 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
75167 120 CONTINUE
75168 ELSEIF(OPER.EQ.'/') THEN
75169 DO 130 IX=6,8+NX
75170 FA2=F2*BIN(IS2+IX)
75171 IF(ABS(FA2).LE.1D-20) THEN
75172 BIN(IS3+IX)=0D0
75173 ELSE
75174 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
75175 ENDIF
75176 130 CONTINUE
75177
75178C...Operations on single histogram: multiplication+addition,
75179C...square root+addition, logarithm+addition.
75180 ELSEIF(OPER.EQ.'A') THEN
75181 DO 140 IX=6,8+NX
75182 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
75183 140 CONTINUE
75184 ELSEIF(OPER.EQ.'S') THEN
75185 DO 150 IX=6,8+NX
75186 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
75187 150 CONTINUE
75188 ELSEIF(OPER.EQ.'L') THEN
75189 ZMIN=1D20
75190 DO 160 IX=9,8+NX
75191 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
75192 & ZMIN=0.8D0*BIN(IS1+IX)
75193 160 CONTINUE
75194 DO 170 IX=6,8+NX
75195 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
75196 170 CONTINUE
75197
75198C...Operation on two or three histograms: average and
75199C...standard deviation.
75200 ELSEIF(OPER.EQ.'M') THEN
75201 DO 180 IX=6,8+NX
75202 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75203 BIN(IS2+IX)=0D0
75204 ELSE
75205 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
75206 ENDIF
75207 IF(ID3.NE.0) THEN
75208 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75209 BIN(IS3+IX)=0D0
75210 ELSE
75211 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
75212 & BIN(IS2+IX)**2))
75213 ENDIF
75214 ENDIF
75215 BIN(IS1+IX)=F1*BIN(IS1+IX)
75216 180 CONTINUE
75217 ENDIF
75218
75219 RETURN
75220 END
75221
75222C*********************************************************************
75223
75224C...PYHIST
75225C...Prints and resets all histograms.
75226
75227 SUBROUTINE PYHIST
75228
75229C...Double precision declaration.
75230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75231 IMPLICIT INTEGER(I-N)
75232C...Commonblock.
75233 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75234 SAVE /PYBINS/
75235
75236C...Loop over histograms, print and reset used ones.
75237 DO 100 ID=1,IHIST(1)
75238 IS=INDX(ID)
75239 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
75240 CALL PYPLOT(ID)
75241 CALL PYNULL(ID)
75242 ENDIF
75243 100 CONTINUE
75244
75245 RETURN
75246 END
75247
75248C*********************************************************************
75249
75250C...PYPLOT
75251C...Prints a histogram (but does not reset it).
75252
75253 SUBROUTINE PYPLOT(ID)
75254
75255C...Double precision declaration.
75256 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75257 IMPLICIT INTEGER(I-N)
75258C...Commonblocks.
75259 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75260 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75261 SAVE /PYDAT1/,/PYBINS/
75262C...Local arrays and character variables.
75263 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
75264 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
75265
75266C...Steps in histogram scale. Character sequence.
75267 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
75268 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
75269
75270C...Find initial address in memory; skip if empty histogram.
75271 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75272 IS=INDX(ID)
75273 IF(IS.EQ.0) RETURN
75274 IF(NINT(BIN(IS+5)).LE.0) THEN
75275 WRITE(MSTU(11),5000) ID
75276 RETURN
75277 ENDIF
75278
75279C...Number of histogram lines and x bins.
75280 LIN=IHIST(3)-18
75281 NX=NINT(BIN(IS+1))
75282
75283C...Extract title by conversion from double precision via integer.
75284 DO 100 IT=1,20
75285 IEQ=NINT(BIN(IS+8+NX+IT))
75286 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
75287 & //CHAR(MOD(IEQ,256))
75288 100 CONTINUE
75289
75290C...Find time; print title.
75291 CALL PYTIME(IDATI)
75292 IF(IDATI(1).GT.0) THEN
75293 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
75294 ELSE
75295 WRITE(MSTU(11),5200) ID, TITLE
75296 ENDIF
75297
75298C...Find minimum and maximum bin content.
75299 YMIN=BIN(IS+9)
75300 YMAX=BIN(IS+9)
75301 DO 110 IX=IS+10,IS+8+NX
75302 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
75303 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
75304 110 CONTINUE
75305
75306C...Determine scale and step size for y axis.
75307 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
75308 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
75309 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
75310 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
75311 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
75312 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
75313 DELY=DYAC(1)
75314 DO 120 IDEL=1,9
75315 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
75316 120 CONTINUE
75317 DY=DELY*10D0**IPOT
75318
75319C...Convert bin contents to integer form; fractional fill in top row.
75320 DO 130 IX=1,NX
75321 CTA=ABS(BIN(IS+8+IX))/DY
75322 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
75323 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
75324 130 CONTINUE
75325 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
75326 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
75327
75328C...Print histogram row by row.
75329 DO 150 IR=IRMA,IRMI,-1
75330 IF(IR.EQ.0) GOTO 150
75331 OUT=' '
75332 DO 140 IX=1,NX
75333 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
75334 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
75335 140 CONTINUE
75336 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
75337 150 CONTINUE
75338
75339C...Print sign and value of bin contents.
75340 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
75341 OUT=' '
75342 DO 160 IX=1,NX
75343 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
75344 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
75345 160 CONTINUE
75346 WRITE(MSTU(11),5400) OUT
75347 DO 180 IR=4,1,-1
75348 DO 170 IX=1,NX
75349 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75350 170 CONTINUE
75351 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
75352 180 CONTINUE
75353
75354C...Print sign and value of lower bin edge.
75355 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
75356 & 10.0001D0)-10
75357 OUT=' '
75358 DO 190 IX=1,NX
75359 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
75360 & OUT(IX:IX)=CHA(11)
75361 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
75362 190 CONTINUE
75363 WRITE(MSTU(11),5600) OUT
75364 DO 210 IR=3,1,-1
75365 DO 200 IX=1,NX
75366 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75367 200 CONTINUE
75368 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
75369 210 CONTINUE
75370 ENDIF
75371
75372C...Calculate and print statistics.
75373 CSUM=0D0
75374 CXSUM=0D0
75375 CXXSUM=0D0
75376 DO 220 IX=1,NX
75377 CTA=ABS(BIN(IS+8+IX))
75378 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
75379 CSUM=CSUM+CTA
75380 CXSUM=CXSUM+CTA*X
75381 CXXSUM=CXXSUM+CTA*X**2
75382 220 CONTINUE
75383 XMEAN=CXSUM/MAX(CSUM,1D-20)
75384 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
75385 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
75386 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
75387
75388C...Formats for output.
75389 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
75390 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
75391 &I2,':',I2/)
75392 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
75393 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
75394 5400 FORMAT(/8X,'Contents',3X,A100)
75395 5500 FORMAT(9X,'*10**',I2,3X,A100)
75396 5600 FORMAT(/8X,'Low edge',3X,A100)
75397 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
75398 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
75399 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
75400
75401 RETURN
75402 END
75403
75404C*********************************************************************
75405
75406C...PYNULL
75407C...Resets bin contents of a histogram.
75408
75409 SUBROUTINE PYNULL(ID)
75410
75411C...Double precision declaration.
75412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75413 IMPLICIT INTEGER(I-N)
75414C...Commonblock.
75415 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75416 SAVE /PYBINS/
75417
75418 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75419 IS=INDX(ID)
75420 IF(IS.EQ.0) RETURN
75421 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
75422 BIN(IX)=0D0
75423 100 CONTINUE
75424
75425 RETURN
75426 END
75427
75428C*********************************************************************
75429
75430C...PYDUMP
75431C...Dumps histogram contents on file for reading by other program.
75432C...Can also read back own dump.
75433
75434 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
75435
75436C...Double precision declaration.
75437 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75438 IMPLICIT INTEGER(I-N)
75439C...Commonblock.
75440 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75441 SAVE /PYBINS/
75442C...Local arrays and character variables.
75443 DIMENSION IHI(*),ISS(100),VAL(5)
75444 CHARACTER TITLE*60,FORMAT*13
75445
75446C...Dump all histograms that have been booked,
75447C...including titles and ranges, one after the other.
75448 IF(MDUMP.EQ.1) THEN
75449
75450C...Loop over histograms and find which are wanted and booked.
75451 IF(NHI.LE.0) THEN
75452 NW=IHIST(1)
75453 ELSE
75454 NW=NHI
75455 ENDIF
75456 DO 130 IW=1,NW
75457 IF(NHI.EQ.0) THEN
75458 ID=IW
75459 ELSE
75460 ID=IHI(IW)
75461 ENDIF
75462 IS=INDX(ID)
75463 IF(IS.NE.0) THEN
75464
75465C...Write title, histogram size, filling statistics.
75466 NX=NINT(BIN(IS+1))
75467 DO 100 IT=1,20
75468 IEQ=NINT(BIN(IS+8+NX+IT))
75469 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
75470 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
75471 100 CONTINUE
75472 WRITE(LFN,5100) ID,TITLE
75473 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
75474 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
75475 & BIN(IS+8)
75476
75477
75478C...Write histogram contents, in groups of five.
75479 DO 120 IXG=1,(NX+4)/5
75480 DO 110 IXV=1,5
75481 IX=5*IXG+IXV-5
75482 IF(IX.LE.NX) THEN
75483 VAL(IXV)=BIN(IS+8+IX)
75484 ELSE
75485 VAL(IXV)=0D0
75486 ENDIF
75487 110 CONTINUE
75488 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
75489 120 CONTINUE
75490
75491C...Go to next histogram; finish.
75492 ELSEIF(NHI.GT.0) THEN
75493 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75494 ENDIF
75495 130 CONTINUE
75496
75497C...Read back in histograms dumped MDUMP=1.
75498 ELSEIF(MDUMP.EQ.2) THEN
75499
75500C...Read histogram number, title and range, and book.
75501 140 READ(LFN,5100,END=170) ID,TITLE
75502 READ(LFN,5200) NX,XL,XU
75503 CALL PYBOOK(ID,TITLE,NX,XL,XU)
75504 IS=INDX(ID)
75505
75506C...Read filling statistics.
75507 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
75508 BIN(IS+5)=DBLE(NENTRY)
75509
75510C...Read histogram contents, in groups of five.
75511 DO 160 IXG=1,(NX+4)/5
75512 READ(LFN,5400) (VAL(IXV),IXV=1,5)
75513 DO 150 IXV=1,5
75514 IX=5*IXG+IXV-5
75515 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
75516 150 CONTINUE
75517 160 CONTINUE
75518
75519C...Go to next histogram; finish.
75520 GOTO 140
75521 170 CONTINUE
75522
75523C...Write histogram contents in column format,
75524C...convenient e.g. for GNUPLOT input.
75525 ELSEIF(MDUMP.EQ.3) THEN
75526
75527C...Find addresses to wanted histograms.
75528 NSS=0
75529 IF(NHI.LE.0) THEN
75530 NW=IHIST(1)
75531 ELSE
75532 NW=NHI
75533 ENDIF
75534 DO 180 IW=1,NW
75535 IF(NHI.EQ.0) THEN
75536 ID=IW
75537 ELSE
75538 ID=IHI(IW)
75539 ENDIF
75540 IS=INDX(ID)
75541 IF(IS.NE.0.AND.NSS.LT.100) THEN
75542 NSS=NSS+1
75543 ISS(NSS)=IS
75544 ELSEIF(NSS.GE.100) THEN
75545 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
75546 ELSEIF(NHI.GT.0) THEN
75547 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75548 ENDIF
75549 180 CONTINUE
75550
75551C...Check that they have common number of x bins. Fix format.
75552 NX=NINT(BIN(ISS(1)+1))
75553 DO 190 IW=2,NSS
75554 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
75555 CALL PYERRM(8,'(PYDUMP:) different number of bins')
75556 RETURN
75557 ENDIF
75558 190 CONTINUE
75559 FORMAT='(1P,000E12.4)'
75560 WRITE(FORMAT(5:7),'(I3)') NSS+1
75561
75562C...Write histogram contents; first column x values.
75563 DO 200 IX=1,NX
75564 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
75565 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
75566 200 CONTINUE
75567
75568 ENDIF
75569
75570C...Formats for output.
75571 5100 FORMAT(I5,5X,A60)
75572 5200 FORMAT(I5,1P,2D12.4)
75573 5300 FORMAT(I12,1P,3D12.4)
75574 5400 FORMAT(1P,5D12.4)
75575
75576 RETURN
75577 END
75578
75579C*********************************************************************
75580
75581C...PYSTOP
75582C...Allows users to handle STOP statemens
75583
75584 SUBROUTINE PYSTOP(MCOD)
75585
75586C...Double precision and integer declarations.
75587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75588 IMPLICIT INTEGER(I-N)
75589 INTEGER PYK,PYCHGE,PYCOMP
75590C...Commonblocks.
75591 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75592 SAVE /PYDAT1/
75593
75594
75595C...Write message, then stop
75596 WRITE(MSTU(11),5000) MCOD
75597 STOP
75598
75599
75600C...Formats for output.
75601 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
75602 RETURN
75603 END
75604
75605C*********************************************************************
75606
75607C...PYKCUT
75608C...Dummy routine, which the user can replace in order to make cuts on
75609C...the kinematics on the parton level before the matrix elements are
75610C...evaluated and the event is generated. The cross-section estimates
75611C...will automatically take these cuts into account, so the given
75612C...values are for the allowed phase space region only. MCUT=0 means
75613C...that the event has passed the cuts, MCUT=1 that it has failed.
75614
75615 SUBROUTINE PYKCUT(MCUT)
75616
75617C...Double precision and integer declarations.
75618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75619 IMPLICIT INTEGER(I-N)
75620 INTEGER PYK,PYCHGE,PYCOMP
75621C...Commonblocks.
75622 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75623 COMMON/PYINT1/MINT(400),VINT(400)
75624 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75625 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75626
75627C...Set default value (accepting event) for MCUT.
75628 MCUT=0
75629
75630C...Read out subprocess number.
75631 ISUB=MINT(1)
75632 ISTSB=ISET(ISUB)
75633
75634C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75635 TAU=VINT(21)
75636 YST=VINT(22)
75637 CTH=0D0
75638 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75639 TAUP=0D0
75640 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75641
75642C...Calculate x_1, x_2, x_F.
75643 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
75644 X1=SQRT(TAU)*EXP(YST)
75645 X2=SQRT(TAU)*EXP(-YST)
75646 ELSE
75647 X1=SQRT(TAUP)*EXP(YST)
75648 X2=SQRT(TAUP)*EXP(-YST)
75649 ENDIF
75650 XF=X1-X2
75651
75652C...Calculate shat, that, uhat, p_T^2.
75653 SHAT=TAU*VINT(2)
75654 SQM3=VINT(63)
75655 SQM4=VINT(64)
75656 RM3=SQM3/SHAT
75657 RM4=SQM4/SHAT
75658 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
75659 RPTS=4D0*VINT(71)**2/SHAT
75660 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
75661 RM34=2D0*RM3*RM4
75662 RSQM=1D0+RM34
75663 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
75664 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
75665 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
75666 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
75667
75668C...Decisions by user to be put here.
75669
75670C...Stop program if this routine is ever called.
75671C...You should not copy these lines to your own routine.
75672 WRITE(MSTU(11),5000)
75673 CALL PYSTOP(6)
75674
75675C...Format for error printout.
75676 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
75677 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75678 &1X,'Execution stopped!')
75679
75680 RETURN
75681 END
75682
75683C*********************************************************************
75684
75685C...PYEVWT
75686C...Dummy routine, which the user can replace in order to multiply the
75687C...standard PYTHIA differential cross-section by a process- and
75688C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
75689C...to generation of weighted events, with weight 1/WTXS, while for
75690C...MSTP(142)=2 it corresponds to a modification of the underlying
75691C...physics.
75692
75693 SUBROUTINE PYEVWT(WTXS)
75694
75695C...Double precision and integer declarations.
75696 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75697 IMPLICIT INTEGER(I-N)
75698 INTEGER PYK,PYCHGE,PYCOMP
75699C...Commonblocks.
75700 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75701 COMMON/PYINT1/MINT(400),VINT(400)
75702 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75703 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75704
75705C...Set default weight for WTXS.
75706 WTXS=1D0
75707
75708C...Read out subprocess number.
75709 ISUB=MINT(1)
75710 ISTSB=ISET(ISUB)
75711
75712C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75713 TAU=VINT(21)
75714 YST=VINT(22)
75715 CTH=0D0
75716 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75717 TAUP=0D0
75718 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75719
75720C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
75721 X1=VINT(41)
75722 X2=VINT(42)
75723 XF=X1-X2
75724 SHAT=VINT(44)
75725 THAT=VINT(45)
75726 UHAT=VINT(46)
75727 PT2=VINT(48)
75728
75729C...Modifications by user to be put here.
75730
75731C...Stop program if this routine is ever called.
75732C...You should not copy these lines to your own routine.
75733 WRITE(MSTU(11),5000)
75734 CALL PYSTOP(4)
75735
75736C...Format for error printout.
75737 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
75738 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75739 &1X,'Execution stopped!')
75740
75741 RETURN
75742 END
75743
75744C*********************************************************************
75745
75746C...UPINIT
75747C...Dummy routine, to be replaced by a user implementing external
75748C...processes. Is supposed to fill the HEPRUP commonblock with info
75749C...on incoming beams and allowed processes.
75750
75751C...New example: handles a standard Les Houches Events File.
75752
75753 SUBROUTINE UPINIT
75754
75755C...Double precision and integer declarations.
75756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75757 IMPLICIT INTEGER(I-N)
75758
75759C...PYTHIA commonblock: only used to provide read unit MSTP(161).
75760 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75761 SAVE /PYPARS/
75762
75763C...User process initialization commonblock.
75764 INTEGER MAXPUP
75765 PARAMETER (MAXPUP=100)
75766 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75767 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75768 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75769 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75770 &LPRUP(MAXPUP)
75771 SAVE /HEPRUP/
75772
75773C...Lines to read in assumed never longer than 200 characters.
75774 PARAMETER (MAXLEN=200)
75775 CHARACTER*(MAXLEN) STRING
75776
75777C...Format for reading lines.
75778 CHARACTER*6 STRFMT
75779 STRFMT='(A000)'
75780 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75781
75782C...Loop until finds line beginning with "<init>" or "<init ".
75783 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
75784 IBEG=0
75785 110 IBEG=IBEG+1
75786C...Allow indentation.
75787 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
75788 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
75789 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
75790
75791C...Read first line of initialization info.
75792 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
75793 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75794
75795C...Read NPRUP subsequent lines with information on each process.
75796 DO 120 IPR=1,NPRUP
75797 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
75798 & XMAXUP(IPR),LPRUP(IPR)
75799 120 CONTINUE
75800 RETURN
75801
75802C...Error exit: give up if initalization does not work.
75803 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
75804 WRITE(*,*) ' Event generation will be stopped.'
75805 CALL PYSTOP(12)
75806
75807 RETURN
75808 END
75809
75810C...Old example: handles a simple Pythia 6.4 initialization file.
75811
75812c SUBROUTINE UPINIT
75813
75814C...Double precision and integer declarations.
75815c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75816c IMPLICIT INTEGER(I-N)
75817
75818C...Commonblocks.
75819c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75820c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75821c SAVE /PYDAT1/,/PYPARS/
75822
75823C...User process initialization commonblock.
75824c INTEGER MAXPUP
75825c PARAMETER (MAXPUP=100)
75826c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75827c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75828c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75829c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75830c &LPRUP(MAXPUP)
75831c SAVE /HEPRUP/
75832
75833C...Read info from file.
75834c IF(MSTP(161).GT.0) THEN
75835c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
75836c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75837c DO 100 IPR=1,NPRUP
75838c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
75839c & XMAXUP(IPR),LPRUP(IPR)
75840c 100 CONTINUE
75841c RETURN
75842C...Error or prematurely reached end of file.
75843c 110 WRITE(MSTU(11),5000)
75844c STOP
75845
75846C...Else not implemented.
75847c ELSE
75848c WRITE(MSTU(11),5100)
75849c STOP
75850c ENDIF
75851
75852C...Format for error printout.
75853c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
75854c &1X,'Execution stopped!')
75855c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
75856c &1X,'Dummy routine in PYTHIA file called instead.'/
75857c &1X,'Execution stopped!')
75858
75859c RETURN
75860c END
75861
75862C*********************************************************************
75863
75864C...UPEVNT
75865C...Dummy routine, to be replaced by a user implementing external
75866C...processes. Depending on cross section model chosen, it either has
75867C...to generate a process of the type IDPRUP requested, or pick a type
75868C...itself and generate this event. The event is to be stored in the
75869C...HEPEUP commonblock, including (often) an event weight.
75870
75871C...New example: handles a standard Les Houches Events File.
75872
75873 SUBROUTINE UPEVNT
75874
75875C...Double precision and integer declarations.
75876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75877 IMPLICIT INTEGER(I-N)
75878
75879C...PYTHIA commonblock: only used to provide read unit MSTP(162).
75880 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75881 SAVE /PYPARS/
75882
75883C...User process event common block.
75884 INTEGER MAXNUP
75885 PARAMETER (MAXNUP=500)
75886 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75887 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75888 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75889 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75890 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75891 SAVE /HEPEUP/
75892
75893C...Lines to read in assumed never longer than 200 characters.
75894 PARAMETER (MAXLEN=200)
75895 CHARACTER*(MAXLEN) STRING
75896
75897C...Format for reading lines.
75898 CHARACTER*6 STRFMT
75899 STRFMT='(A000)'
75900 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75901
75902C...Loop until finds line beginning with "<event>" or "<event ".
75903 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
75904 IBEG=0
75905 110 IBEG=IBEG+1
75906C...Allow indentation.
75907 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
75908 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
75909 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
75910
75911C...Read first line of event info.
75912 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
75913 &AQEDUP,AQCDUP
75914
75915C...Read NUP subsequent lines with information on each particle.
75916 DO 120 I=1,NUP
75917 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
75918 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75919 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75920 120 CONTINUE
75921 RETURN
75922
75923C...Error exit, typically when no more events.
75924 130 WRITE(*,*) ' Failed to read LHEF event information.'
75925 WRITE(*,*) ' Will assume end of file has been reached.'
75926 NUP=0
75927 MSTI(51)=1
75928
75929 RETURN
75930 END
75931
75932C...Old example: handles a simple Pythia 6.4 event file.
75933
75934c SUBROUTINE UPEVNT
75935
75936C...Double precision and integer declarations.
75937c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75938c IMPLICIT INTEGER(I-N)
75939
75940C...Commonblocks.
75941c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75942c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75943c SAVE /PYDAT1/,/PYPARS/
75944
75945C...User process event common block.
75946c INTEGER MAXNUP
75947c PARAMETER (MAXNUP=500)
75948c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75949c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75950c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75951c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75952c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75953c SAVE /HEPEUP/
75954
75955C...Read info from file.
75956c IF(MSTP(162).GT.0) THEN
75957c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
75958c & AQEDUP,AQCDUP
75959c DO 100 I=1,NUP
75960c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
75961c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75962c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75963c 100 CONTINUE
75964c RETURN
75965C...Special when reached end of file or other error.
75966c 110 NUP=0
75967
75968C...Else not implemented.
75969c ELSE
75970c WRITE(MSTU(11),5000)
75971c STOP
75972c ENDIF
75973
75974C...Format for error printout.
75975c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
75976c &1X,'Dummy routine in PYTHIA file called instead.'/
75977c &1X,'Execution stopped!')
75978
75979c RETURN
75980c END
75981
75982C*********************************************************************
75983
75984C...UPVETO
75985C...Dummy routine, to be replaced by user, to veto event generation
75986C...on the parton level, after parton showers but before multiple
75987C...interactions, beam remnants and hadronization is added.
75988C...If resonances like W, Z, top, Higgs and SUSY particles are handed
75989C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
75990C...be undecayed at this stage; if decayed their decay products will
75991C...have been allowed to shower.
75992
75993C...All partons at the end of the shower phase are stored in the
75994C...HEPEVT commonblock. The interesting information is
75995C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
75996C...IDHEP(I) = the particle ID code according to PDG conventions,
75997C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
75998C...All ISTHEP entries are 1, while the rest is zeroed.
75999
76000C...The user decision is to be conveyed by the IVETO value.
76001C...IVETO = 0 : retain current event and generate in full;
76002C... = 1 : abort generation of current event and move to next.
76003
76004 SUBROUTINE UPVETO(IVETO)
76005
76006C...HEPEVT commonblock.
76007 PARAMETER (NMXHEP=4000)
76008 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
76009 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
76010 DOUBLE PRECISION PHEP,VHEP
76011 SAVE /HEPEVT/
76012
76013C...Next few lines allow you to see what info PYVETO extracted from
76014C...the full event record for the first two events.
76015C...Delete if you don't want it.
76016 DATA NLIST/0/
76017 SAVE NLIST
76018 IF(NLIST.LE.2) THEN
76019 WRITE(*,*) ' Full event record at time of UPVETO call:'
76020 CALL PYLIST(1)
76021 WRITE(*,*) ' Part of event record made available to UPVETO:'
76022 CALL PYLIST(5)
76023 NLIST=NLIST+1
76024 ENDIF
76025
76026C...Make decision here.
76027 IVETO = 0
76028
76029 RETURN
76030 END
76031
76032C*********************************************************************
76033
76034C*********************************************************************
76035
76036C...SUGRA
76037C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
76038
76039 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
76040 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76041 IMPLICIT INTEGER(I-N)
76042 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
76043 INTEGER IMODL
76044C...Commonblocks.
76045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76046 SAVE /PYDAT1/
76047
76048C...Stop program if this routine is ever called.
76049 WRITE(MSTU(11),5000)
76050 CALL PYSTOP(110)
76051
76052C...Format for error printout.
76053 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76054 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
76055 &1X,'Execution stopped!')
76056
76057 RETURN
76058 END
76059
76060C*********************************************************************
76061
76062C...VISAJE
76063C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76064
76065 FUNCTION VISAJE()
76066 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76067 IMPLICIT INTEGER(I-N)
76068 CHARACTER*40 VISAJE
76069
76070C...Commonblocks.
76071 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76072 SAVE /PYDAT1/
76073
76074C...Assign default value.
76075 VISAJE='Undefined'
76076
76077C...Stop program if this routine is ever called.
76078 WRITE(MSTU(11),5000)
76079 CALL PYSTOP(110)
76080
76081C...Format for error printout.
76082 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76083 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
76084 &1X,'Execution stopped!')
76085
76086 RETURN
76087 END
76088
76089C*********************************************************************
76090
76091C...SSMSSM
76092C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76093
76094 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
76095 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
76096 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
76097 &IDUM1,IDUM2)
76098 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76099 IMPLICIT INTEGER(I-N)
76100 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
76101 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
76102 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
76103C...Commonblocks.
76104 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76105 SAVE /PYDAT1/
76106
76107C...Stop program if this routine is ever called.
76108 WRITE(MSTU(11),5000)
76109 CALL PYSTOP(110)
76110
76111C...Format for error printout.
76112 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76113 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
76114 &1X,'Execution stopped!')
76115 RETURN
76116 END
76117
76118C*********************************************************************
76119
76120C...FHSETFLAGS
76121C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76122
76123 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
76124 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76125 IMPLICIT INTEGER(I-N)
76126Cmssmpart = 4 # full MSSM [recommended]
76127Cfieldren = 0 # MSbar field ren. [strongly recommended]
76128Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
76129Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
76130Cp2approx = 0 # no approximation [recommended]
76131Clooplevel= 2 # include 2-loop corrections
76132Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
76133Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
76134
76135C...Commonblocks.
76136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76137 SAVE /PYDAT1/
76138
76139C...Stop program if this routine is ever called.
76140 WRITE(MSTU(11),5000)
76141 CALL PYSTOP(103)
76142
76143C...Format for error printout.
76144 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76145 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
76146 &1X,'Execution stopped!')
76147 RETURN
76148 END
76149
76150C*********************************************************************
76151
76152C...FHSETPARA
76153C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76154
76155 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
76156 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
76157 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
76158 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
76159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76160 IMPLICIT INTEGER(I-N)
76161
76162 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76163 DOUBLE COMPLEX DMU,
76164 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76165 & DM1, DM2, DM3
76166
76167C...Commonblocks.
76168 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76169 SAVE /PYDAT1/
76170
76171C...Stop program if this routine is ever called.
76172 WRITE(MSTU(11),5000)
76173 CALL PYSTOP(103)
76174
76175C...Format for error printout.
76176 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76177 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76178 &1X,'Execution stopped!')
76179 RETURN
76180 END
76181
76182C*********************************************************************
76183
76184C...FHHIGGSCORR
76185C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76186
76187 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
76188 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76189 IMPLICIT INTEGER(I-N)
76190
76191C...FeynHiggs variables
76192 DOUBLE PRECISION RMHIGG(4)
76193 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76194 DOUBLE COMPLEX DMU,
76195 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76196 & DM1, DM2, DM3
76197
76198C...Commonblocks.
76199 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76200 SAVE /PYDAT1/
76201
76202C...Stop program if this routine is ever called.
76203 WRITE(MSTU(11),5000)
76204 CALL PYSTOP(103)
76205
76206C...Format for error printout.
76207 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76208 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76209 &1X,'Execution stopped!')
76210 RETURN
76211 END
76212
76213C*********************************************************************
76214
76215C...PYTAUD
76216C...Dummy routine, to be replaced by user, to handle the decay of a
76217C...polarized tau lepton.
76218C...Input:
76219C...ITAU is the position where the decaying tau is stored in /PYJETS/.
76220C...IORIG is the position where the mother of the tau is stored;
76221C... is 0 when the mother is not stored.
76222C...KFORIG is the flavour of the mother of the tau;
76223C... is 0 when the mother is not known.
76224C...Note that IORIG=0 does not necessarily imply KFORIG=0;
76225C... e.g. in B hadron semileptonic decays the W propagator
76226C... is not explicitly stored but the W code is still unambiguous.
76227C...Output:
76228C...NDECAY is the number of decay products in the current tau decay.
76229C...These decay products should be added to the /PYJETS/ common block,
76230C...in positions N+1 through N+NDECAY. For each product I you must
76231C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
76232C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
76233
76234 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
76235
76236C...Double precision and integer declarations.
76237 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76238 IMPLICIT INTEGER(I-N)
76239 INTEGER PYK,PYCHGE,PYCOMP
76240C...Commonblocks.
76241 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76242 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76243 SAVE /PYJETS/,/PYDAT1/
76244
76245C...Stop program if this routine is ever called.
76246C...You should not copy these lines to your own routine.
76247 NDECAY=ITAU+IORIG+KFORIG
76248 WRITE(MSTU(11),5000)
76249 CALL PYSTOP(10)
76250
76251C...Format for error printout.
76252 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
76253 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
76254 &1X,'Execution stopped!')
76255
76256 RETURN
76257 END
76258
76259C*********************************************************************
76260
76261C...PYTIME
76262C...Finds current date and time.
76263C...Since this task is not standardized in Fortran 77, the routine
76264C...is dummy, to be replaced by the user. Examples are given for
76265C...the Fortran 90 routine and DEC Fortran 77, and what to do if
76266C...you do not have access to suitable routines.
76267
76268 SUBROUTINE PYTIME(IDATI)
76269
76270C...Double precision and integer declarations.
76271 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76272 IMPLICIT INTEGER(I-N)
76273 INTEGER PYK,PYCHGE,PYCOMP
76274 CHARACTER*8 ATIME
76275C...Local array.
76276 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
76277
76278C...Example 0: if you do not have suitable routines.
76279 DO 100 J=1,6
76280 IDATI(J)=0
76281 100 CONTINUE
76282
76283C...Example 1: Fortran 90 routine.
76284C CALL DATE_AND_TIME(VALUES=IVAL)
76285C IDATI(1)=IVAL(1)
76286C IDATI(2)=IVAL(2)
76287C IDATI(3)=IVAL(3)
76288C IDATI(4)=IVAL(5)
76289C IDATI(5)=IVAL(6)
76290C IDATI(6)=IVAL(7)
76291
76292C...Example 2: DEC Fortran 77. AIX.
76293C CALL IDATE(IMON,IDAY,IYEAR)
76294C IDATI(1)=IYEAR
76295C IDATI(2)=IMON
76296C IDATI(3)=IDAY
76297C CALL ITIME(IHOUR,IMIN,ISEC)
76298C IDATI(4)=IHOUR
76299C IDATI(5)=IMIN
76300C IDATI(6)=ISEC
76301
76302C...Example 3: DEC Fortran, IRIX, IRIX64.
76303C CALL IDATE(IMON,IDAY,IYEAR)
76304C IDATI(1)=IYEAR
76305C IDATI(2)=IMON
76306C IDATI(3)=IDAY
76307C CALL TIME(ATIME)
76308C IHOUR=0
76309C IMIN=0
76310C ISEC=0
76311C READ(ATIME(1:2),'(I2)') IHOUR
76312C READ(ATIME(4:5),'(I2)') IMIN
76313C READ(ATIME(7:8),'(I2)') ISEC
76314C IDATI(4)=IHOUR
76315C IDATI(5)=IMIN
76316C IDATI(6)=ISEC
76317
76318C...Example 4: GNU LINUX libU77, SunOS.
76319C CALL IDATE(IDTEMP)
76320C IDATI(1)=IDTEMP(3)
76321C IDATI(2)=IDTEMP(2)
76322C IDATI(3)=IDTEMP(1)
76323C CALL ITIME(IDTEMP)
76324C IDATI(4)=IDTEMP(1)
76325C IDATI(5)=IDTEMP(2)
76326C IDATI(6)=IDTEMP(3)
76327
76328C...Common code to ensure right century.
76329 IDATI(1)=2000+MOD(IDATI(1),100)
76330
76331 RETURN
76332 END